diff options
Diffstat (limited to 'noao/imred/ccdred/src')
145 files changed, 37319 insertions, 0 deletions
diff --git a/noao/imred/ccdred/src/calimage.x b/noao/imred/ccdred/src/calimage.x new file mode 100644 index 00000000..82efdf54 --- /dev/null +++ b/noao/imred/ccdred/src/calimage.x @@ -0,0 +1,367 @@ +include <error.h> +include <imset.h> +include "ccdtypes.h" + +define SZ_SUBSET 16 # Maximum size of subset string +define IMAGE Memc[$1+($2-1)*SZ_FNAME] # Image string +define SUBSET Memc[$1+($2-1)*(SZ_SUBSET+1)] # Subset string + +# CAL_IMAGE -- Return a calibration image for a specified input image. +# CAL_OPEN -- Open the calibration image list. +# CAL_CLOSE -- Close the calibration image list. +# CAL_LIST -- Add images to the calibration image list. +# +# The open procedure is called first to get the calibration image +# lists and add them to an internal list. Calibration images from the +# input list are also added so that calibration images may be specified +# either from the calibration image list parameters or in the input image list. +# Existence errors and duplicate calibration images are ignored. +# Validity checks are made when the calibration images are requested. +# +# During processing the calibration image names are requested for each input +# image. The calibration image list is searched for a calibration image of +# the right type and subset. If more than one is found the first one is +# returned and a warning given for the others. The warning is only issued +# once. If no calibration image is found then an error is returned. +# +# The calibration image list must be closed at the end of processing the +# input images. + + +# CAL_IMAGE -- Return a calibration image of a particular type. +# Search the calibration list for the first calibration image of the desired +# type and subset. Print a warning if there is more than one possible +# calibration image and return an error if there is no calibration image. + +procedure cal_image (im, ccdtype, nscan, image, maxchars) + +pointer im # Image to be processed +int ccdtype # Callibration CCD image type desired +int nscan # Number of scan rows desired +char image[maxchars] # Calibration image (returned) +int maxchars # Maximum number chars in image name + +int i, m, n +pointer sp, subset, str +bool strne(), ccd_cmp() + +pointer ccdtypes # Pointer to array of calibration ccdtypes +pointer subsets # Pointer to array of calibration subsets +pointer nscans # Pointer to array of calibration nscan values +pointer images # Pointer to array of calibration image names +int nimages # Number of images +common /calib/ ccdtypes, subsets, nscans, images, nimages + +begin + call smark (sp) + call salloc (subset, SZ_SUBSET, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + m = 0 + n = 0 + switch (ccdtype) { + case ZERO, DARK: + do i = 1, nimages { + if (Memi[ccdtypes+i-1] != ccdtype) + next + n = n + 1 + if (n == 1) { + m = i + } else { + if (Memi[nscans+i-1] == Memi[nscans+m-1]) { +# call eprintf ( +# "Warning: Extra calibration image %s ignored\n") +# call pargstr (IMAGE(images,i)) + + # Reset the image type to eliminate further warnings. + Memi[ccdtypes+i-1] = UNKNOWN + } else if (Memi[nscans+m-1] != nscan && + (Memi[nscans+i-1] == nscan || + Memi[nscans+i-1] == 1)) { + m = i + } + } + } + case FLAT, ILLUM, FRINGE: + call ccdsubset (im, Memc[subset], SZ_SUBSET) + + do i = 1, nimages { + if (Memi[ccdtypes+i-1] != ccdtype) + next + if (strne (SUBSET(subsets,i), Memc[subset])) + next + n = n + 1 + if (n == 1) { + m = i + } else { + if (Memi[nscans+i-1] == Memi[nscans+m-1]) { +# call eprintf ( +# "Warning: Extra calibration image %s ignored\n") +# call pargstr (IMAGE(images,i)) + + # Reset the image type to eliminate further warnings. + Memi[ccdtypes+i-1] = UNKNOWN + } else if (Memi[nscans+m-1] != nscan && + (Memi[nscans+i-1] == nscan || + Memi[nscans+i-1] == 1)) { + m = i + } + } + } + } + + # If no calibration image is found then it is an error. + if (m == 0) { + switch (ccdtype) { + case ZERO: + call error (0, "No zero level calibration image found") + case DARK: + call error (0, "No dark count calibration image found") + case FLAT: + call sprintf (Memc[str], SZ_LINE, + "No flat field calibration image of subset %s found") + call pargstr (Memc[subset]) + call error (0, Memc[str]) + case ILLUM: + call sprintf (Memc[str], SZ_LINE, + "No illumination calibration image of subset %s found") + call pargstr (Memc[subset]) + call error (0, Memc[str]) + case FRINGE: + call sprintf (Memc[str], SZ_LINE, + "No fringe calibration image of subset %s found") + call pargstr (Memc[subset]) + call error (0, Memc[str]) + } + } + + call strcpy (IMAGE(images,m), image, maxchars) + if (nscan != Memi[nscans+m-1]) { + if (nscan != 1 && Memi[nscans+m-1] == 1) + call cal_scan (nscan, image, maxchars) + else { + call sprintf (Memc[str], SZ_LINE, + "Cannot find or create calibration with nscan of %d") + call pargi (nscan) + call error (0, Memc[str]) + } + } + + # Check that the input image is not the same as the calibration image. + call imstats (im, IM_IMAGENAME, Memc[str], SZ_LINE) + if (ccd_cmp (Memc[str], IMAGE(images,m))) { + call sprintf (Memc[str], SZ_LINE, + "Calibration image %s is the same as the input image") + call pargstr (image) + call error (0, Memc[str]) + } + + call sfree (sp) +end + + +# CAL_OPEN -- Create a list of calibration images from the input image list +# and the calibration image lists. + +procedure cal_open (list) + +int list # List of input images +int list1 # List of calibration images + +pointer sp, str +int ccdtype, strdic(), imtopenp() +bool clgetb() + +pointer ccdtypes # Pointer to array of calibration ccdtypes +pointer subsets # Pointer to array of calibration subset numbers +pointer nscans # Pointer to array of calibration nscan values +pointer images # Pointer to array of calibration image names +int nimages # Number of images +common /calib/ ccdtypes, subsets, nscans, images, nimages + +errchk cal_list + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + call clgstr ("ccdtype", Memc[str], SZ_LINE) + call xt_stripwhite (Memc[str]) + if (Memc[str] == EOS) + ccdtype = NONE + else + ccdtype = strdic (Memc[str], Memc[str], SZ_LINE, CCDTYPES) + + # Add calibration images to list. + nimages = 0 + if (ccdtype != ZERO && clgetb ("zerocor")) { + list1 = imtopenp ("zero") + call cal_list (list1, ZERO) + call imtclose (list1) + } + if (ccdtype != ZERO && ccdtype != DARK && clgetb ("darkcor")) { + list1 = imtopenp ("dark") + call cal_list (list1, DARK) + call imtclose (list1) + } + if (ccdtype != ZERO && ccdtype != DARK && ccdtype != FLAT && + clgetb ("flatcor")) { + list1 = imtopenp ("flat") + call cal_list (list1, FLAT) + call imtclose (list1) + } + if (ccdtype != ZERO && ccdtype != DARK && ccdtype != FLAT && + ccdtype != ILLUM && clgetb ("illumcor")) { + list1 = imtopenp ("illum") + call cal_list (list1, ILLUM) + call imtclose (list1) + } + if (ccdtype != ZERO && ccdtype != DARK && ccdtype != FLAT && + ccdtype != FRINGE && clgetb ("fringecor")) { + list1 = imtopenp ("fringe") + call cal_list (list1, FRINGE) + call imtclose (list1) + } + if (list != NULL) { + call cal_list (list, UNKNOWN) + call imtrew (list) + } + + call sfree (sp) +end + + +# CAL_CLOSE -- Free memory from the internal calibration image list. + +procedure cal_close () + +pointer ccdtypes # Pointer to array of calibration ccdtypes +pointer subsets # Pointer to array of calibration subset +pointer nscans # Pointer to array of calibration nscan values +pointer images # Pointer to array of calibration image names +int nimages # Number of images +common /calib/ ccdtypes, subsets, nscans, images, nimages + +begin + if (nimages > 0) { + call mfree (ccdtypes, TY_INT) + call mfree (subsets, TY_CHAR) + call mfree (nscans, TY_INT) + call mfree (images, TY_CHAR) + } +end + + +# CAL_LIST -- Add calibration images to an internal list. +# Map each image and get the CCD image type and subset. +# If the ccdtype is given as a procedure argument this overrides the +# image header type. For the calibration images add the type, subset, +# and image name to dynamic arrays. Ignore duplicate names. + +procedure cal_list (list, listtype) + +pointer list # Image list +int listtype # CCD type of image in list. + # Overrides header type if not UNKNOWN. + +int i, ccdtype, ccdtypei(), ccdnscan(), imtgetim() +pointer sp, image, im, immap() +bool streq() + +pointer ccdtypes # Pointer to array of calibration ccdtypes +pointer subsets # Pointer to array of calibration subsets +pointer nscans # Pointer to array of calibration nscan values +pointer images # Pointer to array of calibration image names +int nimages # Number of images +common /calib/ ccdtypes, subsets, nscans, images, nimages + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + # Open the image. If an explicit type is given it is an + # error if the image can't be opened. + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + if (listtype == UNKNOWN) + next + else + call erract (EA_ERROR) + } + + # Override image header CCD type if a list type is given. + if (listtype == UNKNOWN) + ccdtype = ccdtypei (im) + else + ccdtype = listtype + + switch (ccdtype) { + case ZERO, DARK, FLAT, ILLUM, FRINGE: + # Check for duplication. + for (i=1; i<=nimages; i=i+1) + if (streq (Memc[image], IMAGE(images,i))) + break + if (i <= nimages) + break + + # Allocate memory for a new image. + if (i == 1) { + call malloc (ccdtypes, i, TY_INT) + call malloc (subsets, i * (SZ_SUBSET+1), TY_CHAR) + call malloc (nscans, i, TY_INT) + call malloc (images, i * SZ_FNAME, TY_CHAR) + } else { + call realloc (ccdtypes, i, TY_INT) + call realloc (subsets, i * SZ_FNAME, TY_CHAR) + call realloc (nscans, i, TY_INT) + call realloc (images, i * SZ_FNAME, TY_CHAR) + } + + # Enter the ccdtype, subset, and image name. + Memi[ccdtypes+i-1] = ccdtype + Memi[nscans+i-1] = ccdnscan (im, ccdtype) + call ccdsubset (im, SUBSET(subsets,i), SZ_SUBSET) + call strcpy (Memc[image], IMAGE(images,i), SZ_FNAME-1) + nimages = i + } + call imunmap (im) + } + call sfree (sp) +end + + +# CAL_SCAN -- Generate name for scan corrected calibration image. + +procedure cal_scan (nscan, image, maxchar) + +int nscan #I Number of scan lines +char image[maxchar] #U Input root name, output scan name +int maxchar #I Maximum number of chars in image name + +bool clgetb() +pointer sp, root, ext + +begin + # Check if this operation is desired. + if (!clgetb ("scancor") || nscan == 1) + return + + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (ext, SZ_FNAME, TY_CHAR) + + call xt_imroot (image, Memc[root], SZ_FNAME) + call xt_imext (image, Memc[ext], SZ_FNAME) + if (IS_INDEFI (nscan)) { + call sprintf (image, maxchar, "%s.1d%s") + call pargstr (Memc[root]) + call pargstr (Memc[ext]) + } else { + call sprintf (image, maxchar, "%s.%d%s") + call pargstr (Memc[root]) + call pargi (nscan) + call pargstr (Memc[ext]) + } + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/ccdcache.com b/noao/imred/ccdred/src/ccdcache.com new file mode 100644 index 00000000..91ffae12 --- /dev/null +++ b/noao/imred/ccdred/src/ccdcache.com @@ -0,0 +1,10 @@ +# Common data defining the cached images and data. + +int ccd_ncache # Number of images cached +int ccd_maxcache # Maximum size of cache +int ccd_szcache # Current size of cache +int ccd_oldsize # Original memory size +int ccd_pcache # Pointer to image cache structures + +common /ccdcache_com/ ccd_ncache, ccd_maxcache, ccd_szcache, ccd_oldsize, + ccd_pcache diff --git a/noao/imred/ccdred/src/ccdcache.h b/noao/imred/ccdred/src/ccdcache.h new file mode 100644 index 00000000..f7de3a2c --- /dev/null +++ b/noao/imred/ccdred/src/ccdcache.h @@ -0,0 +1,10 @@ +# Definition for image cache structure. + +define CCD_LENCACHE 6 + +define CCD_IM Memi[$1] # IMIO pointer +define CCD_NACCESS Memi[$1+1] # Number of accesses requested +define CCD_SZDATA Memi[$1+2] # Size of data in cache in chars +define CCD_DATA Memi[$1+3] # Pointer to data cache +define CCD_BUFR Memi[$1+4] # Pointer to real image line +define CCD_BUFS Memi[$1+5] # Pointer to short image line diff --git a/noao/imred/ccdred/src/ccdcache.x b/noao/imred/ccdred/src/ccdcache.x new file mode 100644 index 00000000..78f84ace --- /dev/null +++ b/noao/imred/ccdred/src/ccdcache.x @@ -0,0 +1,381 @@ +include <imhdr.h> +include <imset.h> +include <mach.h> +include "ccdcache.h" + +.help ccdcache Jun87 +.nf --------------------------------------------------------------------- +The purpose of the CCD image caching package is to minimize image mapping +time, to prevent multiple mapping of the same image, and to keep entire +calibration images in memory for extended periods to minimize disk +I/O. It is selected by specifying a maximum caching size based on the +available memory. When there is not enough memory for caching (or by +setting the size to 0) then standard IMIO is used. When there is +enough memory then as many images as will fit into the specified cache +size are kept in memory. Images are also kept mapped until explicitly +flushed or the entire package is closed. + +This is a special purpose interface intended only for the CCDRED package. +It has the following restrictions. + + 1. Images must be processed to be cached. + 2. Images must be 2 dimensional to be cached + 3. Images must be real or short to be cached. + 4. Images must be read_only to be cached. + 5. Cached images remain in memory until they are displaced, + flushed, or the package is closed. + +The package consists of the following procedures. + + ccd_open () + im = ccd_cache (image) + ptr = ccd_glr (im, col1, col2, line) + ptr = ccd_gls (im, col1, col2, line) + ccd_unmap (im) + ccd_flush (im) + ccd_close () + + +CCD_OPEN: Initialize the image cache. Called at the beginning. +CCD_CLOSE: Flush the image cache and restore memory. Called at the end. + +CCD_CACHE: Open an image and save the IMIO pointer. If the image has been +opened previously it need not be opened again. If image data caching +is specified the image data may be read it into memory. In order for +image data caching to occur the the image has to have been processed, +be two dimensional, be real or short, and the total cache memory not +be exceeded. If an error occurs in reading the image into memory +the data is not cached. + +CCD_UNMAP: The image access number is decremented but the image +is not closed against the event it will be used again. + +CCD_FLUSH: The image is closed and flushed from the cache. + +CCD_GLR, CCD_GLS: Get a real or short image line. If the image data is cached +then a pointer to the line is quickly returned. If the data is not cached then +IMIO is used to get the pointer. +.endhelp --------------------------------------------------------------------- + + + +# CCD_CACHE -- Open an image and possibly cache it in memory. + +pointer procedure ccd_cache (image, ccdtype) + +char image[ARB] # Image to be opened +int ccdtype # Image type + +int i, nc, nl, nbytes +pointer sp, str, pcache, pcache1, im + +int sizeof() +pointer immap(), imgs2r(), imgs2s() +bool streq(), ccdcheck() +errchk immap, imgs2r, imgs2s + +include "ccdcache.com" + +define done_ 99 + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Check if the image is cached. + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + im = CCD_IM(pcache) + call imstats (im, IM_IMAGENAME, Memc[str], SZ_LINE) + if (streq (image, Memc[str])) + break + } + + # If the image is not cached open it and allocate memory. + if (i > ccd_ncache) { + im = immap (image, READ_ONLY, 0) + ccd_ncache = i + call realloc (ccd_pcache, ccd_ncache, TY_INT) + call malloc (pcache, CCD_LENCACHE, TY_STRUCT) + Memi[ccd_pcache+i-1] = pcache + CCD_IM(pcache) = im + CCD_NACCESS(pcache) = 0 + CCD_SZDATA(pcache) = 0 + CCD_DATA(pcache) = NULL + CCD_BUFR(pcache) = NULL + CCD_BUFS(pcache) = NULL + } + + # If not caching the image data or if the image data has already + # been cached we are done. + if ((ccd_maxcache == 0) || (CCD_SZDATA(pcache) > 0)) + goto done_ + + # Don't cache unprocessed calibration image data. + # This is the only really CCDRED specific code. + if (ccdcheck (im, ccdtype)) + goto done_ + + # Check image is 2D and a supported pixel type. + if (IM_NDIM(im) != 2) + goto done_ + if ((IM_PIXTYPE(im) != TY_REAL) && (IM_PIXTYPE(im) !=TY_SHORT)) + goto done_ + + # Compute the size of the image data. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + nbytes = nc * nl * sizeof (IM_PIXTYPE(im)) * SZB_CHAR + + # Free memory not in use. + if (ccd_szcache + nbytes > ccd_maxcache) { + for (i=1; i<=ccd_ncache; i=i+1) { + pcache1 = Memi[ccd_pcache+i-1] + if (CCD_NACCESS(pcache1) == 0) { + if (CCD_SZDATA(pcache1) > 0) { + ccd_szcache = ccd_szcache - CCD_SZDATA(pcache1) + CCD_SZDATA(pcache1) = 0 + CCD_DATA(pcache1) = NULL + call mfree (CCD_BUFR(pcache1), TY_REAL) + call mfree (CCD_BUFS(pcache1), TY_SHORT) + call imseti (CCD_IM(pcache1), IM_CANCEL, YES) + if (ccd_szcache + nbytes > ccd_maxcache) + break + } + } + } + } + if (ccd_szcache + nbytes > ccd_maxcache) + goto done_ + + # Cache the image data + iferr { + switch (IM_PIXTYPE (im)) { + case TY_SHORT: + CCD_DATA(pcache) = imgs2s (im, 1, nc, 1, nl) + case TY_REAL: + CCD_DATA(pcache) = imgs2r (im, 1, nc, 1, nl) + } + ccd_szcache = ccd_szcache + nbytes + CCD_SZDATA(pcache) = nbytes + } then { + call imunmap (im) + im = immap (image, READ_ONLY, 0) + CCD_IM(pcache) = im + CCD_SZDATA(pcache) = 0 + } + +done_ + CCD_NACCESS(pcache) = CCD_NACCESS(pcache) + 1 + call sfree (sp) + return (im) +end + + +# CCD_OPEN -- Initialize the CCD image cache. + +procedure ccd_open (max_cache) + +int max_cache # Maximum cache size in bytes + +int max_size, begmem() +include "ccdcache.com" + +begin + ccd_ncache = 0 + ccd_maxcache = max_cache + ccd_szcache = 0 + call malloc (ccd_pcache, 1, TY_INT) + + # Ask for the maximum physical memory. + if (ccd_maxcache > 0) { + ccd_oldsize = begmem (0, ccd_oldsize, max_size) + call fixmem (max_size) + } +end + + +# CCD_UNMAP -- Unmap an image. +# Don't actually unmap the image since it may be opened again. + +procedure ccd_unmap (im) + +pointer im # IMIO pointer + +int i +pointer pcache +include "ccdcache.com" + +begin + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + if (CCD_IM(pcache) == im) { + CCD_NACCESS(pcache) = CCD_NACCESS(pcache) - 1 + return + } + } + + call imunmap (im) +end + + +# CCD_FLUSH -- Close image and flush from cache. + +procedure ccd_flush (im) + +pointer im # IMIO pointer + +int i +pointer pcache +include "ccdcache.com" + +begin + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + if (CCD_IM(pcache) == im) { + ccd_ncache = ccd_ncache - 1 + ccd_szcache = ccd_szcache - CCD_SZDATA(pcache) + call mfree (CCD_BUFR(pcache), TY_REAL) + call mfree (CCD_BUFS(pcache), TY_SHORT) + call mfree (pcache, TY_STRUCT) + for (; i<=ccd_ncache; i=i+1) + Memi[ccd_pcache+i-1] = Memi[ccd_pcache+i] + break + } + } + + call imunmap (im) +end + + +# CCD_CLOSE -- Close the image cache. + +procedure ccd_close () + +int i +pointer pcache +include "ccdcache.com" + +begin + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + call imunmap (CCD_IM(pcache)) + call mfree (CCD_BUFR(pcache), TY_REAL) + call mfree (CCD_BUFS(pcache), TY_SHORT) + call mfree (pcache, TY_STRUCT) + } + call mfree (ccd_pcache, TY_INT) + + # Restore memory. + call fixmem (ccd_oldsize) +end + + +# CCD_GLR -- Get a line of real data from the image. +# If the image data is cached this is fast (particularly if the datatype +# matches). If the image data is not cached then use IMIO. + +pointer procedure ccd_glr (im, col1, col2, line) + +pointer im # IMIO pointer +int col1, col2 # Columns +int line # Line + +int i +pointer pcache, data, bufr, imgs2r() +errchk malloc +include "ccdcache.com" + +begin + # Quick test for cached data. + if (ccd_maxcache == 0) + return (imgs2r (im, col1, col2, line, line)) + + # Return cached data. + if (IM_PIXTYPE(im) == TY_REAL) { + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + if (CCD_IM(pcache) == im) { + if (CCD_SZDATA(pcache) > 0) + return (CCD_DATA(pcache)+(line-1)*IM_LEN(im,1)+col1-1) + else + break + } + } + } else { + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + if (CCD_IM(pcache) == im) { + if (CCD_SZDATA(pcache) > 0) { + data = CCD_DATA(pcache)+(line-1)*IM_LEN(im,1)+col1-1 + bufr = CCD_BUFR(pcache) + if (bufr == NULL) { + call malloc (bufr, IM_LEN(im,1), TY_REAL) + CCD_BUFR(pcache) = bufr + } + call achtsr (Mems[data], Memr[bufr], IM_LEN(im,1)) + return (bufr) + } else + break + } + } + } + + # Return uncached data. + return (imgs2r (im, col1, col2, line, line)) +end + + +# CCD_GLS -- Get a line of short data from the image. +# If the image data is cached this is fast (particularly if the datatype +# matches). If the image data is not cached then use IMIO. + +pointer procedure ccd_gls (im, col1, col2, line) + +pointer im # IMIO pointer +int col1, col2 # Columns +int line # Line + +int i +pointer pcache, data, bufs, imgs2s() +errchk malloc +include "ccdcache.com" + +begin + # Quick test for cached data. + if (ccd_maxcache == 0) + return (imgs2s (im, col1, col2, line, line)) + + # Return cached data. + if (IM_PIXTYPE(im) == TY_SHORT) { + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + if (CCD_IM(pcache) == im) { + if (CCD_SZDATA(pcache) > 0) + return (CCD_DATA(pcache)+(line-1)*IM_LEN(im,1)+col1-1) + else + break + } + } + } else { + for (i=1; i<=ccd_ncache; i=i+1) { + pcache = Memi[ccd_pcache+i-1] + if (CCD_IM(pcache) == im) { + if (CCD_SZDATA(pcache) > 0) { + data = CCD_DATA(pcache)+(line-1)*IM_LEN(im,1)+col1-1 + bufs = CCD_BUFS(pcache) + if (bufs == NULL) { + call malloc (bufs, IM_LEN(im,1), TY_SHORT) + CCD_BUFS(pcache) = bufs + } + call achtrs (Memr[data], Mems[bufs], IM_LEN(im,1)) + return (bufs) + } else + break + } + } + } + + # Return uncached data. + return (imgs2s (im, col1, col2, line, line)) +end diff --git a/noao/imred/ccdred/src/ccdcheck.x b/noao/imred/ccdred/src/ccdcheck.x new file mode 100644 index 00000000..0dde14f9 --- /dev/null +++ b/noao/imred/ccdred/src/ccdcheck.x @@ -0,0 +1,67 @@ +include <imhdr.h> +include "ccdtypes.h" + +# CCDCHECK -- Check processing status. + +bool procedure ccdcheck (im, ccdtype) + +pointer im # IMIO pointer +int ccdtype # CCD type + +real ccdmean, hdmgetr() +bool clgetb(), ccdflag() +long time +int hdmgeti() + +begin + if (clgetb ("trim") && !ccdflag (im, "trim")) + return (true) + if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) + return (true) + if (clgetb ("overscan") && !ccdflag (im, "overscan")) + return (true) + + switch (ccdtype) { + case ZERO: + if (clgetb ("readcor") && !ccdflag (im, "readcor")) + return (true) + case DARK: + if (clgetb ("zerocor") && !ccdflag (im, "zerocor")) + return (true) + case FLAT: + if (clgetb ("zerocor") && !ccdflag (im, "zerocor")) + return (true) + if (clgetb ("darkcor") && !ccdflag (im, "darkcor")) + return (true) + if (clgetb ("scancor") && !ccdflag (im, "scancor")) + return (true) + iferr (ccdmean = hdmgetr (im, "ccdmean")) + return (true) + iferr (time = hdmgeti (im, "ccdmeant")) + time = IM_MTIME(im) + if (time < IM_MTIME(im)) + return (true) + case ILLUM: + if (clgetb ("zerocor") && !ccdflag (im, "zerocor")) + return (true) + if (clgetb ("darkcor") && !ccdflag (im, "darkcor")) + return (true) + if (clgetb ("flatcor") && !ccdflag (im, "flatcor")) + return (true) + iferr (ccdmean = hdmgetr (im, "ccdmean")) + return (true) + default: + if (clgetb ("zerocor") && !ccdflag (im, "zerocor")) + return (true) + if (clgetb ("darkcor") && !ccdflag (im, "darkcor")) + return (true) + if (clgetb ("flatcor") && !ccdflag (im, "flatcor")) + return (true) + if (clgetb ("illumcor") && !ccdflag (im, "illumcor")) + return (true) + if (clgetb ("fringecor") && !ccdflag (im, "fringcor")) + return (true) + } + + return (false) +end diff --git a/noao/imred/ccdred/src/ccdcmp.x b/noao/imred/ccdred/src/ccdcmp.x new file mode 100644 index 00000000..a2687934 --- /dev/null +++ b/noao/imred/ccdred/src/ccdcmp.x @@ -0,0 +1,23 @@ +# CCD_CMP -- Compare two image names with extensions ignored. + +bool procedure ccd_cmp (image1, image2) + +char image1[ARB] # First image +char image2[ARB] # Second image + +int i, j, strmatch(), strlen(), strncmp() +bool streq() + +begin + if (streq (image1, image2)) + return (true) + + i = max (strmatch (image1, ".imh"), strmatch (image1, ".hhh")) + if (i == 0) + i = strlen (image1) + j = max (strmatch (image2, ".imh"), strmatch (image2, ".hhh")) + if (j == 0) + j = strlen (image2) + + return (strncmp (image1, image2, max (i, j)) == 0) +end diff --git a/noao/imred/ccdred/src/ccdcopy.x b/noao/imred/ccdred/src/ccdcopy.x new file mode 100644 index 00000000..a12b2123 --- /dev/null +++ b/noao/imred/ccdred/src/ccdcopy.x @@ -0,0 +1,31 @@ +include <imhdr.h> + +# CCDCOPY -- Copy an image. This should be done with an IMIO procedure +# but there isn't one yet. + +procedure ccdcopy (old, new) + +char old[ARB] # Image to be copied +char new[ARB] # New copy + +int i, nc, nl +pointer in, out, immap(), imgl2s(), impl2s(), imgl2r(), impl2r() + +begin + in = immap (old, READ_ONLY, 0) + out = immap (new, NEW_COPY, in) + + nc = IM_LEN(in,1) + nl = IM_LEN(in,2) + switch (IM_PIXTYPE(in)) { + case TY_SHORT: + do i = 1, nl + call amovs (Mems[imgl2s(in,i)], Mems[impl2s(out,i)], nc) + default: + do i = 1, nl + call amovr (Memr[imgl2r(in,i)], Memr[impl2r(out,i)], nc) + } + + call imunmap (in) + call imunmap (out) +end diff --git a/noao/imred/ccdred/src/ccddelete.x b/noao/imred/ccdred/src/ccddelete.x new file mode 100644 index 00000000..90931135 --- /dev/null +++ b/noao/imred/ccdred/src/ccddelete.x @@ -0,0 +1,55 @@ +# CCDDELETE -- Delete an image by renaming it to a backup image. +# +# 1. Get the backup prefix which may be a path name. +# 2. If no prefix is specified then delete the image without a backup. +# 3. If there is a prefix then make a backup image name. +# Rename the image to the backup image name. +# +# The backup image name is formed by prepending the backup prefix to the +# image name. If a previous backup exist append integers to the backup +# prefix until a nonexistant image name is created. + +procedure ccddelete (image) + +char image[ARB] # Image to delete (backup) + +int i, imaccess() +pointer sp, prefix, backup +errchk imdelete, imrename + +begin + call smark (sp) + call salloc (prefix, SZ_FNAME, TY_CHAR) + call salloc (backup, SZ_FNAME, TY_CHAR) + + # Get the backup prefix. + call clgstr ("backup", Memc[prefix], SZ_FNAME) + call xt_stripwhite (Memc[prefix]) + + # If there is no prefix then simply delete the image. + if (Memc[prefix] == EOS) + call imdelete (image) + + # Otherwise create a backup image name which does not exist and + # rename the image to the backup image. + + else { + i = 0 + repeat { + if (i == 0) { + call sprintf (Memc[backup], SZ_FNAME, "%s%s") + call pargstr (Memc[prefix]) + call pargstr (image) + } else { + call sprintf (Memc[backup], SZ_FNAME, "%s%d%s") + call pargstr (Memc[prefix]) + call pargi (i) + call pargstr (image) + } + i = i + 1 + } until (imaccess (Memc[backup], READ_ONLY) == NO) + call imrename (image, Memc[backup]) + } + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/ccdflag.x b/noao/imred/ccdred/src/ccdflag.x new file mode 100644 index 00000000..427365d2 --- /dev/null +++ b/noao/imred/ccdred/src/ccdflag.x @@ -0,0 +1,27 @@ +# CCDFLAG -- Determine if a CCD processing flag is set. This is less than +# obvious because of the need to use the default value to indicate a +# false flag. + +bool procedure ccdflag (im, name) + +pointer im # IMIO pointer +char name[ARB] # CCD flag name + +bool flag, strne() +pointer sp, str1, str2 + +begin + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Get the flag string value and the default value. + # The flag is true if the value and the default do not match. + + call hdmgstr (im, name, Memc[str1], SZ_LINE) + call hdmgdef (name, Memc[str2], SZ_LINE) + flag = strne (Memc[str1], Memc[str2]) + + call sfree (sp) + return (flag) +end diff --git a/noao/imred/ccdred/src/ccdinst1.key b/noao/imred/ccdred/src/ccdinst1.key new file mode 100644 index 00000000..2a3ef1d4 --- /dev/null +++ b/noao/imred/ccdred/src/ccdinst1.key @@ -0,0 +1,27 @@ + CCDINSTRUMENT COMMANDS + +? Print command summary +help Print command summary +imheader Page image header +instrument Print current instrument translation file +next Next image +newimage Select a new image +quit Quit +read Read instrument translation file +show Show current translations +write Write instrument translation file + +translate Translate image string selected by the imagetyp parameter + to one of the CCDRED types given as an argument or queried: + object, zero, dark, flat, comp, illum, fringe, other + +The following are CCDRED parameters which may be translated. You are +queried for the image keyword to use or it may be typed after the command. +An optional default value (returned if the image does not contain the +keyword) may be typed as the second argument of the command. + + BASIC PARAMETERS +imagetyp Image type parameter (see also translate) +subset Subset or filter parameter +exptime Exposure time +darktime Dark time (may be same as the exposure time) diff --git a/noao/imred/ccdred/src/ccdinst2.key b/noao/imred/ccdred/src/ccdinst2.key new file mode 100644 index 00000000..bd909433 --- /dev/null +++ b/noao/imred/ccdred/src/ccdinst2.key @@ -0,0 +1,39 @@ + CCDINSTRUMENT COMMANDS + +? Print command summary +help Print command summary +imheader Page image header +instrument Print current instrument translation file +next Next image +newimage Select a new image +quit Quit +read Read instrument translation file +show Show current translations +write Write instrument translation file + +translate Translate image string selected by the imagetyp parameter + to one of the CCDRED types given as an argument or queried: + object, zero, dark, flat, comp, illum, fringe, other + +The following are CCDRED parameters which may be translated. You are +queried for the image keyword to use or it may be typed after the command. +An optional default value (returned if the image does not contain the +keyword) may be typed as the second argument of the command. + + BASIC PARAMETERS +imagetyp Image type parameter (see also translate) +subset Subset or filter parameter +exptime Exposure time +darktime Dark time (may be same as the exposure time) + + USEFUL DEFAULT GEOMETRY PARAMETERS +biassec Bias section (often has a default value) +trimsec Trim section (often has a default value) + + COMMON PROCESSING FLAGS +fixpix Bad pixel replacement flag +overscan Overscan correction flag +trim Trim flag +zerocor Zero level correction flag +darkcor Dark count correction flag +flatcor Flat field correction flag diff --git a/noao/imred/ccdred/src/ccdinst3.key b/noao/imred/ccdred/src/ccdinst3.key new file mode 100644 index 00000000..7215aa67 --- /dev/null +++ b/noao/imred/ccdred/src/ccdinst3.key @@ -0,0 +1,62 @@ + CCDINSTRUMENT COMMANDS + +? Print command summary +help Print command summary +imheader Page image header +instrument Print current instrument translation file +next Next image +newimage Select a new image +quit Quit +read Read instrument translation file +show Show current translations +write Write instrument translation file + +translate Translate image string selected by the imagetyp parameter + to one of the CCDRED types given as an argument or queried: + object, zero, dark, flat, comp, illum, fringe, other + +The following are CCDRED parameters which may be translated. You are +queried for the image keyword to use or it may be typed after the command. +An optional default value (returned if the image does not contain the +keyword) may be typed as the second argument of the command. + + BASIC PARAMETERS +imagetyp Image type parameter (see also translate) +subset Subset or filter parameter +exptime Exposure time +darktime Dark time (may be same as the exposure time) + + USEFUL DEFAULT GEOMETRY PARAMETERS +biassec Bias section (often has a default value) +trimsec Trim section (often has a default value) + + COMMON PROCESSING FLAGS +fixpix Bad pixel replacement flag +overscan Overscan correction flag +trim Trim flag +zerocor Zero level correction flag +darkcor Dark count correction flag +flatcor Flat field correction flag + + RARELY TRANSLATED PARAMETERS +ccdsec CCD section +datasec Data section +fixfile Bad pixel file + +fringcor Fringe correction flag +illumcor Ilumination correction flag +readcor One dimensional zero level read out correction flag +scancor Scan mode correction flag + +illumflt Ilumination flat image +mkfringe Fringe image +mkillum Illumination image +skyflat Sky flat image + +ccdmean Mean value +fringscl Fringe scale factor +ncombine Number of images combined +date-obs Date of observations +dec Declination +ra Right Ascension +title Image title diff --git a/noao/imred/ccdred/src/ccdlog.x b/noao/imred/ccdred/src/ccdlog.x new file mode 100644 index 00000000..48453704 --- /dev/null +++ b/noao/imred/ccdred/src/ccdlog.x @@ -0,0 +1,46 @@ +include <imhdr.h> +include <imset.h> + +# CCDLOG -- Log information about the processing with the image name. +# +# 1. If the package "verbose" parameter is set print the string preceded +# by the image name. +# 2. If the package "logfile" parameter is not null append the string, +# preceded by the image name, to the file. + +procedure ccdlog (im, str) + +pointer im # IMIO pointer +char str[ARB] # Log string + +int fd, open() +bool clgetb() +pointer sp, fname +errchk open + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Write to the standard error output if "verbose". + if (clgetb ("verbose")) { + call imstats (im, IM_IMAGENAME, Memc[fname], SZ_FNAME) + call eprintf ("%s: %s\n") + call pargstr (Memc[fname]) + call pargstr (str) + } + + # Append to the "logfile" if not null. + call clgstr ("logfile", Memc[fname], SZ_FNAME) + call xt_stripwhite (Memc[fname]) + if (Memc[fname] != EOS) { + fd = open (Memc[fname], APPEND, TEXT_FILE) + call imstats (im, IM_IMAGENAME, Memc[fname], SZ_FNAME) + call fprintf (fd, "%s: %s\n") + call pargstr (Memc[fname]) + call pargstr (str) + call close (fd) + } + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/ccdmean.x b/noao/imred/ccdred/src/ccdmean.x new file mode 100644 index 00000000..d38ea97b --- /dev/null +++ b/noao/imred/ccdred/src/ccdmean.x @@ -0,0 +1,50 @@ +include <imhdr.h> + + +# CCDMEAN -- Compute mean and add to header if needed. + +procedure ccdmean (input) + +char input[ARB] # Input image + +int i, nc, nl, hdmgeti() +long time, clktime() +bool clgetb() +real mean, hdmgetr(), asumr() +pointer in, immap(), imgl2r() +errchk immap + +begin + # Check if this operation has been done. + + in = immap (input, READ_WRITE, 0) + ifnoerr (mean = hdmgetr (in, "ccdmean")) { + iferr (time = hdmgeti (in, "ccdmeant")) + time = IM_MTIME(in) + if (time >= IM_MTIME(in)) { + call imunmap (in) + return + } + } + + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Compute mean of image\n") + call pargstr (input) + call imunmap (in) + return + } + + # Compute and record the mean. + nc = IM_LEN(in,1) + nl = IM_LEN(in,2) + mean = 0. + do i = 1, nl + mean = mean + asumr (Memr[imgl2r(in,i)], nc) + mean = mean / (nc * nl) + time = clktime (long(0)) + call hdmputr (in, "ccdmean", mean) + call hdmputi (in, "ccdmeant", int (time)) + + call imunmap (in) +end diff --git a/noao/imred/ccdred/src/ccdnscan.x b/noao/imred/ccdred/src/ccdnscan.x new file mode 100644 index 00000000..3a9fbeba --- /dev/null +++ b/noao/imred/ccdred/src/ccdnscan.x @@ -0,0 +1,38 @@ +include "ccdtypes.h" + + +# CCDNSCAN -- Return the number CCD scan rows. +# +# If not found in the header return the "nscan" parameter for objects and +# 1 for calibration images. + +int procedure ccdnscan (im, ccdtype) + +pointer im #I Image +int ccdtype #I CCD type +int nscan #O Number of scan lines + +bool clgetb() +char type, clgetc() +int hdmgeti(), clgeti() + +begin + iferr (nscan = hdmgeti (im, "nscanrow")) { + switch (ccdtype) { + case ZERO, DARK, FLAT, ILLUM, FRINGE: + nscan = 1 + default: + type = clgetc ("scantype") + if (type == 's') + nscan = clgeti ("nscan") + else { + if (clgetb ("scancor")) + nscan = INDEFI + else + nscan = 1 + } + } + } + + return (nscan) +end diff --git a/noao/imred/ccdred/src/ccdproc.x b/noao/imred/ccdred/src/ccdproc.x new file mode 100644 index 00000000..1b2a133c --- /dev/null +++ b/noao/imred/ccdred/src/ccdproc.x @@ -0,0 +1,106 @@ +include <error.h> +include "ccdred.h" +include "ccdtypes.h" + +# CCDPROC -- Process a CCD image of a specified CCD image type. +# +# The input image is corrected for bad pixels, overscan levels, zero +# levels, dark counts, flat field, illumination, and fringing. It may also +# be trimmed. The checking of whether to apply each correction, getting the +# required parameters, and logging the operations is left to separate +# procedures, one for each correction. The actual processing is done by +# a specialized procedure designed to be very efficient. These +# procedures may also process calibration images if necessary. +# The specified image type overrides the image type in the image header. +# There are two data type paths; one for short data types and one for +# all other data types (usually real). + +procedure ccdproc (input, ccdtype) + +char input[ARB] # CCD image to process +int ccdtype # CCD type of image (independent of header). + +pointer sp, output, str, in, out, ccd, immap() +errchk immap, set_output, ccddelete +errchk set_fixpix, set_zero, set_dark, set_flat, set_illum, set_fringe + +begin + call smark (sp) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Map the image, make a working output image and set the processing + # parameters. + + in = immap (input, READ_ONLY, 0) + call mktemp ("tmp", Memc[output], SZ_FNAME) + call set_output (in, out, Memc[output]) + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + + # Set processing appropriate for the various image types. + switch (ccdtype) { + case ZERO: + case DARK: + call set_zero (ccd) + case FLAT: + call set_zero (ccd) + call set_dark (ccd) + CORS(ccd, FINDMEAN) = YES + CORS(ccd, MINREP) = YES + case ILLUM: + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + case OBJECT, COMP: + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + call set_illum (ccd) + call set_fringe (ccd) + default: + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + call set_illum (ccd) + call set_fringe (ccd) + CORS(ccd, FINDMEAN) = YES + } + + # Do the processing if the COR flag is set. + if (COR(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + # Replace the input by the output image. + call imunmap (in) + call imunmap (out) + iferr (call ccddelete (input)) { + call imdelete (Memc[output]) + call error (1, + "Can't delete or make backup of original image") + } + call imrename (Memc[output], input) + } else { + # Delete the temporary output image leaving the input unchanged. + call imunmap (in) + iferr (call imunmap (out)) + ; + iferr (call imdelete (Memc[output])) + ; + } + call free_proc (ccd) + + # Do special processing for calibration images. + switch (ccdtype) { + case ZERO: + call readcor (input) + case FLAT: + call ccdmean (input) + } + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/ccdred.h b/noao/imred/ccdred/src/ccdred.h new file mode 100644 index 00000000..2d370d86 --- /dev/null +++ b/noao/imred/ccdred/src/ccdred.h @@ -0,0 +1,150 @@ +# CCDRED Data Structures and Definitions + +# The CCD structure: This structure is used to communicate processing +# parameters between the package procedures. It contains pointers to +# data, calibration image IMIO pointers, scaling parameters, and the +# correction flags. The corrections flags indicate which processing +# operations are to be performed. The subsection parameters do not +# include a step size. A step size is assumed. If arbitrary subsampling +# is desired this would be the next generalization. + +define LEN_CCD 131 # Length of CCD structure + +# CCD data coordinates +define CCD_C1 Memi[$1] # CCD starting column +define CCD_C2 Memi[$1+1] # CCD ending column +define CCD_L1 Memi[$1+2] # CCD starting line +define CCD_L2 Memi[$1+3] # CCD ending line + +# Input data +define IN_IM Memi[$1+10] # Input image pointer +define IN_C1 Memi[$1+11] # Input data starting column +define IN_C2 Memi[$1+12] # Input data ending column +define IN_L1 Memi[$1+13] # Input data starting line +define IN_L2 Memi[$1+14] # Input data ending line + +# Output data +define OUT_IM Memi[$1+20] # Output image pointer +define OUT_C1 Memi[$1+21] # Output data starting column +define OUT_C2 Memi[$1+22] # Output data ending column +define OUT_L1 Memi[$1+23] # Output data starting line +define OUT_L2 Memi[$1+24] # Output data ending line + +# Mask data +define MASK_IM Memi[$1+30] # Mask image pointer +define MASK_C1 Memi[$1+31] # Mask data starting column +define MASK_C2 Memi[$1+32] # Mask data ending column +define MASK_L1 Memi[$1+33] # Mask data starting line +define MASK_L2 Memi[$1+34] # Mask data ending line +define MASK_PM Memi[$1+35] # Mask pointer +define MASK_FP Memi[$1+36] # Mask fixpix data + +# Zero level data +define ZERO_IM Memi[$1+40] # Zero level image pointer +define ZERO_C1 Memi[$1+41] # Zero level data starting column +define ZERO_C2 Memi[$1+42] # Zero level data ending column +define ZERO_L1 Memi[$1+43] # Zero level data starting line +define ZERO_L2 Memi[$1+44] # Zero level data ending line + +# Dark count data +define DARK_IM Memi[$1+50] # Dark count image pointer +define DARK_C1 Memi[$1+51] # Dark count data starting column +define DARK_C2 Memi[$1+52] # Dark count data ending column +define DARK_L1 Memi[$1+53] # Dark count data starting line +define DARK_L2 Memi[$1+54] # Dark count data ending line + +# Flat field data +define FLAT_IM Memi[$1+60] # Flat field image pointer +define FLAT_C1 Memi[$1+61] # Flat field data starting column +define FLAT_C2 Memi[$1+62] # Flat field data ending column +define FLAT_L1 Memi[$1+63] # Flat field data starting line +define FLAT_L2 Memi[$1+64] # Flat field data ending line + +# Illumination data +define ILLUM_IM Memi[$1+70] # Illumination image pointer +define ILLUM_C1 Memi[$1+71] # Illumination data starting column +define ILLUM_C2 Memi[$1+72] # Illumination data ending column +define ILLUM_L1 Memi[$1+73] # Illumination data starting line +define ILLUM_L2 Memi[$1+74] # Illumination data ending line + +# Fringe data +define FRINGE_IM Memi[$1+80] # Fringe image pointer +define FRINGE_C1 Memi[$1+81] # Fringe data starting column +define FRINGE_C2 Memi[$1+82] # Fringe data ending column +define FRINGE_L1 Memi[$1+83] # Fringe data starting line +define FRINGE_L2 Memi[$1+84] # Fringe data ending line + +# Trim section +define TRIM_C1 Memi[$1+90] # Trim starting column +define TRIM_C2 Memi[$1+91] # Trim ending column +define TRIM_L1 Memi[$1+92] # Trim starting line +define TRIM_L2 Memi[$1+93] # Trim ending line + +# Bias section +define BIAS_C1 Memi[$1+100] # Bias starting column +define BIAS_C2 Memi[$1+101] # Bias ending column +define BIAS_L1 Memi[$1+102] # Bias starting line +define BIAS_L2 Memi[$1+103] # Bias ending line + +define READAXIS Memi[$1+110] # Read out axis (1=cols, 2=lines) +define CALCTYPE Memi[$1+111] # Calculation data type +define OVERSCAN_TYPE Memi[$1+112] # Overscan type +define OVERSCAN_VEC Memi[$1+113] # Pointer to overscan vector +define DARKSCALE Memr[P2R($1+114)] # Dark count scale factor +define FRINGESCALE Memr[P2R($1+115)] # Fringe scale factor +define FLATSCALE Memr[P2R($1+116)] # Flat field scale factor +define ILLUMSCALE Memr[P2R($1+117)] # Illumination scale factor +define MINREPLACE Memr[P2R($1+118)] # Minimum replacement value +define MEAN Memr[P2R($1+119)] # Mean of output image +define COR Memi[$1+120] # Overall correction flag +define CORS Memi[$1+121+($2-1)] # Individual correction flags + +# The correction array contains the following elements with array indices +# given by the macro definitions. + +define NCORS 10 # Number of corrections + +define FIXPIX 1 # Fix bad pixels +define TRIM 2 # Trim image +define OVERSCAN 3 # Apply overscan correction +define ZEROCOR 4 # Apply zero level correction +define DARKCOR 5 # Apply dark count correction +define FLATCOR 6 # Apply flat field correction +define ILLUMCOR 7 # Apply illumination correction +define FRINGECOR 8 # Apply fringe correction +define FINDMEAN 9 # Find the mean of the output image +define MINREP 10 # Check and replace minimum value + +# The following definitions identify the correction values in the correction +# array. They are defined in terms of bit fields so that it is possible to +# add corrections to form unique combination corrections. Some of +# these combinations are implemented as compound operations for efficiency. + +define O 001B # overscan +define Z 002B # zero level +define D 004B # dark count +define F 010B # flat field +define I 020B # Illumination +define Q 040B # Fringe + +# The following correction combinations are recognized. + +define ZO 003B # zero level + overscan +define DO 005B # dark count + overscan +define DZ 006B # dark count + zero level +define DZO 007B # dark count + zero level + overscan +define FO 011B # flat field + overscan +define FZ 012B # flat field + zero level +define FZO 013B # flat field + zero level + overscan +define FD 014B # flat field + dark count +define FDO 015B # flat field + dark count + overscan +define FDZ 016B # flat field + dark count + zero level +define FDZO 017B # flat field + dark count + zero level + overscan +define QI 060B # fringe + illumination + +# The following overscan functions are recognized. +define OVERSCAN_TYPES "|mean|median|minmax|chebyshev|legendre|spline3|spline1|" +define OVERSCAN_MEAN 1 # Mean of overscan +define OVERSCAN_MEDIAN 2 # Median of overscan +define OVERSCAN_MINMAX 3 # Minmax of overscan +define OVERSCAN_FIT 4 # Following codes are function fits diff --git a/noao/imred/ccdred/src/ccdsection.x b/noao/imred/ccdred/src/ccdsection.x new file mode 100644 index 00000000..aced216a --- /dev/null +++ b/noao/imred/ccdred/src/ccdsection.x @@ -0,0 +1,100 @@ +include <ctype.h> + +# CCD_SECTION -- Parse a 2D 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 ccd_section (section, x1, x2, xstep, y1, y2, ystep) + +char section[ARB] # Image section +int x1, x2, xstep # X image section parameters +int y1, y2, ystep # X image section parameters + +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, 2 { + while (IS_WHITE(section[ip])) + ip = ip + 1 + + # Default values + if (i == 1) { + a = x1 + b = x2 + c = xstep + } else { + a = y1 + b = y2 + c = ystep + } + + # 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 + + if (i == 1) { + x1 = a + x2 = b + xstep = c + } else { + y1 = a + y2 = b + ystep = 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/imred/ccdred/src/ccdsubsets.x b/noao/imred/ccdred/src/ccdsubsets.x new file mode 100644 index 00000000..528b0223 --- /dev/null +++ b/noao/imred/ccdred/src/ccdsubsets.x @@ -0,0 +1,93 @@ +include <ctype.h> + + +# CCDSUBSET -- Return the CCD subset identifier. +# +# 1. Get the subset string and search the subset record file for the ID string. +# 2. If the subset string is not in the record file define a default ID string +# based on the first word of the subset string. If the first word is not +# unique append a integer to the first word until it is unique. +# 3. Add the new subset string and identifier to the record file. +# 4. Since the ID string is used to generate image names replace all +# nonimage name characters with '_'. +# +# It is an error if the record file cannot be created or written when needed. + +procedure ccdsubset (im, subset, sz_name) + +pointer im # Image +char subset[sz_name] # CCD subset identifier +int sz_name # Size of subset string + +bool streq() +int i, fd, ctowrd(), open(), fscan() +pointer sp, fname, str1, str2, subset1, subset2, subset3 +errchk open + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + call salloc (subset1, SZ_LINE, TY_CHAR) + call salloc (subset2, SZ_LINE, TY_CHAR) + call salloc (subset3, SZ_LINE, TY_CHAR) + + # Get the subset record file and the subset string. + call clgstr ("ssfile", Memc[fname], SZ_LINE) + call hdmgstr (im, "subset", Memc[str1], SZ_LINE) + + # The default subset identifier is the first word of the subset string. + i = 1 + i = ctowrd (Memc[str1], i, Memc[subset1], SZ_LINE) + + # A null subset string is ok. If not null check for conflict + # with previous subset IDs. + if (Memc[str1] != EOS) { + call strcpy (Memc[subset1], Memc[subset3], SZ_LINE) + + # Search the subset record file for the same subset string. + # If found use the ID string. If the subset ID has been + # used for another subset string then increment an integer + # suffix to the default ID and check the list again. + + i = 1 + ifnoerr (fd = open (Memc[fname], READ_ONLY, TEXT_FILE)) { + while (fscan (fd) != EOF) { + call gargwrd (Memc[str2], SZ_LINE) + call gargwrd (Memc[subset2], SZ_LINE) + if (streq (Memc[str1], Memc[str2])) { + i = 0 + call strcpy (Memc[subset2], Memc[subset1], SZ_LINE) + break + } if (streq (Memc[subset1], Memc[subset2])) { + call sprintf (Memc[subset1], SZ_LINE, "%s%d") + call pargstr (Memc[subset3]) + call pargi (i) + i = i + 1 + call seek (fd, BOF) + } + } + call close (fd) + } + + # If the subset is not in the record file add it. + if (i > 0) { + fd = open (Memc[fname], APPEND, TEXT_FILE) + call fprintf (fd, "'%s'\t%s\n") + call pargstr (Memc[str1]) + call pargstr (Memc[subset1]) + call close (fd) + } + } + + # Set the subset ID string and replace magic characters by '_' + # since the subset ID is used in forming image names. + + call strcpy (Memc[subset1], subset, sz_name) + for (i=1; subset[i]!=EOS; i=i+1) + if (!(IS_ALNUM(subset[i])||subset[i]=='.')) + subset[i] = '_' + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/ccdtypes.h b/noao/imred/ccdred/src/ccdtypes.h new file mode 100644 index 00000000..0d5d4caf --- /dev/null +++ b/noao/imred/ccdred/src/ccdtypes.h @@ -0,0 +1,14 @@ +# Standard CCD image types. + +define CCDTYPES "|object|zero|dark|flat|illum|fringe|other|comp|" + +define NONE -1 +define UNKNOWN 0 +define OBJECT 1 +define ZERO 2 +define DARK 3 +define FLAT 4 +define ILLUM 5 +define FRINGE 6 +define OTHER 7 +define COMP 8 diff --git a/noao/imred/ccdred/src/ccdtypes.x b/noao/imred/ccdred/src/ccdtypes.x new file mode 100644 index 00000000..bf6d29e2 --- /dev/null +++ b/noao/imred/ccdred/src/ccdtypes.x @@ -0,0 +1,72 @@ +include "ccdtypes.h" + +# CCDTYPES -- Return the CCD type name string. +# CCDTYPEI -- Return the CCD type code. + + +# CCDTYPES -- Return the CCD type name string. + +procedure ccdtypes (im, name, sz_name) + +pointer im # Image +char name[sz_name] # CCD type name +int sz_name # Size of name string + +int strdic() +pointer sp, str + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the image type string. If none then return "none". + # Otherwise get the corresponding package image type string. + # If the image type is unknown return "unknown" otherwise return + # the package name. + + call hdmgstr (im, "imagetyp", Memc[str], SZ_LINE) + if (Memc[str] == EOS) { + call strcpy ("none", name, sz_name) + } else { + call hdmname (Memc[str], name, sz_name) + if (name[1] == EOS) + call strcpy (Memc[str], name, sz_name) + if (strdic (name, name, sz_name, CCDTYPES) == UNKNOWN) + call strcpy ("unknown", name, sz_name) + } + + call sfree (sp) +end + + +# CCDTYPEI -- Return the CCD type code. + +int procedure ccdtypei (im) + +pointer im # Image +int ccdtype # CCD type (returned) + +pointer sp, str1, str2 +int strdic() + +begin + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Get the image type and if there is none then return the NONE code. + call hdmgstr (im, "imagetyp", Memc[str1], SZ_LINE) + if (Memc[str1] == EOS) { + ccdtype = NONE + + # Otherwise get the package type and convert to an image type code. + } else { + call hdmname (Memc[str1], Memc[str2], SZ_LINE) + if (Memc[str2] == EOS) + call strcpy (Memc[str1], Memc[str2], SZ_LINE) + ccdtype = strdic (Memc[str2], Memc[str2], SZ_LINE, CCDTYPES) + } + + call sfree (sp) + return (ccdtype) +end diff --git a/noao/imred/ccdred/src/combine/generic/icaclip.x b/noao/imred/ccdred/src/combine/generic/icaclip.x new file mode 100644 index 00000000..1530145c --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icaclip.x @@ -0,0 +1,1102 @@ +# 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 + 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow > 0) { + 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_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 + 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/combine/generic/icaverage.x b/noao/imred/ccdred/src/combine/generic/icaverage.x new file mode 100644 index 00000000..3646b725 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icaverage.x @@ -0,0 +1,163 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + + +# IC_AVERAGE -- Compute the average image line. +# Options include a weight average. + +procedure ic_averages (d, m, n, wts, npts, 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 +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 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 to the blank value. + + 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] + average[i] = sum / n[i] + } + } + } else if (dflag == D_NONE) { + 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 + } + average[i] = sum / sumwt + } else + 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] + average[i] = sum / n[i] + } else + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average image line. +# Options include a weight average. + +procedure ic_averager (d, m, n, wts, npts, 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 +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 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 to the blank value. + + 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] + average[i] = sum / n[i] + } + } + } else if (dflag == D_NONE) { + 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 + } + average[i] = sum / sumwt + } else + 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] + average[i] = sum / n[i] + } else + average[i] = blank + } + } + } +end diff --git a/noao/imred/ccdred/src/combine/generic/iccclip.x b/noao/imred/ccdred/src/combine/generic/iccclip.x new file mode 100644 index 00000000..57709064 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/iccclip.x @@ -0,0 +1,898 @@ +# 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow > 0) { + 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_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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/combine/generic/icgdata.x b/noao/imred/ccdred/src/combine/generic/icgdata.x new file mode 100644 index 00000000..5c6ac18c --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icgdata.x @@ -0,0 +1,459 @@ +# 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 keeped 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 for nonaligned images +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, ndim, nused +real a, b +pointer buf, dp, ip, mp, 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) + return + + # Get data and fill data buffers. Correct for offsets if needed. + ndim = IM_NDIM(out[1]) + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (aligned) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = imgnls (in[i], d[i], v2) + } else { + v2[1] = v1[1] + do j = 2, ndim + v2[j] = v1[j] - offsets[i,j] + if (project) + v2[ndim+1] = i + j = imgnls (in[i], buf, v2) + call amovs (Mems[buf], Mems[dbuf[i]+offsets[i,1]], + IM_LEN(in[i],1)) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + dp = d[i] + if (lflag[i] == D_ALL) { + 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 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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 + 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 + } + } + } + } + + # 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 { + dp = d[i] + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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] + dp = d[i] + ip = id[i] + mp = m[i] + do j = 1, npts { + 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 > 0) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + dp = d[i] + mp = m[i] + do j = 1, npts { + 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 keeped 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 for nonaligned images +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, ndim, nused +real a, b +pointer buf, dp, ip, mp, 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) + return + + # Get data and fill data buffers. Correct for offsets if needed. + ndim = IM_NDIM(out[1]) + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (aligned) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = imgnlr (in[i], d[i], v2) + } else { + v2[1] = v1[1] + do j = 2, ndim + v2[j] = v1[j] - offsets[i,j] + if (project) + v2[ndim+1] = i + j = imgnlr (in[i], buf, v2) + call amovr (Memr[buf], Memr[dbuf[i]+offsets[i,1]], + IM_LEN(in[i],1)) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + dp = d[i] + if (lflag[i] == D_ALL) { + 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 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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 + 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 + } + } + } + } + + # 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 { + dp = d[i] + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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] + dp = d[i] + ip = id[i] + mp = m[i] + do j = 1, npts { + 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 > 0) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + dp = d[i] + mp = m[i] + do j = 1, npts { + 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 + diff --git a/noao/imred/ccdred/src/combine/generic/icgrow.x b/noao/imred/ccdred/src/combine/generic/icgrow.x new file mode 100644 index 00000000..b94e1cbc --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icgrow.x @@ -0,0 +1,148 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + + +# IC_GROW -- Reject neigbors of rejected pixels. +# The rejected pixels are marked by having nonzero ids beyond the number +# of included pixels. The pixels rejected here are given zero ids +# to avoid growing of the pixels rejected here. The unweighted average +# can be updated but any rejected pixels requires the median to be +# recomputed. When the number of pixels at a grow point reaches nkeep +# no further pixels are rejected. Note that the rejection order is not +# based on the magnitude of the residuals and so a grow from a weakly +# rejected image pixel may take precedence over a grow from a strongly +# rejected image pixel. + +procedure ic_grows (d, m, n, nimages, npts, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i1, i2, j1, j2, k1, k2, l, is, ie, n2, maxkeep +pointer mp1, mp2 + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + do i1 = 1, npts { + k1 = i1 - 1 + is = max (1, i1 - grow) + ie = min (npts, i1 + grow) + do j1 = n[i1]+1, nimages { + l = Memi[m[j1]+k1] + if (l == 0) + next + if (combine == MEDIAN) + docombine = true + + do i2 = is, ie { + if (i2 == i1) + next + k2 = i2 - 1 + n2 = n[i2] + if (nkeep < 0) + maxkeep = max (0, n2 + nkeep) + else + maxkeep = min (n2, nkeep) + if (n2 <= maxkeep) + next + do j2 = 1, n2 { + mp1 = m[j2] + k2 + if (Memi[mp1] == l) { + if (!docombine && n2 > 1) + average[i2] = + (n2*average[i2] - Mems[d[j2]+k2]) / (n2-1) + mp2 = m[n2] + k2 + if (j2 < n2) { + Mems[d[j2]+k2] = Mems[d[n2]+k2] + Memi[mp1] = Memi[mp2] + } + Memi[mp2] = 0 + n[i2] = n2 - 1 + break + } + } + } + } + } +end + +# IC_GROW -- Reject neigbors of rejected pixels. +# The rejected pixels are marked by having nonzero ids beyond the number +# of included pixels. The pixels rejected here are given zero ids +# to avoid growing of the pixels rejected here. The unweighted average +# can be updated but any rejected pixels requires the median to be +# recomputed. When the number of pixels at a grow point reaches nkeep +# no further pixels are rejected. Note that the rejection order is not +# based on the magnitude of the residuals and so a grow from a weakly +# rejected image pixel may take precedence over a grow from a strongly +# rejected image pixel. + +procedure ic_growr (d, m, n, nimages, npts, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i1, i2, j1, j2, k1, k2, l, is, ie, n2, maxkeep +pointer mp1, mp2 + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + do i1 = 1, npts { + k1 = i1 - 1 + is = max (1, i1 - grow) + ie = min (npts, i1 + grow) + do j1 = n[i1]+1, nimages { + l = Memi[m[j1]+k1] + if (l == 0) + next + if (combine == MEDIAN) + docombine = true + + do i2 = is, ie { + if (i2 == i1) + next + k2 = i2 - 1 + n2 = n[i2] + if (nkeep < 0) + maxkeep = max (0, n2 + nkeep) + else + maxkeep = min (n2, nkeep) + if (n2 <= maxkeep) + next + do j2 = 1, n2 { + mp1 = m[j2] + k2 + if (Memi[mp1] == l) { + if (!docombine && n2 > 1) + average[i2] = + (n2*average[i2] - Memr[d[j2]+k2]) / (n2-1) + mp2 = m[n2] + k2 + if (j2 < n2) { + Memr[d[j2]+k2] = Memr[d[n2]+k2] + Memi[mp1] = Memi[mp2] + } + Memi[mp2] = 0 + n[i2] = n2 - 1 + break + } + } + } + } + } +end diff --git a/noao/imred/ccdred/src/combine/generic/icmedian.x b/noao/imred/ccdred/src/combine/generic/icmedian.x new file mode 100644 index 00000000..ec0166ba --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icmedian.x @@ -0,0 +1,343 @@ +# 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, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +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) { + 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 + 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 + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_medianr (d, n, npts, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +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) { + 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 + 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 + median[i] = blank + } +end + diff --git a/noao/imred/ccdred/src/combine/generic/icmm.x b/noao/imred/ccdred/src/combine/generic/icmm.x new file mode 100644 index 00000000..259759bd --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icmm.x @@ -0,0 +1,300 @@ +# 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 + Memi[m[jmax]+i1] = Memi[m[j]+i1] + } else { + Mems[kmax] = d1 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } + if (jmin < j) { + if (jmax != n1) { + Mems[kmin] = d1 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } else { + Mems[kmin] = d2 + Memi[m[jmin]+i1] = Memi[m[j]+i1] + } + } + } 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 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } + } 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 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } 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_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 + Memi[m[jmax]+i1] = Memi[m[j]+i1] + } else { + Memr[kmax] = d1 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } + if (jmin < j) { + if (jmax != n1) { + Memr[kmin] = d1 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } else { + Memr[kmin] = d2 + Memi[m[jmin]+i1] = Memi[m[j]+i1] + } + } + } 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 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } + } 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 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } 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 diff --git a/noao/imred/ccdred/src/combine/generic/icombine.x b/noao/imred/ccdred/src/combine/generic/icombine.x new file mode 100644 index 00000000..b4ff60be --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icombine.x @@ -0,0 +1,607 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "../icombine.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, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, npts, fd, stropen(), errcode(), imstati() +pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf +pointer buf, imgl1s(), impl1i() +errchk stropen, imgl1s, impl1i +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + 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 (scales, nimages, TY_REAL) + call salloc (zeros, nimages, TY_REAL) + call salloc (wts, nimages, TY_REAL) + call amovki (D_ALL, Memi[lflag], nimages) + + # If aligned use the IMIO buffer otherwise we need vectors of + # output length. + + if (!aligned) { + call salloc (dbuf, nimages, TY_POINTER) + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 3 { + if (out[i] != NULL) + 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, 3 { + if (out[i] != NULL) + 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) + } + + do i = 1, nimages { + call imseti (in[i], IM_BUFSIZE, bufsize) + iferr (buf = imgl1s (in[i])) { + switch (errcode()) { + case SYS_MFULL: + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (imstati (in[i], IM_CLOSEFD) == YES) { + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + do j = i-2, nimages + call imseti (in[j], IM_CLOSEFD, YES) + buf = imgl1s (in[i]) + default: + 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, Memr[scales], Memr[zeros], + Memr[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, ctor() +real r, imgetr() +pointer sp, v1, v2, v3, outdata, buf, nm, impnli() +pointer impnlr() +errchk ic_scale, imgetr + +include "../icombine.com" + +begin + call smark (sp) + 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 || grow > 0) + 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 + if (grow > 0) + keepids = true + case PCLIP: + mclip = true + if (grow > 0) + keepids = true + case AVSIGCLIP, SIGCLIP: + if (doscale1 || grow > 0) + keepids = true + case NONE: + mclip = false + grow = 0 + } + + 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 (grow > 0) + call ic_grows (d, id, n, nimages, npts, Memr[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averages (d, id, n, wts, npts, Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, Memr[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + call sfree (sp) +end + +procedure icombiner (in, out, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, npts, fd, stropen(), errcode(), imstati() +pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf +pointer buf, imgl1r(), impl1i() +errchk stropen, imgl1r, impl1i +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + 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 (scales, nimages, TY_REAL) + call salloc (zeros, nimages, TY_REAL) + call salloc (wts, nimages, TY_REAL) + call amovki (D_ALL, Memi[lflag], nimages) + + # If aligned use the IMIO buffer otherwise we need vectors of + # output length. + + if (!aligned) { + call salloc (dbuf, nimages, TY_POINTER) + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 3 { + if (out[i] != NULL) + 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, 3 { + if (out[i] != NULL) + 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) + } + + do i = 1, nimages { + call imseti (in[i], IM_BUFSIZE, bufsize) + iferr (buf = imgl1r (in[i])) { + switch (errcode()) { + case SYS_MFULL: + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (imstati (in[i], IM_CLOSEFD) == YES) { + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + do j = i-2, nimages + call imseti (in[j], IM_CLOSEFD, YES) + buf = imgl1r (in[i]) + default: + 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, Memr[scales], Memr[zeros], + Memr[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, ctor() +real r, imgetr() +pointer sp, v1, v2, v3, outdata, buf, nm, impnli() +pointer impnlr() +errchk ic_scale, imgetr + +include "../icombine.com" + +begin + call smark (sp) + 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 || grow > 0) + 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 + if (grow > 0) + keepids = true + case PCLIP: + mclip = true + if (grow > 0) + keepids = true + case AVSIGCLIP, SIGCLIP: + if (doscale1 || grow > 0) + keepids = true + case NONE: + mclip = false + grow = 0 + } + + 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 (grow > 0) + call ic_growr (d, id, n, nimages, npts, Memr[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averager (d, id, n, wts, npts, Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, Memr[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + call sfree (sp) +end + diff --git a/noao/imred/ccdred/src/combine/generic/icpclip.x b/noao/imred/ccdred/src/combine/generic/icpclip.x new file mode 100644 index 00000000..da09bb75 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icpclip.x @@ -0,0 +1,442 @@ +# 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 > 0)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+j] = Mems[d[k]+j] + if (grow > 0) { + 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_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 > 0)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+j] = Memr[d[k]+j] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/combine/generic/icsclip.x b/noao/imred/ccdred/src/combine/generic/icsclip.x new file mode 100644 index 00000000..d7ccfd84 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icsclip.x @@ -0,0 +1,964 @@ +# 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow > 0) { + 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_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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/combine/generic/icsigma.x b/noao/imred/ccdred/src/combine/generic/icsigma.x new file mode 100644 index 00000000..bc0d9788 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icsigma.x @@ -0,0 +1,205 @@ +# 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 + } + sigma[i] = sqrt (sum / sumwt * 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_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 + } + sigma[i] = sqrt (sum / sumwt * 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 diff --git a/noao/imred/ccdred/src/combine/generic/icsort.x b/noao/imred/ccdred/src/combine/generic/icsort.x new file mode 100644 index 00000000..a39b68e2 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icsort.x @@ -0,0 +1,550 @@ +# 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_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 diff --git a/noao/imred/ccdred/src/combine/generic/icstat.x b/noao/imred/ccdred/src/combine/generic/icstat.x new file mode 100644 index 00000000..41512ccb --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/icstat.x @@ -0,0 +1,444 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 10000 # 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() +short ic_modes() +real asums() + + +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, 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) + } + + 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.8 # 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_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 ic_moder() +real asumr() + + +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, 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) + } + + 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.8 # 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 + diff --git a/noao/imred/ccdred/src/combine/generic/mkpkg b/noao/imred/ccdred/src/combine/generic/mkpkg new file mode 100644 index 00000000..63695459 --- /dev/null +++ b/noao/imred/ccdred/src/combine/generic/mkpkg @@ -0,0 +1,23 @@ +# Make CCDRED Package. + +$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 + icmedian.x ../icombine.com ../icombine.h + icmm.x ../icombine.com ../icombine.h + icombine.x ../icombine.com ../icombine.h <error.h> <syserr.h>\ + <imhdr.h> <imset.h> <mach.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> + ; diff --git a/noao/imred/ccdred/src/combine/icaclip.gx b/noao/imred/ccdred/src/combine/icaclip.gx new file mode 100644 index 00000000..bb592542 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icaclip.gx @@ -0,0 +1,573 @@ +# 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 (sr) +# 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 + 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/combine/icaverage.gx b/noao/imred/ccdred/src/combine/icaverage.gx new file mode 100644 index 00000000..c145bb33 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icaverage.gx @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +$for (sr) +# IC_AVERAGE -- Compute the average image line. +# Options include a weight average. + +procedure ic_average$t (d, m, n, wts, npts, 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 +$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 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 to the blank value. + + 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] + average[i] = sum / n[i] + } + } + } else if (dflag == D_NONE) { + 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 + } + average[i] = sum / sumwt + } else + 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] + average[i] = sum / n[i] + } else + average[i] = blank + } + } + } +end +$endfor diff --git a/noao/imred/ccdred/src/combine/iccclip.gx b/noao/imred/ccdred/src/combine/iccclip.gx new file mode 100644 index 00000000..69df984c --- /dev/null +++ b/noao/imred/ccdred/src/combine/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 (sr) +# 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/combine/icgdata.gx b/noao/imred/ccdred/src/combine/icgdata.gx new file mode 100644 index 00000000..41cf5810 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icgdata.gx @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" + +$for (sr) +# 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 keeped 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 for nonaligned images +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, ndim, nused +real a, b +pointer buf, dp, ip, mp, 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) + return + + # Get data and fill data buffers. Correct for offsets if needed. + ndim = IM_NDIM(out[1]) + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (aligned) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = imgnl$t (in[i], d[i], v2) + } else { + v2[1] = v1[1] + do j = 2, ndim + v2[j] = v1[j] - offsets[i,j] + if (project) + v2[ndim+1] = i + j = imgnl$t (in[i], buf, v2) + call amov$t (Mem$t[buf], Mem$t[dbuf[i]+offsets[i,1]], + IM_LEN(in[i],1)) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + dp = d[i] + if (lflag[i] == D_ALL) { + 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 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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 + 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 + } + } + } + } + + # 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 { + dp = d[i] + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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] + dp = d[i] + ip = id[i] + mp = m[i] + do j = 1, npts { + 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 > 0) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + dp = d[i] + mp = m[i] + do j = 1, npts { + 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/imred/ccdred/src/combine/icgrow.gx b/noao/imred/ccdred/src/combine/icgrow.gx new file mode 100644 index 00000000..e3cf6228 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icgrow.gx @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sr) +# IC_GROW -- Reject neigbors of rejected pixels. +# The rejected pixels are marked by having nonzero ids beyond the number +# of included pixels. The pixels rejected here are given zero ids +# to avoid growing of the pixels rejected here. The unweighted average +# can be updated but any rejected pixels requires the median to be +# recomputed. When the number of pixels at a grow point reaches nkeep +# no further pixels are rejected. Note that the rejection order is not +# based on the magnitude of the residuals and so a grow from a weakly +# rejected image pixel may take precedence over a grow from a strongly +# rejected image pixel. + +procedure ic_grow$t (d, m, n, nimages, npts, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +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 i1, i2, j1, j2, k1, k2, l, is, ie, n2, maxkeep +pointer mp1, mp2 + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + do i1 = 1, npts { + k1 = i1 - 1 + is = max (1, i1 - grow) + ie = min (npts, i1 + grow) + do j1 = n[i1]+1, nimages { + l = Memi[m[j1]+k1] + if (l == 0) + next + if (combine == MEDIAN) + docombine = true + + do i2 = is, ie { + if (i2 == i1) + next + k2 = i2 - 1 + n2 = n[i2] + if (nkeep < 0) + maxkeep = max (0, n2 + nkeep) + else + maxkeep = min (n2, nkeep) + if (n2 <= maxkeep) + next + do j2 = 1, n2 { + mp1 = m[j2] + k2 + if (Memi[mp1] == l) { + if (!docombine && n2 > 1) + average[i2] = + (n2*average[i2] - Mem$t[d[j2]+k2]) / (n2-1) + mp2 = m[n2] + k2 + if (j2 < n2) { + Mem$t[d[j2]+k2] = Mem$t[d[n2]+k2] + Memi[mp1] = Memi[mp2] + } + Memi[mp2] = 0 + n[i2] = n2 - 1 + break + } + } + } + } + } +end +$endfor diff --git a/noao/imred/ccdred/src/combine/icimstack.x b/noao/imred/ccdred/src/combine/icimstack.x new file mode 100644 index 00000000..2a19751d --- /dev/null +++ b/noao/imred/ccdred/src/combine/icimstack.x @@ -0,0 +1,125 @@ +# 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 (images, nimages, output) + +char images[SZ_FNAME-1, nimages] #I Input images +int nimages #I Number of images +char output #I Name of output image + +int i, j, npix +long line_in[IM_MAXDIM], line_out[IM_MAXDIM] +pointer sp, key, in, out, buf_in, buf_out, ptr + +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer immap() +errchk immap + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + iferr { + # Add each input image to the output image. + out = NULL + do i = 1, nimages { + in = NULL + ptr = immap (images[1,i], 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)) = nimages + npix = IM_LEN(out, 1) + call amovkl (long(1), line_out, 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], images[1,i]) + + # 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) + } + } + call imunmap (in) + } + } then { + if (out != NULL) { + call imunmap (out) + call imdelete (out) + } + if (in != NULL) + call imunmap (in) + call sfree (sp) + call erract (EA_ERROR) + } + + # Finish up. + call imunmap (out) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/combine/iclog.x b/noao/imred/ccdred/src/combine/iclog.x new file mode 100644 index 00000000..82135866 --- /dev/null +++ b/noao/imred/ccdred/src/combine/iclog.x @@ -0,0 +1,378 @@ +# 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, expname, exposure) + +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 +char expname[ARB] # Exposure name +real exposure # Output exposure + +int i, j, stack, ctor() +real rval, imgetr() +long clktime() +bool prncombine, prexptime, prmode, prmedian, prmean, prmask +bool prrdn, prgain, prsn +pointer sp, fname, key +errchk imgetr + +include "icombine.com" + +begin + if (logfd == NULL) + return + + call smark (sp) + call salloc (fname, 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: IMCOMBINE\n") + call pargstr (Memc[fname]) + switch (combine) { + case AVERAGE: + call fprintf (logfd, " combine = average, ") + case MEDIAN: + call fprintf (logfd, " combine = median, ") + } + 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 > 0) { + call fprintf (logfd, " grow = %d\n") + call pargi (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) + call clgstr ("statsec", Memc[fname], SZ_LINE) + if (Memc[fname] != 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 && Memi[ICM_PMS(icm)+i-1] != NULL) + 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 { + 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 && Memi[ICM_PMS(icm)+i-1] != NULL) { + call imgstr (in[i], "BPM", Memc[fname], SZ_LINE) + call fprintf (logfd, " %s") + call pargstr (Memc[fname]) + } + 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) + if (expname[1] != EOS) { + call fprintf (logfd, ", %s = %g") + call pargstr (expname) + call pargr (exposure) + } + call fprintf (logfd, "\n") + + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Pixel list image = %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/imred/ccdred/src/combine/icmask.com b/noao/imred/ccdred/src/combine/icmask.com new file mode 100644 index 00000000..baba6f6a --- /dev/null +++ b/noao/imred/ccdred/src/combine/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/imred/ccdred/src/combine/icmask.h b/noao/imred/ccdred/src/combine/icmask.h new file mode 100644 index 00000000..b2d30530 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icmask.h @@ -0,0 +1,7 @@ +# ICMASK -- Data structure for IMCOMBINE mask interface. + +define ICM_LEN 4 # 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 diff --git a/noao/imred/ccdred/src/combine/icmask.x b/noao/imred/ccdred/src/combine/icmask.x new file mode 100644 index 00000000..ba448b68 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icmask.x @@ -0,0 +1,354 @@ +include <imhdr.h> +include <pmset.h> +include "icombine.h" +include "icmask.h" + +# IC_MASK -- ICOMBINE mask interface +# +# IC_MOPEN -- Open masks +# 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_MOPEN -- Open masks. +# Parse and interpret the mask selection parameters. + +procedure ic_mopen (in, out, nimages) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I 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 + +int i, npix, npms, clgwrd() +real clgetr() +pointer sp, fname, title, pm, pm_open() +bool invert, pm_empty() +errchk calloc, pm_open, pm_loadf + +include "icombine.com" + +begin + icm = NULL + if (IM_NDIM(out[1]) == 0) + return + + call smark (sp) + call salloc (fname, 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 = clgwrd ("masktype", Memc[title], SZ_FNAME, MASKTYPES) + mvalue = clgetr ("maskvalue") + npix = IM_LEN(out[1],1) + call calloc (pms, nimages, TY_POINTER) + call calloc (bufs, 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. + + npms = 0 + do i = 1, nimages { + if (mtype != M_NONE) { + ifnoerr (call imgstr (in[i], "BPM", Memc[fname], SZ_FNAME)) { + pm = pm_open (NULL) + call pm_loadf (pm, Memc[fname], Memc[title], SZ_FNAME) + call pm_seti (pm, P_REFIM, in[i]) + if (pm_empty (pm) && !invert) + call pm_close (pm) + else { + if (project) { + npms = nimages + call amovki (pm, Memi[pms], nimages) + } else { + npms = npms + 1 + Memi[pms+i-1] = pm + } + } + if (project) + break + } + } + } + + # 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 + + 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_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_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 + +int i, j, ndim, nout, npix +pointer buf, pm +bool pm_linenotempty() +errchk pm_glpi + +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) + + # 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 { + npix = IM_LEN(in[i],1) + j = offsets[i,1] + m[i] = Memi[bufs+i-1] + buf = Memi[bufs+i-1] + j + pm = Memi[pms+i-1] + if (npix == nout) + lflag[i] = D_ALL + else + lflag[i] = D_MIX + + v2[1] = v1[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) + next + + if (pm == NULL) { + call aclri (Memi[buf], npix) + next + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + 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, offset, v, m) + +pointer in # Input image pointer +int image # Image index +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 + +int i, npix +pointer buf, pm +bool pm_linenotempty() +errchk pm_glpi + +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) + + npix = IM_LEN(in,1) + m = Memi[bufs+image-1] + offset + pm = Memi[pms+image-1] + if (pm == NULL) + return + + # 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 diff --git a/noao/imred/ccdred/src/combine/icmedian.gx b/noao/imred/ccdred/src/combine/icmedian.gx new file mode 100644 index 00000000..dc8488d9 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icmedian.gx @@ -0,0 +1,228 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sr) +# IC_MEDIAN -- Median of lines + +procedure ic_median$t (d, n, npts, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +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, 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) { + 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 + 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 + median[i] = blank + } +end +$endfor diff --git a/noao/imred/ccdred/src/combine/icmm.gx b/noao/imred/ccdred/src/combine/icmm.gx new file mode 100644 index 00000000..90837ae5 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icmm.gx @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sr) +# 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 + Memi[m[jmax]+i1] = Memi[m[j]+i1] + } else { + Mem$t[kmax] = d1 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } + if (jmin < j) { + if (jmax != n1) { + Mem$t[kmin] = d1 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } else { + Mem$t[kmin] = d2 + Memi[m[jmin]+i1] = Memi[m[j]+i1] + } + } + } 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 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } + } 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 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } 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/imred/ccdred/src/combine/icombine.com b/noao/imred/ccdred/src/combine/icombine.com new file mode 100644 index 00000000..cb826d58 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icombine.com @@ -0,0 +1,40 @@ +# ICOMBINE Common + +int combine # Combine algorithm +int reject # Rejection algorithm +bool project # Combine across the highest dimension? +real blank # Blank value +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 +int 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? + +pointer icm # Mask data structure + +common /imccom/ combine, reject, blank, 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, icm diff --git a/noao/imred/ccdred/src/combine/icombine.gx b/noao/imred/ccdred/src/combine/icombine.gx new file mode 100644 index 00000000..d6e93ef0 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icombine.gx @@ -0,0 +1,395 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "../icombine.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 (sr) +procedure icombine$t (in, out, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, npts, fd, stropen(), errcode(), imstati() +pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf +pointer buf, imgl1$t(), impl1i() +errchk stropen, imgl1$t, impl1i +$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 (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 (scales, nimages, TY_REAL) + call salloc (zeros, nimages, TY_REAL) + call salloc (wts, nimages, TY_REAL) + call amovki (D_ALL, Memi[lflag], nimages) + + # If aligned use the IMIO buffer otherwise we need vectors of + # output length. + + if (!aligned) { + call salloc (dbuf, nimages, TY_POINTER) + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 3 { + if (out[i] != NULL) + 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, 3 { + if (out[i] != NULL) + 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) + } + + do i = 1, nimages { + call imseti (in[i], IM_BUFSIZE, bufsize) + iferr (buf = imgl1$t (in[i])) { + switch (errcode()) { + case SYS_MFULL: + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (imstati (in[i], IM_CLOSEFD) == YES) { + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + do j = i-2, nimages + call imseti (in[j], IM_CLOSEFD, YES) + buf = imgl1$t (in[i]) + default: + 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, Memr[scales], Memr[zeros], + Memr[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, ctor() +real r, imgetr() +pointer sp, v1, v2, v3, outdata, buf, nm, impnli() +$if (datatype == sil) +pointer impnlr() +$else +pointer impnl$t() +$endif +errchk ic_scale, imgetr + +include "../icombine.com" + +begin + call smark (sp) + 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 || grow > 0) + 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 + if (grow > 0) + keepids = true + case PCLIP: + mclip = true + if (grow > 0) + keepids = true + case AVSIGCLIP, SIGCLIP: + if (doscale1 || grow > 0) + keepids = true + case NONE: + mclip = false + grow = 0 + } + + 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 (grow > 0) + call ic_grow$t (d, id, n, nimages, npts, Memr[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, Memr[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + 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 (grow > 0) + call ic_grow$t (d, id, n, nimages, npts, Mem$t[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, Mem$t[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $endif + + call sfree (sp) +end +$endfor diff --git a/noao/imred/ccdred/src/combine/icombine.h b/noao/imred/ccdred/src/combine/icombine.h new file mode 100644 index 00000000..13b77117 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icombine.h @@ -0,0 +1,52 @@ +# ICOMBINE Definitions + +# Memory management parameters; +define DEFBUFSIZE 65536 # default IMIO buffer size +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|" +define AVERAGE 1 +define MEDIAN 2 + +# 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/imred/ccdred/src/combine/icpclip.gx b/noao/imred/ccdred/src/combine/icpclip.gx new file mode 100644 index 00000000..223396c3 --- /dev/null +++ b/noao/imred/ccdred/src/combine/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 (sr) +# 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/combine/icscale.x b/noao/imred/ccdred/src/combine/icscale.x new file mode 100644 index 00000000..fc4efb2f --- /dev/null +++ b/noao/imred/ccdred/src/combine/icscale.x @@ -0,0 +1,376 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include "icombine.h" + +# IC_SCALE -- Get the scale factors for the images. +# 1. This procedure does CLIO to determine the type of scaling desired. +# 2. The output header parameters for exposure time and NCOMBINE are set. + +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, exposure, zmean, darktime, dark +pointer sp, ncombine, exptime, modes, medians, means +pointer section, str, sname, zname, wname, imref +bool domode, domedian, domean, dozero, snorm, znorm, wflag + +bool clgetb() +int hdmgeti(), strdic(), ic_gscale() +real hdmgetr(), asumr(), asumi() +errchk ic_gscale, 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_FNAME, 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) + + # Set the defaults. + call amovki (1, Memi[ncombine], nimages) + call amovkr (0., Memr[exptime], nimages) + call amovkr (INDEF, Memr[modes], nimages) + call amovkr (INDEF, Memr[medians], nimages) + call amovkr (INDEF, Memr[means], nimages) + call amovkr (1., scales, nimages) + call amovkr (0., zeros, nimages) + call amovkr (1., wts, nimages) + + # 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] = hdmgeti (in[i], "ncombine")) + Memi[ncombine+i-1] = 1 + iferr (Memr[exptime+i-1] = hdmgetr (in[i], "exptime")) + Memr[exptime+i-1] = 0. + if (project) { + call amovki (Memi[ncombine], Memi[ncombine], nimages) + call amovkr (Memr[exptime], Memr[exptime], nimages) + break + } + } + + # Set scaling 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 only if needed. + 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)) + if (domode || domedian || domean) { + Memc[section] = EOS + Memc[str] = EOS + call clgstr ("statsec", Memc[section], SZ_FNAME) + call sscan (Memc[section]) + 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 { + if (imref != out[1]) + imref = in[i] + call ic_statr (in[i], imref, Memc[section], offsets, + i, nimages, domode, domedian, domean, mode, median, mean) + if (domode) { + Memr[modes+i-1] = mode + if (stype == S_MODE) + scales[i] = mode + if (ztype == S_MODE) + zeros[i] = mode + if (wtype == S_MODE) + wts[i] = mode + } + if (domedian) { + Memr[medians+i-1] = median + if (stype == S_MEDIAN) + scales[i] = median + if (ztype == S_MEDIAN) + zeros[i] = median + if (wtype == S_MEDIAN) + wts[i] = median + } + if (domean) { + Memr[means+i-1] = mean + if (stype == S_MEAN) + scales[i] = mean + if (ztype == S_MEAN) + zeros[i] = mean + if (wtype == S_MEAN) + wts[i] = mean + } + } + } + + 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 relative factors if needed. + 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) + else { + mean = asumr (scales, nimages) / nimages + call adivkr (scales, mean, scales, nimages) + } + call adivr (zeros, scales, zeros, nimages) + zmean = asumr (zeros, nimages) / 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] * zmean / 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. + + call asubkr (zeros, zmean, 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) + call adivkr (wts, mean, wts, nimages) + + # 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 + } + } + if (!doscale1 && zmean > 0.) { + do i = 1, nimages { + if (abs (zeros[i] / zmean) > sigscale) { + doscale1 = true + break + } + } + } + } + + # Set the output header parameters. + nout = asumi (Memi[ncombine], nimages) + call hdmputi (out[1], "ncombine", nout) + exposure = 0. + darktime = 0. + mean = 0. + do i = 1, nimages { + exposure = exposure + wts[i] * Memr[exptime+i-1] / scales[i] + ifnoerr (dark = hdmgetr (in[i], "darktime")) + darktime = darktime + wts[i] * dark / scales[i] + else + darktime = darktime + wts[i] * Memr[exptime+i-1] / scales[i] + ifnoerr (mode = hdmgetr (in[i], "ccdmean")) + mean = mean + wts[i] * mode / scales[i] + } + call hdmputr (out[1], "exptime", exposure) + call hdmputr (out[1], "darktime", darktime) + ifnoerr (mode = hdmgetr (out[1], "ccdmean")) { + call hdmputr (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 (clgetb ("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, "", exposure) + + 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, + "", exposure) + + doscale = (doscale || dozero) + + call sfree (sp) +end + + +# IC_GSCALE -- Get scale values as directed by CL parameter +# 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, hdmgetr() +pointer errstr +errchk open, hdmgetr() + +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 + 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 + values[i] = rval + } + call close (fd) + if (i < nimages) { + call salloc (errstr, SZ_LINE, TY_CHAR) + call sprintf (Memc[errstr], SZ_FNAME, + "Insufficient %s values in %s") + call pargstr (param) + call pargstr (name[2]) + call error (1, Memc[errstr]) + } + } else if (name[1] == '!') { + type = S_KEYWORD + do i = 1, nimages { + values[i] = hdmgetr (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 + values[i] = max (0.001, exptime[i]) + } + + return (type) +end diff --git a/noao/imred/ccdred/src/combine/icsclip.gx b/noao/imred/ccdred/src/combine/icsclip.gx new file mode 100644 index 00000000..f70611aa --- /dev/null +++ b/noao/imred/ccdred/src/combine/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 (sr) +# 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/combine/icsection.x b/noao/imred/ccdred/src/combine/icsection.x new file mode 100644 index 00000000..746c1f51 --- /dev/null +++ b/noao/imred/ccdred/src/combine/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/imred/ccdred/src/combine/icsetout.x b/noao/imred/ccdred/src/combine/icsetout.x new file mode 100644 index 00000000..bd1d75ec --- /dev/null +++ b/noao/imred/ccdred/src/combine/icsetout.x @@ -0,0 +1,193 @@ +include <imhdr.h> +include <mwset.h> + +# 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 +real val +bool reloff, streq() +pointer sp, fname, lref, wref, cd, coord, shift, axno, axval +pointer mw, ct, mw_openim(), mw_sctran() +int open(), fscan(), nscan(), mw_stati() +errchk mw_openim, mw_gwtermd, mw_gltermd, mw_gaxmap +errchk mw_sctran, mw_ctrand, open + +include "icombine.com" +define newscan_ 10 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + 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]) + if (project) { + outdim = indim - 1 + IM_NDIM(out[1]) = outdim + } else { + 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]) + 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 (project) + Memd[lref+outdim] = 1 + + # Parse the user offset string. If "none" then there are no offsets. + # If "wcs" then set the offsets based on the image 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 || streq (Memc[fname], "none")) { + call aclri (offsets, outdim*nimages) + reloff = true + } else if (streq (Memc[fname], "wcs")) { + do j = 1, outdim + offsets[1,j] = 0 + if (project) { + 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 { + 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 + } else if (streq (Memc[fname], "grid")) { + amin = 1 + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 1+2*j) + break + do i = 1, nimages + offsets[i,j] = mod ((i-1)/amin, a) * b + amin = amin * a + } + reloff = true + } else { + 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 + } + } + + # Update the WCS. + if (project || !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] + } + call mw_sltermd (mw, Memd[cd], Memd[lref], mwdim) + } + if (project) { + # 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) + } + call mw_saveim (mw, out) + } + call mw_close (mw) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/combine/icsigma.gx b/noao/imred/ccdred/src/combine/icsigma.gx new file mode 100644 index 00000000..d0ae28d4 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icsigma.gx @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +$for (sr) +# 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 + } + sigma[i] = sqrt (sum / sumwt * 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/imred/ccdred/src/combine/icsort.gx b/noao/imred/ccdred/src/combine/icsort.gx new file mode 100644 index 00000000..2235dbd0 --- /dev/null +++ b/noao/imred/ccdred/src/combine/icsort.gx @@ -0,0 +1,386 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +define LOGPTR 32 # log2(maxpts) (4e9) + +$for (sr) +# 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/imred/ccdred/src/combine/icstat.gx b/noao/imred/ccdred/src/combine/icstat.gx new file mode 100644 index 00000000..099ddf5e --- /dev/null +++ b/noao/imred/ccdred/src/combine/icstat.gx @@ -0,0 +1,237 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 10000 # Maximum number of pixels to sample + +$for (sr) +# 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() +PIXEL ic_mode$t() +$if (datatype == irs) +real asum$t() +$endif +$if (datatype == dl) +double asum$t() +$endif +$if (datatype == x) +complex asum$t() +$endif + + +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, 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) + } + + 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.8 # 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/imred/ccdred/src/combine/mkpkg b/noao/imred/ccdred/src/combine/mkpkg new file mode 100644 index 00000000..2c5c0795 --- /dev/null +++ b/noao/imred/ccdred/src/combine/mkpkg @@ -0,0 +1,51 @@ +# Make CCDRED Package. + +$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/icombine.x, icombine.gx) + $(GEN) icombine.gx -o generic/icombine.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 + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + @generic + + 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 icombine.com <imhdr.h>\ + <pmset.h> + icscale.x icombine.com icombine.h <error.h> <imhdr.h> <imset.h> + icsection.x <ctype.h> + icsetout.x icombine.com <imhdr.h> <mwset.h> + ; diff --git a/noao/imred/ccdred/src/cor.gx b/noao/imred/ccdred/src/cor.gx new file mode 100644 index 00000000..189f9437 --- /dev/null +++ b/noao/imred/ccdred/src/cor.gx @@ -0,0 +1,362 @@ +include "ccdred.h" + + +.help cor Feb87 noao.imred.ccdred +.nf ---------------------------------------------------------------------------- +cor -- Process CCD image lines + +These procedures are the heart of the CCD processing. They do the desired +set of processing operations on the image line data as efficiently as +possible. They are called by the PROC procedures. There are four procedures +one for each readout axis and one for short and real image data. +Some sets of operations are coded as single compound operations for efficiency. +To keep the number of combinations managable only the most common +combinations are coded as compound operations. The combinations +consist of any set of line overscan, column overscan, zero level, dark +count, and flat field and any set of illumination and fringe +correction. The corrections are applied in place to the output vector. + +The column readout procedure is more complicated in order to handle +zero level and flat field corrections specified as one dimensional +readout corrections instead of two dimensional calibration images. +Column readout format is probably extremely rare and the 1D readout +corrections are used only for special types of data. +.ih +SEE ALSO +proc, ccdred.h +.endhelp ----------------------------------------------------------------------- + +$for (sr) +# COR1 -- Correct image lines with readout axis 1 (lines). + +procedure cor1$t (cors, out, overscan, zero, dark, flat, illum, + fringe, n, darkscale, flatscale, illumscale, frgscale) + +int cors[ARB] # Correction flags +PIXEL out[n] # Output data +real overscan # Overscan value +PIXEL zero[n] # Zero level correction +PIXEL dark[n] # Dark count correction +PIXEL flat[n] # Flat field correction +PIXEL illum[n] # Illumination correction +PIXEL fringe[n] # Fringe correction +int n # Number of pixels +real darkscale # Dark count scale factor +real flatscale # Flat field scale factor +real illumscale # Illumination scale factor +real frgscale # Fringe scale factor + +int i, op + +begin + op = cors[OVERSCAN] + cors[ZEROCOR] + cors[DARKCOR] + cors[FLATCOR] + switch (op) { + case O: # overscan + do i = 1, n + out[i] = out[i] - overscan + case Z: # zero level + do i = 1, n + out[i] = out[i] - zero[i] + + case ZO: # zero level + overscan + do i = 1, n + out[i] = out[i] - overscan - zero[i] + + case D: # dark count + do i = 1, n + out[i] = out[i] - darkscale * dark[i] + case DO: # dark count + overscan + do i = 1, n + out[i] = out[i] - overscan - darkscale * dark[i] + case DZ: # dark count + zero level + do i = 1, n + out[i] = out[i] - zero[i] - darkscale * dark[i] + case DZO: # dark count + zero level + overscan + do i = 1, n + out[i] = out[i] - overscan - zero[i] - darkscale * dark[i] + + case F: # flat field + do i = 1, n + out[i] = out[i] * flatscale / flat[i] + case FO: # flat field + overscan + do i = 1, n + out[i] = (out[i] - overscan) * flatscale / flat[i] + case FZ: # flat field + zero level + do i = 1, n + out[i] = (out[i] - zero[i]) * flatscale / flat[i] + case FZO: # flat field + zero level + overscan + do i = 1, n + out[i] = (out[i] - overscan - zero[i]) * flatscale / + flat[i] + case FD: # flat field + dark count + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatscale / flat[i] + case FDO: # flat field + dark count + overscan + do i = 1, n + out[i] = (out[i] - overscan - darkscale * dark[i]) * + flatscale / flat[i] + case FDZ: # flat field + dark count + zero level + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatscale / flat[i] + case FDZO: # flat field + dark count + zero level + overscan + do i = 1, n + out[i] = (out[i] - overscan - zero[i] - + darkscale * dark[i]) * flatscale / flat[i] + } + + # Often these operations will not be performed so test for no + # correction rather than go through the switch. + + op = cors[ILLUMCOR] + cors[FRINGECOR] + if (op != 0) { + switch (op) { + case I: # illumination + do i = 1, n + out[i] = out[i] * illumscale / illum[i] + case Q: # fringe + do i = 1, n + out[i] = out[i] - frgscale * fringe[i] + case QI: # fringe + illumination + do i = 1, n + out[i] = out[i]*illumscale/illum[i] - frgscale*fringe[i] + } + } +end + + +# COR2 -- Correct lines for readout axis 2 (columns). This procedure is +# more complex than when the readout is along the image lines because the +# zero level and/or flat field corrections may be single readout column +# vectors. + +procedure cor2$t (line, cors, out, overscan, zero, dark, flat, illum, + fringe, n, zeroim, flatim, darkscale, flatscale, illumscale, frgscale) + +int line # Line to be corrected +int cors[ARB] # Correction flags +PIXEL out[n] # Output data +real overscan[n] # Overscan value +PIXEL zero[n] # Zero level correction +PIXEL dark[n] # Dark count correction +PIXEL flat[n] # Flat field correction +PIXEL illum[n] # Illumination correction +PIXEL fringe[n] # Fringe correction +int n # Number of pixels +pointer zeroim # Zero level IMIO pointer (NULL if 1D vector) +pointer flatim # Flat field IMIO pointer (NULL if 1D vector) +real darkscale # Dark count scale factor +real flatscale # Flat field scale factor +real illumscale # Illumination scale factor +real frgscale # Fringe scale factor + +PIXEL zeroval +real flatval +int i, op + +begin + op = cors[OVERSCAN] + cors[ZEROCOR] + cors[DARKCOR] + cors[FLATCOR] + switch (op) { + case O: # overscan + do i = 1, n + out[i] = out[i] - overscan[i] + case Z: # zero level + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - zero[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - zeroval + } + + case ZO: # zero level + overscan + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - overscan[i] - zero[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - overscan[i] - zeroval + } + + case D: # dark count + do i = 1, n + out[i] = out[i] - darkscale * dark[i] + case DO: # dark count + overscan + do i = 1, n + out[i] = out[i] - overscan[i] - darkscale * dark[i] + case DZ: # dark count + zero level + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - zero[i] - darkscale * dark[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - zeroval - darkscale * dark[i] + } + case DZO: # dark count + zero level + overscan + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - overscan[i] - zero[i] - + darkscale * dark[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - overscan[i] - zeroval - + darkscale * dark[i] + } + + case F: # flat field + if (flatim != NULL) { + do i = 1, n + out[i] = out[i] * flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = out[i] * flatval + } + case FO: # flat field + overscan + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i]) * flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - overscan[i]) * flatval + } + case FZ: # flat field + zero level + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i]) * flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval) * flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval) * flatval + } + } + case FZO: # flat field + zero level + overscan + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i]) * + flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval) * + flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval) * flatval + } + } + case FD: # flat field + dark count + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatscale/flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatval + } + case FDO: # flat field + dark count + overscan + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - darkscale * dark[i]) * + flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - darkscale * dark[i]) * + flatval + } + case FDZ: # flat field + dark count + zero level + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval - darkscale * dark[i]) * + flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval - darkscale * dark[i]) * + flatval + } + } + case FDZO: # flat field + dark count + zero level + overscan + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i] - + darkscale * dark[i]) * flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval - + darkscale * dark[i]) * flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i] - + darkscale * dark[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval - + darkscale * dark[i]) * flatval + } + } + } + + # Often these operations will not be performed so test for no + # correction rather than go through the switch. + + op = cors[ILLUMCOR] + cors[FRINGECOR] + if (op != 0) { + switch (op) { + case I: # illumination + do i = 1, n + out[i] = out[i] * illumscale / illum[i] + case Q: # fringe + do i = 1, n + out[i] = out[i] - frgscale * fringe[i] + case QI: # fringe + illumination + do i = 1, n + out[i] = out[i]*illumscale/illum[i] - frgscale*fringe[i] + } + } +end +$endfor diff --git a/noao/imred/ccdred/src/cosmic/cosmicrays.hlp b/noao/imred/ccdred/src/cosmic/cosmicrays.hlp new file mode 100644 index 00000000..bfb56e9c --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/cosmicrays.hlp @@ -0,0 +1,338 @@ +.help cosmicrays Dec87 noao.imred.ccdred +.ih +NAME +cosmicrays -- Detect and replace cosmic rays +.ih +USAGE +cosmicrays input output +.ih +PARAMETERS +.ls input +List of input images in which to detect cosmic rays. +.le +.ls output +List of output images in which the detected cosmic rays will be replaced +by an average of neighboring pixels. If the output image name differs +from the input image name then a copy of the input image is made with +the detected cosmic rays replaced. If no output images are specified +then the input images are modified in place. In place modification of +an input image also occurs when the output image name is the same as +the input image name. +.le +.ls badpix = "" +List of bad pixel files to be created, one for each input image. If no +file names are given then no bad pixel file is created. The bad pixel +file is a simple list of pixel coordinates for each replaced cosmic ray. +This file may be used in conjunction with \fBbadpixelimage\fR to create +a mask image. +.le + +.ls ccdtype = "" +If specified only the input images of the desired CCD image type will be +selected. +.le +.ls threshold = 25. +Detection threshold above the mean of the surrounding pixels for cosmic +rays. The threshold will depend on the noise characteristics of the +image and how weak the cosmic rays may be for detection. A typical value +is 5 or more times the sigma of the background. +.le +.ls fluxratio = 2. +The ratio (as a percent) of the mean neighboring pixel flux to the candidate +cosmic ray pixel for rejection. The value depends on the seeing and the +characteristics of the cosmic rays. Typical values are in the range +2 to 10 percent. This value may be reset interactively from a plot +or defined by identifying selected objects as stars or cosmic rays. +.le +.ls npasses = 5 +Number of cosmic ray detection passes. Since only the locally strongest +pixel is considered a cosmic ray, multiple detection passes are needed to +detect and replace multiple pixel cosmic ray events. +.le +.ls window = 5 +Size of cosmic ray detection window. A square window of either 5 by 5 or +7 by 7 is used to detect cosmic rays. The smaller window allows detection +in the presence of greater background gradients but is less sensitive at +discriminating multiple event cosmic rays from stars. It is also marginally +faster. +.le +.ls interactive = yes +Examine parameters interactively? A plot of the mean flux within the +detection window (x100) vs the flux ratio (x100) is plotted and the user may +set the flux ratio threshold, delete and undelete specific events, and +examine specific events. This is useful for new data in which one is +uncertain of an appropriate flux ratio threshold. Once determined the +task need not be used interactively. +.le +.ls train = no +Define the flux ratio threshold by using a set of objects identified +as stars (or other astronomical objects) or cosmic rays? +.le +.ls objects = "" +Cursor list of coordinates of training objects. If null (the null string "") +then the image display cursor will be read. The user is responsible for first +displaying the image. Otherwise a file containing cursor coordinates +may be given. The format of the cursor file is "x y wcs key" where +x and y are the pixel coordinates, wcs is an arbitrary number such as 1, +and key may be 's' for star or 'c' for cosmic ray. +.le +.ls savefile = "" +File to save (by appending) the training object coordinates. This is of +use when the objects are identified using the image display cursor. The +saved file can then be input as the object cursor list for repeating the +execution. +.le +.ls answer +This parameter is used for interactive queries when processing a list of +images. The responses may be "no", "yes", "NO", or "YES". The upper case +responses permanently enable or disable the interactive review while +the lower case reponses allow selective examination of certain input +images. \fIThis parameter should not be specified on the command line. +If it is then the value will be ignored and the task will act as if +the answer "yes" is given for each image; i.e. it will enter the interactive +phase without prompting.\fR +.le +.ih +OTHER PARAMETERS +There are other parameters which may be defined by the package, as is the +case with \fBccdred\fR, or as part of the task, as is the case with +standalone version in the \fBgeneric\fR package. + +.ls verbose +If yes then a time stamped log of the operation is printed on the standard +output. +.le +.ls logfile +If a log file is specified then a time stamped log of the operation is +recorded. +.le +.ls plotfile +If a plot file is specified then the graph of the flux ratio (x100) vs +the mean flux (x100) is recorded as metacode. This may be spooled or examined +later. +.le +.ls graphics = "stdgraph" +Interactive graphic output device for interactive examination of the +detection parameters. +.le +.ls cursor = "" +Interactive graphics cursor input. If null the graphics display cursor +is used, otherwise a file containing cursor input may be specified. +.le +.ls instrument +The \fBccdred\fR instrument file is used for mapping header keywords and +CCD image types. +.le +.ih +IMAGE CURSOR COMMANDS + +.nf +? Help +c Identify the object as a cosmic ray +s Identify the object as a star +g Switch to the graphics plot +q Quit and continue with the cleaning +.fi + +GRAPHICS CURSOR COMMANDS + +.nf +? Help +a Toggle between showing all candidates and only the training points +d Mark candidate for replacement (applys to '+' points) +q Quit and return to image cursor or replace the selected pixels +r Redraw the graph +s Make a surface plot for the candidate nearest the cursor +t Set the flux ratio threshold at the y cursor position +u Mark candidate to not be replaced (applys to 'x' points) +w Adjust the graph window (see \fBgtools\fR) +<space> Print the pixel coordinates +.fi + +There are no colon commands except those for the windowing options (type +:\help or see \fBgtools\fR). +.ih +DESCRIPTION +Cosmic ray events in each input image are detected and replaced by the +average of the four neighbors. The replacement may be performed +directly on the input image if no output image is specified or if the +output image name is the same as the input image name. If a new image +is created it is a copy of the input image except for the replaced +pixels. The processing keyword CRCOR is added to the output image +header. Optional output includes a log file to which a processing log +is appended, a verbose log output to the standard output (the same as +that in the log file), a plot file showing the parameters of the +detected cosmic ray candidates and the flux ratio threshold used, a +bad pixel file containing the coordinates of the replaced pixels, and +a file of training objects marked with the image display cursor. The +bad pixel file may be used for plotting purposes or to create a mask +image for display and analysis using the task \fBbadpiximage\fR. This +bad pixel file will be replaced by the IRAF bad pixel facility when it +becomes available. If one wants more than a simple mask image then by +creating a different output image a difference image between the +original and the modified image may be made using \fBimarith\fR. + +This task may be applied to an image previously processed to detect +additional cosmic rays. A warning will be given (because of the +CRCOR header parameter) and the previous processing header keyword will +be overwritten. + +The cosmic ray detection algorithm consists of the following steps. +First a pixel must be the brightest pixel within the specified +detection window (either 5x5 or 7x7). The mean flux in the surrounding +pixels with the second brightest pixel excluded (which may also be a +cosmic ray event) is computed and the candidate pixel must exceed this +mean by the amount specified by the parameter \fIthreshold\fR. A plane +is fit to the border pixels of the window and the fitted background is +subtracted. The mean flux (now background subtracted) and the ratio of +this mean to the cosmic ray candidate (the brightest pixel) are +computed. The mean flux (x100) and the ratio (x100) are recorded for +interactive examination if desired. + +Once the list of cosmic ray candidates has been created and a threshold for +the flux ratio established (by the parameter \fIfluxratio\fR, by the +"training" method, or by using the graphics cursor in the interactive plot) +the pixels with ratios below the threshold are replaced in the output by +the average of the four neighboring pixels (with the second strongest pixel +in the detection window excluded if it is one of these pixels). Additonal +pixels may then be detected and replaced in further passes as specified by +the parameter \fInpasses\fR. Note that only pixels in the vicinity of +replaced pixels need be considered in further passes. + +The division between the peaks of real objects and cosmic rays is made +based on the flux ratio between the mean flux (excluding the center +pixel and the second strongest pixel) and the candidate pixel. This +threshold depends on the point spread function and the distribution of +multiple cosmic ray events and any additional neighboring light caused +by the events. This threshold is not strongly coupled to small changes +in the data so that once it is set for a new type of image data it may +be used for similar images. To set it initially one may examine the +scatter plot of the flux ratio as a function of the mean flux. This +may be done interactively or from the optional plot file produced. + +After the initial list of cosmic ray candidates has been created and before +the final replacing cosmic rays there are two optional steps to allow +examining the candidates and setting the flux ratio threshold dividing +cosmic rays from real objects. The first optional step is define the flux +ratio boundary by reference to user specified classifications; that is +"training". To do this step the \fItrain\fR parameter must be set to yes. +The user classified objects are specified by a cursor input list. This +list can be an actual file or the image display cursor as defined by the +\fIobjects\fR parameter. The \fIsavefile\fR parameter is also used during +the training to record the objects specified. The parameter specifies a +file to append the objects selected. This is useful when the objects are +defined by interactive image cursor and does not make much sense when using +an input list. + +If the \fIobjects\fR parameter is specified as a null string then +the image display cursor will be repeatedly read until a 'q' is +entered. The user first displays the image and then when the task +reads the display cursor the cursor shape will change. The user +points at objects and types 's' for a star (or other astronomical +object) and 'c' for a cosmic ray. Note that this input is used +to search for the matching object in the cosmic ray candidate list +and so it is possible the selected object is not in the list though +it is unlikely. The selection will be quietly ignored in that case. +To exit the interactive selection of training objects type 'q'. + +If 'g' is typed a graph of all the candidates is drawn showing +"flux" vs. "flux ratio" (see below for more). Training objects will +be shown with a box and the currently set flux ratio threshold will +also be shown. Exiting the plot will return to entering more training +objects. The plot will remain and additional objects will immediately +be shown with a new box. Thus, if one wants to see the training +objects identified in the plot as one selects them from the image +display first type a 'g' to draw the initial plot. Also by switching +to the plot with 'g' allows you to draw surface plots (with 's') or +get the pixel coordinates of a candidate (the space key) to be +found in the display using the coordinate readout of the display. +Note that the display interaction is simpler than might be desired +because this task does not directly connect to the display. + +The most likely use for training is with the interactive image display. +However one may prepare an input list by other means, one example +is with \fBrimcursor\fR, and then specify the file name. The savefile +may also be used a cursor input to repeat the cosmic ray operation +(but be careful not to have the cursor input and save file be the +same file!). + +The flux ratio threshold is determined from the training objects by +finding the point with the minimum number of misclassifications +(stars as cosmic rays or cosmic rays as stars). The threshold is +set at the lowest value so that it will always go through one of +the cosmic ray objects. There should be at least one of each type +of object defined for this to work. The following option of +examining the cosmic ray candidates and parameters may still be +used to modify the derived flux ratio threshold. One last point +about the training objects is that even if some of the points +lie on the wrong side of the threshold they will remain classified +as cosmic ray or non-cosmic ray. In other words, any object +classified by the user will remain in that classification regardless +of the final flux ratio threshold. + +After the training step the user will be queried to examine the candidates +in the flux vs flux ratio plane if the \fIinteractive\fR flag is set. +Responses may be made for specific images or for all images by using +lower or upper case answers respectively. When the parameters are +examined interactively the user may change the flux ratio threshold +('t' key). Changes made are stored in the parameter file and, thus, +learned for further images. Pixels to be deleted are marked by crosses +and pixels which are peaks of objects are marked by pluses. The user +may explicitly delete or undelete any point if desired but this is only +for special cases near the threshold. In the future keys for +interactive display of the specific detections will be added. +Currently a surface plot of any candidate may be displayed graphically +in four 90 degree rotated views using the 's' key. Note that the +initial graph does not show all the points some of which are clearly +cosmic rays because they have negative mean flux or flux ratio. To +view all data one must rewindow the graph with the 'w' key or ":/" +commands (see \fBgtools\fR). +.ih +EXAMPLES +1. To replace cosmic rays in a set of images ccd* without training: + +.nf + cl> cosmicrays ccd* new//ccd* + ccd001: Examine parameters interactively? (yes): + [A scatter plot graph is made. One can adjust the threshold.] + [Looking at a few points using the 's' key can be instructive.] + [When done type 'q'.] + ccd002: Examine parameters interactively? (yes): NO + [No further interactive examination is done.] +.fi + +After cleaning one typically displays the images and possibly blinks them. +A difference image or mask image may also be created. + +2. To use the interactive training method for setting the flux ratio threshold: + +.nf + # First display the image. + cl> display ccd001 1 + z1 = 123.45 z2= 543.21 + cl> cosmicrays ccd001 ccd001cr train+ + [After the cosmic ray candidates are found the image display + [cursor will be activated. Mark a cosmic ray with 'c' and + [a star with 's'. Type 'g' to get a plot showing the two + [points with boxes. Type 'q' to go back to the image display. + [As each new object is marked a box will appear in the plot and + [the threshold may change. To find the location of an object + [seen in the plot use 'g' to go to the graph, space key to find + [the pixel coordinates, 'q' to go back to the image display, + [and the image display coordinate box to find the object. + [When done with the training type 'q'. + ccd001: Examine parameters interactively? (yes): no +.fi + +3. To create a mask image a bad pixel file must be specified. In the +following we replace the cosmic rays in place and create a bad pixel +file and mask image: + +.nf + cl> cosmicrays ccd001 ccd001 badpix=ccd001.bp + cl> badpiximage ccd001.bp ccd001 ccd001bp +.fi +.ih +SEE ALSO +badpixelimage gtools imedit rimcursor +.endhelp diff --git a/noao/imred/ccdred/src/cosmic/crexamine.x b/noao/imred/ccdred/src/cosmic/crexamine.x new file mode 100644 index 00000000..d84961bc --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/crexamine.x @@ -0,0 +1,486 @@ +include <error.h> +include <syserr.h> +include <imhdr.h> +include <gset.h> +include <mach.h> +include <pkg/gtools.h> +include "crlist.h" + +# CR_EXAMINE -- Examine cosmic ray candidates interactively. +# CR_GRAPH -- Make a graph +# CR_NEAREST -- Find the nearest cosmic ray to the cursor. +# CR_DELETE -- Set replace flag for cosmic ray candidate nearest cursor. +# CR_UNDELETE -- Set no replace flag for cosmic ray candidate nearest cursor. +# CR_UPDATE -- Change replacement flags, thresholds, and graphs. +# CR_PLOT -- Make log plot + +define HELP "noao$lib/scr/cosmicrays.key" +define PROMPT "cosmic ray options" + +# CR_EXAMINE -- Examine cosmic ray candidates interactively. + +procedure cr_examine (cr, gp, gt, im, fluxratio, first) + +pointer cr # Cosmic ray list +pointer gp # GIO pointer +pointer gt # GTOOLS pointer +pointer im # Image pointer +real fluxratio # Flux ratio threshold +int first # Initial key + +char cmd[SZ_LINE] +int i, newgraph, wcs, key, nc, nl, c1, c2, l1, l2, show +real wx, wy +pointer data + +int clgcur() +pointer imgs2r() + +begin + # Set up the graphics. + call gt_sets (gt, GTPARAMS, IM_TITLE(im)) + + # Set image limits + nc = IM_LEN(im, 1) + nl = IM_LEN(im, 2) + + # Enter cursor loop. + key = first + repeat { + switch (key) { + case '?': # Print help text. + call gpagefile (gp, HELP, PROMPT) + case ':': # Colon commands. + switch (cmd[1]) { + case '/': + call gt_colon (cmd, gp, gt, newgraph) + default: + call printf ("\007") + } + case 'a': # Toggle show all + if (show == 0) + show = 1 + else + show = 0 + newgraph = YES + case 'd': # Delete candidate + call cr_delete (gp, wx, wy, cr, i, show) + case 'q': # Quit + break + case 'r': # Redraw the graph. + newgraph = YES + case 's': # Make surface plots + call cr_nearest (gp, wx, wy, cr, i, show) + c1 = max (1, int (Memr[CR_COL(cr)+i-1]) - 5) + c2 = min (nc, int (Memr[CR_COL(cr)+i-1]) + 5) + l1 = max (1, int (Memr[CR_LINE(cr)+i-1]) - 5) + l2 = min (nl, int (Memr[CR_LINE(cr)+i-1]) + 5) + data = imgs2r (im, c1, c2, l1, l2) + call gclear (gp) + call gsview (gp, 0.03, 0.48, 0.53, 0.98) + call cr_surface (gp, Memr[data], c2-c1+1, l2-l1+1, -33., 25.) + call gsview (gp, 0.53, 0.98, 0.53, 0.98) + call cr_surface (gp, Memr[data], c2-c1+1, l2-l1+1, -123., 25.) + call gsview (gp, 0.03, 0.48, 0.03, 0.48) + call cr_surface (gp, Memr[data], c2-c1+1, l2-l1+1, 57., 25.) + call gsview (gp, 0.53, 0.98, 0.03, 0.48) + call cr_surface (gp, Memr[data], c2-c1+1, l2-l1+1, 147., 25.) + call fprintf (STDERR, "[Type any key to continue]") + i = clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) + newgraph = YES + case 't': # Set threshold + call cr_update (gp, wy, cr, fluxratio, show) + call clputr ("fluxratio", fluxratio) + case 'u': # Undelete candidate + call cr_undelete (gp, wx, wy, cr, i, show) + case 'w':# Window the graph. + call gt_window (gt, gp, "cursor", newgraph) + case ' ': # Print info + call cr_nearest (gp, wx, wy, cr, i, show) + call printf ("%d %d\n") + call pargr (Memr[CR_COL(cr)+i-1]) + call pargr (Memr[CR_LINE(cr)+i-1]) + case 'z': # NOP + newgraph = NO + default: # Ring bell for unrecognized commands. + call printf ("\007") + } + + # Update the graph if needed. + if (newgraph == YES) { + call cr_graph (gp, gt, cr, fluxratio, show) + newgraph = NO + } + } until (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) +end + + +# CR_GRAPH -- Make a graph + +procedure cr_graph (gp, gt, cr, fluxratio, show) + +pointer gp # GIO pointer +pointer gt # GTOOLS pointers +pointer cr # Cosmic ray list +real fluxratio # Flux ratio threshold +int show # Show (0=all, 1=train) + +int i, ncr +real x1, x2, y1, y2 +pointer sp, x, y, w, flag, index + +begin + call smark (sp) + + call cr_show (show, cr, x, y, w, flag, index, ncr) + if (ncr == 0) { + call sfree (sp) + return + } + + call gclear (gp) + call gt_ascale (gp, gt, Memr[x+1], Memr[y+1], ncr) + call gt_swind (gp, gt) + call gt_labax (gp, gt) + + do i = 1, ncr { + if ((Memi[flag+i] == NO) || (Memi[flag+i] == ALWAYSNO)) + call gmark (gp, Memr[x+i], Memr[y+i], GM_PLUS, 2., 2.) + else + call gmark (gp, Memr[x+i], Memr[y+i], GM_CROSS, 2., 2.) + if (Memr[w+i] != 0.) + call gmark (gp, Memr[x+i], Memr[y+i], GM_BOX, 2., 2.) + } + + call ggwind (gp, x1, x2, y1, y2) + call gseti (gp, G_PLTYPE, 2) + call gline (gp, x1, fluxratio, x2, fluxratio) + + call sfree (sp) +end + + +# CR_NEAREST -- Find the nearest cosmic ray to the cursor. + +procedure cr_nearest (gp, wx, wy, cr, nearest, show) + +pointer gp # GIO pointer +real wx, wy # Cursor position +pointer cr # Cosmic ray list +int nearest # Index of nearest point (returned) +int show # Show (0=all, 1=train) + +int i, ncr +real x0, y0, x1, y1, x2, y2, r2, r2min +pointer sp, x, y, w, flag, index + +begin + call smark (sp) + + call cr_show (show, cr, x, y, w, flag, index, ncr) + if (ncr == 0) { + call sfree (sp) + return + } + + # Search for nearest point in NDC. + r2min = MAX_REAL + call gctran (gp, wx, wy, wx, wy, 1, 0) + do i = 1, ncr { + x1 = Memr[x+i] + y1 = Memr[y+i] + call gctran (gp, x1, y1, x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + x2 = x1 + y2 = y1 + nearest = i + } + } + if (index != NULL) + nearest = Memi[index+nearest] + + # Move the cursor to the selected point. + call gscur (gp, x2, y2) + + call sfree (sp) +end + + +# CR_DELETE -- Set replace flag for cosmic ray candidate nearest cursor. + +procedure cr_delete (gp, wx, wy, cr, nearest, show) + +pointer gp # GIO pointer +real wx, wy # Cursor position +pointer cr # Cosmic ray list +int nearest # Index of nearest point (returned) +int show # Show (0=all, 1=train) + +int i, ncr +real x0, y0, x1, y1, x2, y2, r2, r2min +pointer sp, x, y, w, flag, index + +begin + call smark (sp) + + call cr_show (show, cr, x, y, w, flag, index, ncr) + if (ncr == 0) { + call sfree (sp) + return + } + + # Search for nearest point in NDC. + nearest = 0 + r2min = MAX_REAL + call gctran (gp, wx, wy, wx, wy, 1, 0) + do i = 1, ncr { + if ((Memi[flag+i] == YES) || (Memi[flag+i] == ALWAYSYES)) + next + x1 = Memr[x+i] + y1 = Memr[y+i] + call gctran (gp, x1, y1, x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + x2 = x1 + y2 = y1 + nearest = i + } + } + + # Move the cursor to the selected point and mark the deleted point. + if (nearest > 0) { + if (index != NULL) + nearest = Memi[index+nearest] + Memi[CR_FLAG(cr)+nearest-1] = ALWAYSYES + Memi[CR_WT(cr)+nearest-1] = -1 + call gscur (gp, x2, y2) + call gseti (gp, G_PMLTYPE, 0) + y2 = Memr[CR_RATIO(cr)+nearest-1] + call gmark (gp, x2, y2, GM_PLUS, 2., 2.) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, x2, y2, GM_CROSS, 2., 2.) + } + + call sfree (sp) +end + + +# CR_UNDELETE -- Set no replace flag for cosmic ray candidate nearest cursor. + +procedure cr_undelete (gp, wx, wy, cr, nearest, show) + +pointer gp # GIO pointer +real wx, wy # Cursor position +pointer cr # Cosmic ray list +int nearest # Index of nearest point (returned) +int show # Show (0=all, 1=train) + +int i, ncr +real x0, y0, x1, y1, x2, y2, r2, r2min +pointer sp, x, y, w, flag, index + +begin + call smark (sp) + + call cr_show (show, cr, x, y, w, flag, index, ncr) + if (ncr == 0) { + call sfree (sp) + return + } + + # Search for nearest point in NDC. + nearest = 0 + r2min = MAX_REAL + call gctran (gp, wx, wy, wx, wy, 1, 0) + do i = 1, ncr { + if ((Memi[flag+i] == NO) || (Memi[flag+i] == ALWAYSNO)) + next + x1 = Memr[x+i] + y1 = Memr[y+i] + call gctran (gp, x1, y1, x0, y0, 1, 0) + r2 = (x0 - wx) ** 2 + (y0 - wy) ** 2 + if (r2 < r2min) { + r2min = r2 + x2 = x1 + y2 = y1 + nearest = i + } + } + + # Move the cursor to the selected point and mark the delete point. + if (nearest > 0) { + if (index != NULL) + nearest = Memi[index+nearest] + Memi[CR_FLAG(cr)+nearest-1] = ALWAYSNO + Memi[CR_WT(cr)+nearest-1] = 1 + call gscur (gp, x2, y2) + + call gseti (gp, G_PMLTYPE, 0) + y2 = Memr[CR_RATIO(cr)+nearest-1] + call gmark (gp, x2, y2, GM_CROSS, 2., 2.) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, x2, y2, GM_PLUS, 2., 2.) + } + + call sfree (sp) +end + + +# CR_UPDATE -- Change replacement flags, thresholds, and graphs. + +procedure cr_update (gp, wy, cr, fluxratio, show) + +pointer gp # GIO pointer +real wy # Y cursor position +pointer cr # Cosmic ray list +real fluxratio # Flux ratio threshold +int show # Show (0=all, 1=train) + +int i, ncr, flag +real x1, x2, y1, y2 +pointer x, y, f + +begin + call gseti (gp, G_PLTYPE, 0) + call ggwind (gp, x1, x2, y1, y2) + call gline (gp, x1, fluxratio, x2, fluxratio) + fluxratio = wy + call gseti (gp, G_PLTYPE, 2) + call gline (gp, x1, fluxratio, x2, fluxratio) + + if (show == 1) + return + + ncr = CR_NCR(cr) + x = CR_FLUX(cr) - 1 + y = CR_RATIO(cr) - 1 + f = CR_FLAG(cr) - 1 + + do i = 1, ncr { + flag = Memi[f+i] + if ((flag == ALWAYSYES) || (flag == ALWAYSNO)) + next + x1 = Memr[x+i] + y1 = Memr[y+i] + if (flag == NO) { + if (y1 < fluxratio) { + Memi[f+i] = YES + call gseti (gp, G_PMLTYPE, 0) + call gmark (gp, x1, y1, GM_PLUS, 2., 2.) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, x1, y1, GM_CROSS, 2., 2.) + } + } else { + if (y1 >= fluxratio) { + Memi[f+i] = NO + call gseti (gp, G_PMLTYPE, 0) + call gmark (gp, x1, y1, GM_CROSS, 2., 2.) + call gseti (gp, G_PMLTYPE, 1) + call gmark (gp, x1, y1, GM_PLUS, 2., 2.) + } + } + } +end + + +# CR_PLOT -- Make log plot + +procedure cr_plot (cr, im, fluxratio) + +pointer cr # Cosmic ray list +pointer im # Image pointer +real fluxratio # Flux ratio threshold + +int fd, open(), errcode() +pointer sp, fname, gp, gt, gopen(), gt_init() +errchk gopen + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Open the plotfile. + call clgstr ("plotfile", Memc[fname], SZ_FNAME) + iferr (fd = open (Memc[fname], APPEND, BINARY_FILE)) { + if (errcode() != SYS_FNOFNAME) + call erract (EA_WARN) + return + } + + # Set up the graphics. + gp = gopen ("stdplot", NEW_FILE, fd) + gt = gt_init() + call gt_sets (gt, GTTYPE, "mark") + call gt_sets (gt, GTXTRAN, "log") + call gt_setr (gt, GTXMIN, 10.) + call gt_setr (gt, GTYMIN, 0.) + call gt_sets (gt, GTTITLE, "Parameters of cosmic rays candidates") + call gt_sets (gt, GTPARAMS, IM_TITLE(im)) + call gt_sets (gt, GTXLABEL, "Flux") + call gt_sets (gt, GTYLABEL, "Flux Ratio") + + call cr_graph (gp, gt, cr, fluxratio, 'r') + + call gt_free (gt) + call gclose (gp) + call close (fd) + call sfree (sp) +end + + +# CR_SHOW -- Select data to show. +# This returns pointers to the data. Note the pointers are salloc from +# the last smark which is done by the calling program. + +procedure cr_show (show, cr, x, y, w, flag, index, ncr) + +int show #I Data to show (0=all, 1=train) +pointer cr #I CR data +pointer x #O Fluxes +pointer y #O Ratios +pointer w #O Weights +pointer flag #O Flags +pointer index #O Index into CR data (if not null) +int ncr #O Number of selected data points + +int i + +begin + switch (show) { + case 0: + ncr = CR_NCR(cr) + x = CR_FLUX(cr) - 1 + y = CR_RATIO(cr) - 1 + w = CR_WT(cr) - 1 + flag = CR_FLAG(cr) - 1 + index = NULL + case 1: + ncr = CR_NCR(cr) + call salloc (x, ncr, TY_REAL) + call salloc (y, ncr, TY_REAL) + call salloc (w, ncr, TY_REAL) + call salloc (flag, ncr, TY_INT) + call salloc (index, ncr, TY_INT) + + ncr = 0 + x = x - 1 + y = y - 1 + w = w - 1 + flag = flag - 1 + index = index - 1 + + do i = 1, CR_NCR(cr) { + if (Memr[CR_WT(cr)+i-1] == 0.) + next + ncr = ncr + 1 + Memr[x+ncr] = Memr[CR_FLUX(cr)+i-1] + Memr[y+ncr] = Memr[CR_RATIO(cr)+i-1] + Memr[w+ncr] = Memr[CR_WT(cr)+i-1] + Memi[flag+ncr] = Memi[CR_FLAG(cr)+i-1] + Memi[index+ncr] = i + } + } +end diff --git a/noao/imred/ccdred/src/cosmic/crfind.x b/noao/imred/ccdred/src/cosmic/crfind.x new file mode 100644 index 00000000..58850940 --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/crfind.x @@ -0,0 +1,305 @@ +include <math/gsurfit.h> + +# CR_FIND -- Find cosmic ray candidates. +# This procedure is an interface to special procedures specific to a given +# window size. + +procedure cr_find (cr, threshold, data, nc, nl, col, line, + sf1, sf2, x, y, z, w) + +pointer cr # Cosmic ray list +real threshold # Detection threshold +pointer data[ARB] # Data lines +int nc # Number of columns +int nl # Number of lines +int col # First column +int line # Center line +pointer sf1, sf2 # Surface fitting +real x[ARB], y[ARB], z[ARB], w[ARB] # Surface arrays + +pointer a, b, c, d, e, f, g + +begin + switch (nl) { + case 5: + a = data[1] + b = data[2] + c = data[3] + d = data[4] + e = data[5] + call cr_find5 (cr, threshold, col, line, Memr[a], Memr[b], + Memr[c], Memr[d], Memr[e], nc, sf1, sf2, x, y, z, w) + case 7: + a = data[1] + b = data[2] + c = data[3] + d = data[4] + e = data[5] + f = data[6] + g = data[7] + call cr_find7 (cr, threshold, col, line, Memr[a], Memr[b], + Memr[c], Memr[d], Memr[e], Memr[f], Memr[g], nc, + sf1, sf2, x, y, z, w) + } +end + + +# CR_FIND7 -- Find cosmic rays candidates in 7x7 window. +# This routine finds cosmic rays candidates with the following algorithm. +# 1. If the pixel is not a local maximum relative to it's 48 neighbors +# go on to the next pixel. +# 2. Identify the next strongest pixel in the 7x7 region. +# This suspect pixel is excluded in the following. +# 2. Compute the flux of the 7x7 region excluding the cosmic ray +# candidate and the suspect pixel. +# 3. The candidate must exceed the average flux per pixel by a specified +# threshold. If not go on to the next pixel. +# 4. Fit a plane to the border pixels (excluding the suspect pixel). +# 5. Subtract the background defined by the plane. +# 6. Determine a replacement value as the average of the four adjacent +# pixels (excluding the suspect pixels). +# 7. Add the pixel to the cosmic ray candidate list. + +procedure cr_find7 (cr, threshold, col, line, a, b, c, d, e, f, g, n, + sf1, sf2, x, y, z, w) + +pointer cr # Cosmic ray list +real threshold # Detection threshold +int col # First column +int line # Line +real a[ARB], b[ARB], c[ARB], d[ARB] # Image lines +real e[ARB], f[ARB], g[ARB] # Image lines +int n # Number of columns +pointer sf1, sf2 # Surface fitting +real x[49], y[49], z[49], w[49] # Surface arrays + +real bkgd[49] +int i1, i2, i3, i4, i5, i6, i7, j, j1, j2 +real p, flux, replace, asumr() +pointer sf + +begin + for (i4=4; i4<=n-3; i4=i4+1) { + # Must be local maxima. + p = d[i4] + if (p<a[i4]||p<b[i4]||p<c[i4]||p<e[i4]||p<f[i4]||p<g[i4]) + next + i1 = i4 - 3 + if (p<a[i1]||p<b[i1]||p<c[i1]||p<d[i1]||p<e[i1]||p<f[i1]||p<g[i1]) + next + i2 = i4 - 2 + if (p<a[i2]||p<b[i2]||p<c[i2]||p<d[i2]||p<e[i2]||p<f[i2]||p<g[i2]) + next + i3 = i4 - 1 + if (p<a[i3]||p<b[i3]||p<c[i3]||p<d[i3]||p<e[i3]||p<f[i3]||p<g[i3]) + next + i5 = i4 + 1 + if (p<a[i5]||p<b[i5]||p<c[i5]||p<d[i5]||p<e[i5]||p<f[i5]||p<g[i5]) + next + i6 = i4 + 2 + if (p<a[i6]||p<b[i6]||p<c[i6]||p<d[i6]||p<e[i6]||p<f[i6]||p<g[i6]) + next + i7 = i4 + 3 + if (p<a[i7]||p<b[i7]||p<c[i7]||p<d[i7]||p<e[i7]||p<f[i7]||p<g[i7]) + next + + # Convert to a single array in surface fitting order. + call amovr (a[i1], z[1], 7) + z[8] = b[i7]; z[9] = c[i7]; z[10] = d[i7]; z[11] = e[i7] + z[12] = f[i7]; z[13] = g[i7]; z[14] = g[i6]; z[15] = g[i5] + z[16] = f[i4]; z[17] = g[i3]; z[18] = g[i2]; z[19] = g[i1] + z[20] = f[i1]; z[21] = e[i1]; z[22] = d[i1]; z[23] = c[i1] + z[24] = b[i1] + call amovr (b[i2], z[25], 5) + call amovr (c[i2], z[30], 5) + call amovr (d[i2], z[35], 5) + call amovr (e[i2], z[40], 5) + call amovr (f[i2], z[45], 5) + + # Find the highest point excluding the center. + j1 = 37; j2 = 1 + do j = 2, 49 { + if (j == j1) + next + if (z[j] > z[j2]) + j2 = j + } + + # Compute the flux excluding the extreme points. + flux = (asumr (z, 49) - z[j1] - z[j2]) / 47 + + # Pixel must be exceed specified threshold. + if (p < flux + threshold) + next + + # Fit and subtract the background. + if (j2 < 25) { + w[j2] = 0 + sf = sf2 + call gsfit (sf, x, y, z, w, 24, WTS_USER, j) + w[j2] = 1 + } else { + sf = sf1 + call gsrefit (sf, x, y, z, w, j) + } + + call gsvector (sf, x, y, bkgd, 49) + call asubr (z, bkgd, z, 49) + p = z[j1] + + # Compute the flux excluding the extreme points. + flux = (asumr (z, 49) - z[j1] - z[j2]) / 47 + + # Determine replacement value from four nearest neighbors again + # excluding the most deviant pixels. + replace = 0 + j = 0 + if (j2 != 32) { + replace = replace + c[i4] + j = j + 1 + } + if (j2 != 36) { + replace = replace + d[i3] + j = j + 1 + } + if (j2 != 38) { + replace = replace + d[i5] + j = j + 1 + } + if (j2 != 42) { + replace = replace + e[i4] + j = j + 1 + } + replace = replace / j + + # Add pixel to cosmic ray list. + flux = 100. * flux + call cr_add (cr, col+i4-1, line, flux, flux/p, 0., replace, 0) + i4 = i7 + } +end + + +# CR_FIND5 -- Find cosmic rays candidates in 5x5 window. +# This routine finds cosmic rays candidates with the following algorithm. +# 1. If the pixel is not a local maximum relative to it's 24 neighbors +# go on to the next pixel. +# 2. Identify the next strongest pixel in the 5x5 region. +# This suspect pixel is excluded in the following. +# 2. Compute the flux of the 5x5 region excluding the cosmic ray +# candidate and the suspect pixel. +# 3. The candidate must exceed the average flux per pixel by a specified +# threshold. If not go on to the next pixel. +# 4. Fit a plane to the border pixels (excluding the suspect pixel). +# 5. Subtract the background defined by the plane. +# 6. Determine a replacement value as the average of the four adjacent +# pixels (excluding the suspect pixels). +# 7. Add the pixel to the cosmic ray candidate list. + +procedure cr_find5 (cr, threshold, col, line, a, b, c, d, e, n, + sf1, sf2, x, y, z, w) + +pointer cr # Cosmic ray list +real threshold # Detection threshold +int col # First column +int line # Line +real a[ARB], b[ARB], c[ARB], d[ARB], e[ARB] # Image lines +int n # Number of columns +pointer sf1, sf2 # Surface fitting +real x[25], y[25], z[25], w[25] # Surface arrays + +real bkgd[25] +int i1, i2, i3, i4, i5, j, j1, j2 +real p, flux, replace, asumr() +pointer sf + +begin + for (i3=3; i3<=n-2; i3=i3+1) { + # Must be local maxima. + p = c[i3] + if (p<a[i3]||p<b[i3]||p<d[i3]||p<e[i3]) + next + i1 = i3 - 2 + if (p<a[i1]||p<b[i1]||p<c[i1]||p<d[i1]||p<e[i1]) + next + i2 = i3 - 1 + if (p<a[i2]||p<b[i2]||p<c[i2]||p<d[i2]||p<e[i2]) + next + i4 = i3 + 1 + if (p<a[i4]||p<b[i4]||p<c[i4]||p<d[i4]||p<e[i4]) + next + i5 = i3 + 2 + if (p<a[i5]||p<b[i5]||p<c[i5]||p<d[i5]||p<e[i5]) + next + + # Convert to a single array in surface fitting order. + call amovr (a[i1], z[1], 5) + z[6] = b[i5]; z[7] = c[i5]; z[8] = d[i5]; z[9] = e[i5] + z[10] = e[i4]; z[11] = e[i3]; z[12] = e[i2]; z[13] = e[i1] + z[14] = d[i1]; z[15] = c[i1]; z[16] = b[i1] + call amovr (b[i2], z[17], 3) + call amovr (c[i2], z[20], 3) + call amovr (d[i2], z[23], 3) + + # Find the highest point excluding the center. + j1 = 21; j2 = 1 + do j = 2, 25 { + if (j == j1) + next + if (z[j] > z[j2]) + j2 = j + } + + # Compute the flux excluding the extreme points. + flux = (asumr (z, 25) - z[j1] - z[j2]) / 23 + + # Pixel must be exceed specified threshold. + if (p < flux + threshold) + next + + # Fit and subtract the background. + if (j2 < 17) { + w[j2] = 0 + sf = sf2 + call gsfit (sf, x, y, z, w, 16, WTS_USER, j) + w[j2] = 1 + } else { + sf = sf1 + call gsrefit (sf, x, y, z, w, j) + } + + call gsvector (sf, x, y, bkgd, 25) + call asubr (z, bkgd, z, 25) + p = z[j1] + + # Compute the flux excluding the extreme points. + flux = (asumr (z, 25) - z[j1] - z[j2]) / 23 + + # Determine replacement value from four nearest neighbors again + # excluding the most deviant pixels. + replace = 0 + j = 0 + if (j2 != 18) { + replace = replace + b[i3] + j = j + 1 + } + if (j2 != 20) { + replace = replace + c[i2] + j = j + 1 + } + if (j2 != 22) { + replace = replace + c[i4] + j = j + 1 + } + if (j2 != 24) { + replace = replace + d[i3] + j = j + 1 + } + replace = replace / j + + # Add pixel to cosmic ray list. + flux = 100. * flux + call cr_add (cr, col+i3-1, line, flux, flux/p, 0., replace, 0) + i3 = i5 + } +end diff --git a/noao/imred/ccdred/src/cosmic/crlist.h b/noao/imred/ccdred/src/cosmic/crlist.h new file mode 100644 index 00000000..1ed498a7 --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/crlist.h @@ -0,0 +1,17 @@ +define CR_ALLOC 100 # Allocation block size +define CR_LENSTRUCT 9 # Length of structure + +define CR_NCR Memi[$1] # Number of cosmic rays +define CR_NALLOC Memi[$1+1] # Length of cosmic ray list +define CR_COL Memi[$1+2] # Pointer to columns +define CR_LINE Memi[$1+3] # Pointer to lines +define CR_FLUX Memi[$1+4] # Pointer to fluxes +define CR_RATIO Memi[$1+5] # Pointer to flux ratios +define CR_WT Memi[$1+6] # Pointer to training weights +define CR_REPLACE Memi[$1+7] # Pointer to replacement values +define CR_FLAG Memi[$1+8] # Pointer to rejection flag + +define ALWAYSNO 3 +define ALWAYSYES 4 + +define CR_RMAX 3. # Maximum radius for matching diff --git a/noao/imred/ccdred/src/cosmic/crlist.x b/noao/imred/ccdred/src/cosmic/crlist.x new file mode 100644 index 00000000..e0a8fd5c --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/crlist.x @@ -0,0 +1,366 @@ +include <error.h> +include <syserr.h> +include <gset.h> +include "crlist.h" + +define HELP "noao$lib/scr/cosmicrays.key" +define PROMPT "cosmic ray options" + +# CR_OPEN -- Open cosmic ray list +# CR_CLOSE -- Close cosmic ray list +# CR_ADD -- Add a cosmic ray candidate to cosmic ray list. +# CR_TRAIN -- Set flux ratio threshold from a training set. +# CR_FINDTHRESH -- Find flux ratio. +# CR_WEIGHT -- Compute the training weight at a particular flux ratio. +# CR_FLAGS -- Set cosmic ray reject flags. +# CR_BADPIX -- Store cosmic rays in bad pixel list. +# CR_REPLACE -- Replace cosmic rays in image with replacement values. + +# CR_OPEN -- Open cosmic ray list + +procedure cr_open (cr) + +pointer cr # Cosmic ray list pointer +errchk malloc + +begin + call malloc (cr, CR_LENSTRUCT, TY_STRUCT) + call malloc (CR_COL(cr), CR_ALLOC, TY_REAL) + call malloc (CR_LINE(cr), CR_ALLOC, TY_REAL) + call malloc (CR_FLUX(cr), CR_ALLOC, TY_REAL) + call malloc (CR_RATIO(cr), CR_ALLOC, TY_REAL) + call malloc (CR_WT(cr), CR_ALLOC, TY_REAL) + call malloc (CR_REPLACE(cr), CR_ALLOC, TY_REAL) + call malloc (CR_FLAG(cr), CR_ALLOC, TY_INT) + CR_NCR(cr) = 0 + CR_NALLOC(cr) = CR_ALLOC +end + + +# CR_CLOSE -- Close cosmic ray list + +procedure cr_close (cr) + +pointer cr # Cosmic ray list pointer + +begin + call mfree (CR_COL(cr), TY_REAL) + call mfree (CR_LINE(cr), TY_REAL) + call mfree (CR_FLUX(cr), TY_REAL) + call mfree (CR_RATIO(cr), TY_REAL) + call mfree (CR_WT(cr), TY_REAL) + call mfree (CR_REPLACE(cr), TY_REAL) + call mfree (CR_FLAG(cr), TY_INT) + call mfree (cr, TY_STRUCT) +end + +# CR_ADD -- Add a cosmic ray candidate to cosmic ray list. + +procedure cr_add (cr, col, line, flux, ratio, wt, replace, flag) + +pointer cr # Cosmic ray list pointer +int col # Cofluxn +int line # Line +real flux # Luminosity +real ratio # Ratio +real wt # Weight +real replace # Sky value +int flag # Flag value + +int ncr +errchk realloc + +begin + if (CR_NCR(cr) == CR_NALLOC(cr)) { + CR_NALLOC(cr) = CR_NALLOC(cr) + CR_ALLOC + call realloc (CR_COL(cr), CR_NALLOC(cr), TY_REAL) + call realloc (CR_LINE(cr), CR_NALLOC(cr), TY_REAL) + call realloc (CR_FLUX(cr), CR_NALLOC(cr), TY_REAL) + call realloc (CR_RATIO(cr), CR_NALLOC(cr), TY_REAL) + call realloc (CR_WT(cr), CR_NALLOC(cr), TY_REAL) + call realloc (CR_REPLACE(cr), CR_NALLOC(cr), TY_REAL) + call realloc (CR_FLAG(cr), CR_NALLOC(cr), TY_INT) + } + + ncr = CR_NCR(cr) + CR_NCR(cr) = ncr + 1 + Memr[CR_COL(cr)+ncr] = col + Memr[CR_LINE(cr)+ncr] = line + Memr[CR_FLUX(cr)+ncr] = flux + Memr[CR_RATIO(cr)+ncr] = ratio + Memr[CR_WT(cr)+ncr] = wt + Memr[CR_REPLACE(cr)+ncr] = replace + Memi[CR_FLAG(cr)+ncr] = flag +end + + +# CR_TRAIN -- Set flux ratio threshold from a training set. + +procedure cr_train (cr, gp, gt, im, fluxratio, fname) + +pointer cr #I Cosmic ray list +pointer gp #I GIO pointer +pointer gt #I GTOOLS pointer +pointer im #I IMIO pointer +real fluxratio #O Flux ratio threshold +char fname[ARB] #I Save file name + +char cmd[10] +bool gflag +real x, y, y1, y2, w, r, rmin +int i, j, n, f, ncr, wcs, key, fd, clgcur(), open(), errcode() +pointer col, line, ratio, flux, wt, flag + +begin + # Open save file + iferr (fd = open (fname, APPEND, TEXT_FILE)) { + if (errcode() != SYS_FNOFNAME) + call erract (EA_WARN) + fd = 0 + } + + ncr = CR_NCR(cr) + col = CR_COL(cr) - 1 + line = CR_LINE(cr) - 1 + flux = CR_FLUX(cr) - 1 + ratio = CR_RATIO(cr) - 1 + wt = CR_WT(cr) - 1 + flag = CR_FLAG(cr) - 1 + + gflag = false + n = 0 + while (clgcur ("objects", x, y, wcs, key, cmd, 10) != EOF) { + switch (key) { + case '?': + call gpagefile (gp, HELP, PROMPT) + next + case 'q': + break + case 's': + w = 1 + f = ALWAYSNO + case 'c': + w = -1 + f = ALWAYSYES + case 'g': + if (gflag) + call cr_examine (cr, gp, gt, im, fluxratio, 'z') + else { + if (n > 1) + call cr_findthresh (cr, fluxratio) + call cr_flags (cr, fluxratio) + call cr_examine (cr, gp, gt, im, fluxratio, 'r') + gflag = true + } + next + default: + next + } + + y1 = y - CR_RMAX + y2 = y + CR_RMAX + for (i=10; i<ncr && y1>Memr[line+i]; i=i+10) + ; + j = i - 9 + rmin = (Memr[col+j] - x) ** 2 + (Memr[line+j] - y) ** 2 + for (i=j+1; i<ncr && y2>Memr[line+i]; i=i+1) { + r = (Memr[col+i] - x) ** 2 + (Memr[line+i] - y) ** 2 + if (r < rmin) { + rmin = r + j = i + } + } + if (sqrt (rmin) > CR_RMAX) + next + + Memr[wt+j] = w + Memi[flag+j] = f + n = n + 1 + + if (gflag) { + if (n > 1) { + call cr_findthresh (cr, r) + call cr_update (gp, r, cr, fluxratio, 0) + } + call gmark (gp, Memr[flux+j], Memr[ratio+j], GM_BOX, 2., 2.) + } + if (fd > 0) { + call fprintf (fd, "%g %g %d %c\n") + call pargr (x) + call pargr (y) + call pargi (wcs) + call pargi (key) + } + } + + if (fd > 0) + call close (fd) +end + + +# CR_FINDTHRESH -- Find flux ratio. + +procedure cr_findthresh (cr, fluxratio) + +pointer cr #I Cosmic ray list +real fluxratio #O Flux ratio threshold + +real w, r, rmin, cr_weight() +int i, ncr +pointer ratio, wt + +begin + ncr = CR_NCR(cr) + ratio = CR_RATIO(cr) - 1 + wt = CR_WT(cr) - 1 + + fluxratio = Memr[ratio+1] + rmin = cr_weight (fluxratio, Memr[ratio+1], Memr[wt+1], ncr) + do i = 2, ncr { + if (Memr[wt+i] == 0.) + next + r = Memr[ratio+i] + w = cr_weight (r, Memr[ratio+1], Memr[wt+1], ncr) + if (w <= rmin) { + if (w == rmin) + fluxratio = min (fluxratio, r) + else { + rmin = w + fluxratio = r + } + } + } +end + + +# CR_WEIGHT -- Compute the training weight at a particular flux ratio. + +real procedure cr_weight (fluxratio, ratio, wts, ncr) + +real fluxratio #I Flux ratio +real ratio[ARB] #I Ratio Values +real wts[ARB] #I Weights +int ncr #I Number of ratio values +real wt #O Sum of weights + +int i + +begin + wt = 0. + do i = 1, ncr { + if (ratio[i] > fluxratio) { + if (wts[i] < 0.) + wt = wt - wts[i] + } else { + if (wts[i] > 0.) + wt = wt + wts[i] + } + } + return (wt) +end + + +# CR_FLAGS -- Set cosmic ray reject flags. + +procedure cr_flags (cr, fluxratio) + +pointer cr # Cosmic ray candidate list +real fluxratio # Rejection limits + +int i, ncr +pointer ratio, flag + +begin + ncr = CR_NCR(cr) + ratio = CR_RATIO(cr) - 1 + flag = CR_FLAG(cr) - 1 + + do i = 1, ncr { + if ((Memi[flag+i] == ALWAYSYES) || (Memi[flag+i] == ALWAYSNO)) + next + if (Memr[ratio+i] > fluxratio) + Memi[flag+i] = NO + else + Memi[flag+i] = YES + } +end + + +# CR_BADPIX -- Store cosmic rays in bad pixel list. +# This is currently a temporary measure until a real bad pixel list is +# implemented. + +procedure cr_badpix (cr, fname) + +pointer cr # Cosmic ray list +char fname[ARB] # Bad pixel file name + +int i, ncr, c, l, f, fd, open(), errcode() +pointer col, line, ratio, flux, flag +errchk open + +begin + # Open bad pixel file + iferr (fd = open (fname, APPEND, TEXT_FILE)) { + if (errcode() != SYS_FNOFNAME) + call erract (EA_WARN) + return + } + + ncr = CR_NCR(cr) + col = CR_COL(cr) - 1 + line = CR_LINE(cr) - 1 + flux = CR_FLUX(cr) - 1 + ratio = CR_RATIO(cr) - 1 + flag = CR_FLAG(cr) - 1 + + do i = 1, ncr { + f = Memi[flag+i] + if ((f == NO) || (f == ALWAYSNO)) + next + + c = Memr[col+i] + l = Memr[line+i] + call fprintf (fd, "%d %d\n") + call pargi (c) + call pargi (l) + } + call close (fd) +end + + +# CR_REPLACE -- Replace cosmic rays in image with replacement values. + +procedure cr_replace (cr, offset, im, nreplaced) + +pointer cr # Cosmic ray list +int offset # Offset in list +pointer im # IMIO pointer of output image +int nreplaced # Number replaced (for log) + +int i, ncr, c, l, f +real r +pointer col, line, replace, flag, imps2r() + +begin + ncr = CR_NCR(cr) + if (ncr <= offset) + return + + col = CR_COL(cr) - 1 + line = CR_LINE(cr) - 1 + replace = CR_REPLACE(cr) - 1 + flag = CR_FLAG(cr) - 1 + + do i = offset+1, ncr { + f = Memi[flag+i] + if ((f == NO) || (f == ALWAYSNO)) + next + + c = Memr[col+i] + l = Memr[line+i] + r = Memr[replace+i] + Memr[imps2r (im, c, c, l, l)] = r + nreplaced = nreplaced + 1 + } +end diff --git a/noao/imred/ccdred/src/cosmic/crsurface.x b/noao/imred/ccdred/src/cosmic/crsurface.x new file mode 100644 index 00000000..32645ff4 --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/crsurface.x @@ -0,0 +1,46 @@ +define DUMMY 6 + +# CR_SURFACE -- Draw a perspective view of a surface. The altitude +# and azimuth of the viewing angle are variable. + +procedure cr_surface(gp, data, ncols, nlines, angh, angv) + +pointer gp # GIO pointer +real data[ncols,nlines] # Surface data to be plotted +int ncols, nlines # Dimensions of surface +real angh, angv # Orientation of surface (degrees) + +int wkid +pointer sp, work + +int first +real vpx1, vpx2, vpy1, vpy2 +common /frstfg/ first +common /noaovp/ vpx1, vpx2, vpy1, vpy2 + +begin + call smark (sp) + call salloc (work, 2 * (2 * ncols * nlines + ncols + nlines), TY_REAL) + + # Initialize surface common blocks + first = 1 + call srfabd() + + # Define viewport. + call ggview (gp, vpx1, vpx2, vpy1, vpy2) + + # Link GKS to GIO + wkid = 1 + call gopks (STDERR) + call gopwk (wkid, DUMMY, gp) + call gacwk (wkid) + + call ezsrfc (data, ncols, nlines, angh, angv, Memr[work]) + + call gdawk (wkid) + # We don't want to close the GIO pointer. + #call gclwk (wkid) + call gclks () + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/cosmic/mkpkg b/noao/imred/ccdred/src/cosmic/mkpkg new file mode 100644 index 00000000..d63d9c2c --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/mkpkg @@ -0,0 +1,16 @@ +# COSMIC RAY CLEANING + +$checkout libpkg.a ../.. +$update libpkg.a +$checkin libpkg.a ../.. +$exit + +libpkg.a: + crexamine.x crlist.h <error.h> <gset.h> <mach.h> <pkg/gtools.h>\ + <imhdr.h> <syserr.h> + crfind.x <math/gsurfit.h> + crlist.x crlist.h <error.h> <gset.h> <syserr.h> + crsurface.x + t_cosmicrays.x crlist.h <error.h> <gset.h> <math/gsurfit.h>\ + <pkg/gtools.h> <imhdr.h> <imset.h> + ; diff --git a/noao/imred/ccdred/src/cosmic/t_cosmicrays.x b/noao/imred/ccdred/src/cosmic/t_cosmicrays.x new file mode 100644 index 00000000..8640b639 --- /dev/null +++ b/noao/imred/ccdred/src/cosmic/t_cosmicrays.x @@ -0,0 +1,348 @@ +include <error.h> +include <imhdr.h> +include <imset.h> +include <math/gsurfit.h> +include <gset.h> +include <pkg/gtools.h> +include "crlist.h" + +# T_COSMICRAYS -- Detect and remove cosmic rays in images. +# A list of images is examined for cosmic rays which are then replaced +# by values from neighboring pixels. The output image may be the same +# as the input image. This is the top level procedure which manages +# the input and output image data. The actual algorithm for detecting +# cosmic rays is in CR_FIND. + +procedure t_cosmicrays () + +int list1 # List of input images to be cleaned +int list2 # List of output images +int list3 # List of output bad pixel files +real threshold # Detection threshold +real fluxratio # Luminosity boundary for stars +int npasses # Number of cleaning passes +int szwin # Size of detection window +bool train # Use training objects? +pointer savefile # Save file for training objects +bool interactive # Examine cosmic ray parameters? +char ans # Answer to interactive query + +int nc, nl, c, c1, c2, l, l1, l2, szhwin, szwin2 +int i, j, k, m, ncr, ncrlast, nreplaced, flag +pointer sp, input, output, badpix, str, gp, gt, im, in, out +pointer x, y, z, w, sf1, sf2, cr, data, ptr + +bool clgetb(), ccdflag(), streq(), strne() +char clgetc() +int imtopenp(), imtlen(), imtgetim(), clpopnu(), clgfil(), clgeti() +real clgetr() +pointer immap(), impl2r(), imgs2r(), gopen(), gt_init() +errchk immap, impl2r, imgs2r +errchk cr_find, cr_examine, cr_replace, cr_plot, cr_badpix + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (badpix, SZ_FNAME, TY_CHAR) + call salloc (savefile, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the task parameters. Check that the number of output images + # is either zero, in which case the cosmic rays will be removed + # in place, or equal to the number of input images. + + list1 = imtopenp ("input") + list2 = imtopenp ("output") + i = imtlen (list1) + j = imtlen (list2) + if (j > 0 && j != i) + call error (0, "Input and output image lists do not match") + + list3 = clpopnu ("badpix") + threshold = clgetr ("threshold") + fluxratio = clgetr ("fluxratio") + npasses = clgeti ("npasses") + szwin = clgeti ("window") + train = clgetb ("train") + call clgstr ("savefile", Memc[savefile], SZ_FNAME) + interactive = clgetb ("interactive") + call clpstr ("answer", "yes") + ans = 'y' + + # Set up the graphics. + call clgstr ("graphics", Memc[str], SZ_LINE) + if (interactive) { + gp = gopen (Memc[str], NEW_FILE+AW_DEFER, STDGRAPH) + gt = gt_init() + call gt_sets (gt, GTTYPE, "mark") + call gt_sets (gt, GTXTRAN, "log") + call gt_setr (gt, GTXMIN, 10.) + call gt_setr (gt, GTYMIN, 0.) + call gt_sets (gt, GTTITLE, "Parameters of cosmic rays candidates") + call gt_sets (gt, GTXLABEL, "Flux") + call gt_sets (gt, GTYLABEL, "Flux Ratio") + } + + # Use image header translation file. + call clgstr ("instrument", Memc[input], SZ_FNAME) + call hdmopen (Memc[input]) + + # Set up surface fitting. The background points are placed together + # at the beginning of the arrays. There are two surface pointers, + # one for using the fast refit if there are no points excluded and + # one for doing a full fit with points excluded. + + szhwin = szwin / 2 + szwin2 = szwin * szwin + call salloc (data, szwin, TY_INT) + call salloc (x, szwin2, TY_REAL) + call salloc (y, szwin2, TY_REAL) + call salloc (z, szwin2, TY_REAL) + call salloc (w, szwin2, TY_REAL) + + k = 0 + do i = 1, szwin { + Memr[x+k] = i + Memr[y+k] = 1 + k = k + 1 + } + do i = 2, szwin { + Memr[x+k] = szwin + Memr[y+k] = i + k = k + 1 + } + do i = szwin-1, 1, -1 { + Memr[x+k] = i + Memr[y+k] = szwin + k = k + 1 + } + do i = szwin-1, 2, -1 { + Memr[x+k] = 1 + Memr[y+k] = i + k = k + 1 + } + do i = 2, szwin-1 { + do j = 2, szwin-1 { + Memr[x+k] = j + Memr[y+k] = i + k = k + 1 + } + } + call aclrr (Memr[z], szwin2) + call amovkr (1., Memr[w], 4*szwin-4) + call gsinit (sf1, GS_POLYNOMIAL, 2, 2, NO, 1., real(szwin), + 1., real(szwin)) + call gsinit (sf2, GS_POLYNOMIAL, 2, 2, NO, 1., real(szwin), + 1., real(szwin)) + call gsfit (sf1, Memr[x], Memr[y], Memr[z], Memr[w], 4*szwin-4, + WTS_USER, j) + + # Process each input image. Either work in place or create a + # new output image. If an error mapping the images occurs + # issue a warning and go on to the next input image. + + while (imtgetim (list1, Memc[input], SZ_FNAME) != EOF) { + if (imtgetim (list2, Memc[output], SZ_FNAME) == EOF) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (clgfil (list3, Memc[badpix], SZ_FNAME) == EOF) + Memc[badpix] = EOS + + iferr { + in = NULL + out = NULL + cr = NULL + + # Map the input image and check for image type and + # previous correction flag. If the output image is + # the same as the input image work in place. + # Initialize IMIO to use a scrolling buffer of lines. + + call set_input (Memc[input], im, i) + if (im == NULL) + call error (1, "Skipping input image") + + if (ccdflag (im, "crcor")) { + call eprintf ("WARNING: %s previously corrected\n") + call pargstr (Memc[input]) + #call imunmap (im) + #next + } + + if (streq (Memc[input], Memc[output])) { + call imunmap (im) + im = immap (Memc[input], READ_WRITE, 0) + } + in = im + + nc = IM_LEN(in,1) + nl = IM_LEN(in,2) + if ((nl < szwin) || (nc < szwin)) + call error (0, "Image size is too small") + call imseti (in, IM_NBUFS, szwin) + call imseti (in, IM_TYBNDRY, BT_NEAREST) + call imseti (in, IM_NBNDRYPIX, szhwin) + + # Open the output image if needed. + if (strne (Memc[input], Memc[output])) + im = immap (Memc[output], NEW_COPY, in) + out = im + + # Open a cosmic ray list structure. + call cr_open (cr) + ncrlast = 0 + nreplaced = 0 + + # Now proceed through the image line by line, scrolling + # the line buffers at each step. If creating a new image + # also write out each line as it is read. A procedure is + # called to find the cosmic ray candidates in the line + # and add them to the list maintained by CRLIST. + # Note that cosmic rays are not replaced at this point + # in order to allow the user to modify the criteria for + # a cosmic ray and review the results. + + c1 = 1-szhwin + c2 = nc+szhwin + do i = 1, szwin-1 + Memi[data+i] = + imgs2r (in, c1, c2, i-szhwin, i-szhwin) + + do l = 1, nl { + do i = 1, szwin-1 + Memi[data+i-1] = Memi[data+i] + Memi[data+szwin-1] = + imgs2r (in, c1, c2, l+szhwin, l+szhwin) + if (out != in) + call amovr (Memr[Memi[data+szhwin]+szhwin], + Memr[impl2r(out,l)], nc) + + call cr_find (cr, threshold, Memi[data], + c2-c1+1, szwin, c1, l, + sf1, sf2, Memr[x], Memr[y], Memr[z], Memr[w]) + } + if (interactive && train) { + call cr_train (cr, gp, gt, in, fluxratio, Memc[savefile]) + train = false + } + call cr_flags (cr, fluxratio) + + # If desired examine the cosmic ray list interactively. + if (interactive && ans != 'N') { + if (ans != 'Y') { + call eprintf ("%s - ") + call pargstr (Memc[input]) + call flush (STDERR) + ans = clgetc ("answer") + } + if ((ans == 'Y') || (ans == 'y')) + call cr_examine (cr, gp, gt, in, fluxratio, 'r') + } + + # Now replace the selected cosmic rays in the output image. + + call imflush (out) + call imseti (out, IM_ADVICE, RANDOM) + call cr_replace (cr, ncrlast, out, nreplaced) + + # Do additional passes through the data. We work in place + # in the output image. Note that we only have to look in + # the vicinity of replaced cosmic rays for secondary + # events since we've already looked at every pixel once. + # Instead of scrolling through the image we will extract + # subrasters around each replaced cosmic ray. However, + # we use pointers into the subraster to maintain the same + # format expected by CR_FIND. + + if (npasses > 1) { + if (out != in) + call imunmap (out) + call imunmap (in) + im = immap (Memc[output], READ_WRITE, 0) + in = im + out = im + call imseti (in, IM_TYBNDRY, BT_NEAREST) + call imseti (in, IM_NBNDRYPIX, szhwin) + + for (i=2; i<=npasses; i=i+1) { + # Loop through each cosmic ray in the previous pass. + ncr = CR_NCR(cr) + do j = ncrlast+1, ncr { + flag = Memi[CR_FLAG(cr)+j-1] + if (flag==NO || flag==ALWAYSNO) + next + c = Memr[CR_COL(cr)+j-1] + l = Memr[CR_LINE(cr)+j-1] + c1 = max (1-szhwin, c - (szwin-1)) + c2 = min (nc+szhwin, c + (szwin-1)) + k = c2 - c1 + 1 + l1 = max (1-szhwin, l - (szwin-1)) + l2 = min (nl+szhwin, l + (szwin-1)) + + # Set the line pointers off an image section + # centered on a previously replaced cosmic ray. + + ptr = imgs2r (in, c1, c2, l1, l2) - k + + l1 = max (1, l - szhwin) + l2 = min (nl, l + szhwin) + do l = l1, l2 { + do m = 1, szwin + Memi[data+m-1] = ptr + m * k + ptr = ptr + k + + call cr_find ( cr, threshold, Memi[data], + k, szwin, c1, l, sf1, sf2, + Memr[x], Memr[y], Memr[z], Memr[w]) + } + } + call cr_flags (cr, fluxratio) + + # Replace any new cosmic rays found. + call cr_replace (cr, ncr, in, nreplaced) + ncrlast = ncr + } + } + + # Output header log, log, plot, and bad pixels. + call sprintf (Memc[str], SZ_LINE, + "Threshold=%5.1f, fluxratio=%6.2f, removed=%d") + call pargr (threshold) + call pargr (fluxratio) + call pargi (nreplaced) + call timelog (Memc[str], SZ_LINE) + call ccdlog (out, Memc[str]) + call hdmpstr (out, "crcor", Memc[str]) + + call cr_plot (cr, in, fluxratio) + call cr_badpix (cr, Memc[badpix]) + + call cr_close (cr) + if (out != in) + call imunmap (out) + call imunmap (in) + } then { + # In case of error clean up and go on to the next image. + if (in != NULL) { + if (out != NULL && out != in) + call imunmap (out) + call imunmap (in) + } + if (cr != NULL) + call cr_close (cr) + call erract (EA_WARN) + } + } + + if (interactive) { + call gt_free (gt) + call gclose (gp) + } + call imtclose (list1) + call imtclose (list2) + call clpcls (list3) + call hdmclose () + call gsfree (sf1) + call gsfree (sf2) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/doproc.x b/noao/imred/ccdred/src/doproc.x new file mode 100644 index 00000000..909c6f12 --- /dev/null +++ b/noao/imred/ccdred/src/doproc.x @@ -0,0 +1,29 @@ +include "ccdred.h" + +# DOPROC -- Call the appropriate processing procedure. +# +# There are four data type paths depending on the readout axis and +# the calculation data type. + +procedure doproc (ccd) + +pointer ccd # CCD processing structure + +begin + switch (READAXIS (ccd)) { + case 1: + switch (CALCTYPE (ccd)) { + case TY_SHORT: + call proc1s (ccd) + default: + call proc1r (ccd) + } + case 2: + switch (CALCTYPE (ccd)) { + case TY_SHORT: + call proc2s (ccd) + default: + call proc2r (ccd) + } + } +end diff --git a/noao/imred/ccdred/src/generic/ccdred.h b/noao/imred/ccdred/src/generic/ccdred.h new file mode 100644 index 00000000..2d370d86 --- /dev/null +++ b/noao/imred/ccdred/src/generic/ccdred.h @@ -0,0 +1,150 @@ +# CCDRED Data Structures and Definitions + +# The CCD structure: This structure is used to communicate processing +# parameters between the package procedures. It contains pointers to +# data, calibration image IMIO pointers, scaling parameters, and the +# correction flags. The corrections flags indicate which processing +# operations are to be performed. The subsection parameters do not +# include a step size. A step size is assumed. If arbitrary subsampling +# is desired this would be the next generalization. + +define LEN_CCD 131 # Length of CCD structure + +# CCD data coordinates +define CCD_C1 Memi[$1] # CCD starting column +define CCD_C2 Memi[$1+1] # CCD ending column +define CCD_L1 Memi[$1+2] # CCD starting line +define CCD_L2 Memi[$1+3] # CCD ending line + +# Input data +define IN_IM Memi[$1+10] # Input image pointer +define IN_C1 Memi[$1+11] # Input data starting column +define IN_C2 Memi[$1+12] # Input data ending column +define IN_L1 Memi[$1+13] # Input data starting line +define IN_L2 Memi[$1+14] # Input data ending line + +# Output data +define OUT_IM Memi[$1+20] # Output image pointer +define OUT_C1 Memi[$1+21] # Output data starting column +define OUT_C2 Memi[$1+22] # Output data ending column +define OUT_L1 Memi[$1+23] # Output data starting line +define OUT_L2 Memi[$1+24] # Output data ending line + +# Mask data +define MASK_IM Memi[$1+30] # Mask image pointer +define MASK_C1 Memi[$1+31] # Mask data starting column +define MASK_C2 Memi[$1+32] # Mask data ending column +define MASK_L1 Memi[$1+33] # Mask data starting line +define MASK_L2 Memi[$1+34] # Mask data ending line +define MASK_PM Memi[$1+35] # Mask pointer +define MASK_FP Memi[$1+36] # Mask fixpix data + +# Zero level data +define ZERO_IM Memi[$1+40] # Zero level image pointer +define ZERO_C1 Memi[$1+41] # Zero level data starting column +define ZERO_C2 Memi[$1+42] # Zero level data ending column +define ZERO_L1 Memi[$1+43] # Zero level data starting line +define ZERO_L2 Memi[$1+44] # Zero level data ending line + +# Dark count data +define DARK_IM Memi[$1+50] # Dark count image pointer +define DARK_C1 Memi[$1+51] # Dark count data starting column +define DARK_C2 Memi[$1+52] # Dark count data ending column +define DARK_L1 Memi[$1+53] # Dark count data starting line +define DARK_L2 Memi[$1+54] # Dark count data ending line + +# Flat field data +define FLAT_IM Memi[$1+60] # Flat field image pointer +define FLAT_C1 Memi[$1+61] # Flat field data starting column +define FLAT_C2 Memi[$1+62] # Flat field data ending column +define FLAT_L1 Memi[$1+63] # Flat field data starting line +define FLAT_L2 Memi[$1+64] # Flat field data ending line + +# Illumination data +define ILLUM_IM Memi[$1+70] # Illumination image pointer +define ILLUM_C1 Memi[$1+71] # Illumination data starting column +define ILLUM_C2 Memi[$1+72] # Illumination data ending column +define ILLUM_L1 Memi[$1+73] # Illumination data starting line +define ILLUM_L2 Memi[$1+74] # Illumination data ending line + +# Fringe data +define FRINGE_IM Memi[$1+80] # Fringe image pointer +define FRINGE_C1 Memi[$1+81] # Fringe data starting column +define FRINGE_C2 Memi[$1+82] # Fringe data ending column +define FRINGE_L1 Memi[$1+83] # Fringe data starting line +define FRINGE_L2 Memi[$1+84] # Fringe data ending line + +# Trim section +define TRIM_C1 Memi[$1+90] # Trim starting column +define TRIM_C2 Memi[$1+91] # Trim ending column +define TRIM_L1 Memi[$1+92] # Trim starting line +define TRIM_L2 Memi[$1+93] # Trim ending line + +# Bias section +define BIAS_C1 Memi[$1+100] # Bias starting column +define BIAS_C2 Memi[$1+101] # Bias ending column +define BIAS_L1 Memi[$1+102] # Bias starting line +define BIAS_L2 Memi[$1+103] # Bias ending line + +define READAXIS Memi[$1+110] # Read out axis (1=cols, 2=lines) +define CALCTYPE Memi[$1+111] # Calculation data type +define OVERSCAN_TYPE Memi[$1+112] # Overscan type +define OVERSCAN_VEC Memi[$1+113] # Pointer to overscan vector +define DARKSCALE Memr[P2R($1+114)] # Dark count scale factor +define FRINGESCALE Memr[P2R($1+115)] # Fringe scale factor +define FLATSCALE Memr[P2R($1+116)] # Flat field scale factor +define ILLUMSCALE Memr[P2R($1+117)] # Illumination scale factor +define MINREPLACE Memr[P2R($1+118)] # Minimum replacement value +define MEAN Memr[P2R($1+119)] # Mean of output image +define COR Memi[$1+120] # Overall correction flag +define CORS Memi[$1+121+($2-1)] # Individual correction flags + +# The correction array contains the following elements with array indices +# given by the macro definitions. + +define NCORS 10 # Number of corrections + +define FIXPIX 1 # Fix bad pixels +define TRIM 2 # Trim image +define OVERSCAN 3 # Apply overscan correction +define ZEROCOR 4 # Apply zero level correction +define DARKCOR 5 # Apply dark count correction +define FLATCOR 6 # Apply flat field correction +define ILLUMCOR 7 # Apply illumination correction +define FRINGECOR 8 # Apply fringe correction +define FINDMEAN 9 # Find the mean of the output image +define MINREP 10 # Check and replace minimum value + +# The following definitions identify the correction values in the correction +# array. They are defined in terms of bit fields so that it is possible to +# add corrections to form unique combination corrections. Some of +# these combinations are implemented as compound operations for efficiency. + +define O 001B # overscan +define Z 002B # zero level +define D 004B # dark count +define F 010B # flat field +define I 020B # Illumination +define Q 040B # Fringe + +# The following correction combinations are recognized. + +define ZO 003B # zero level + overscan +define DO 005B # dark count + overscan +define DZ 006B # dark count + zero level +define DZO 007B # dark count + zero level + overscan +define FO 011B # flat field + overscan +define FZ 012B # flat field + zero level +define FZO 013B # flat field + zero level + overscan +define FD 014B # flat field + dark count +define FDO 015B # flat field + dark count + overscan +define FDZ 016B # flat field + dark count + zero level +define FDZO 017B # flat field + dark count + zero level + overscan +define QI 060B # fringe + illumination + +# The following overscan functions are recognized. +define OVERSCAN_TYPES "|mean|median|minmax|chebyshev|legendre|spline3|spline1|" +define OVERSCAN_MEAN 1 # Mean of overscan +define OVERSCAN_MEDIAN 2 # Median of overscan +define OVERSCAN_MINMAX 3 # Minmax of overscan +define OVERSCAN_FIT 4 # Following codes are function fits diff --git a/noao/imred/ccdred/src/generic/cor.x b/noao/imred/ccdred/src/generic/cor.x new file mode 100644 index 00000000..fd2a8d6b --- /dev/null +++ b/noao/imred/ccdred/src/generic/cor.x @@ -0,0 +1,694 @@ +include "ccdred.h" + + +.help cor Feb87 noao.imred.ccdred +.nf ---------------------------------------------------------------------------- +cor -- Process CCD image lines + +These procedures are the heart of the CCD processing. They do the desired +set of processing operations on the image line data as efficiently as +possible. They are called by the PROC procedures. There are four procedures +one for each readout axis and one for short and real image data. +Some sets of operations are coded as single compound operations for efficiency. +To keep the number of combinations managable only the most common +combinations are coded as compound operations. The combinations +consist of any set of line overscan, column overscan, zero level, dark +count, and flat field and any set of illumination and fringe +correction. The corrections are applied in place to the output vector. + +The column readout procedure is more complicated in order to handle +zero level and flat field corrections specified as one dimensional +readout corrections instead of two dimensional calibration images. +Column readout format is probably extremely rare and the 1D readout +corrections are used only for special types of data. +.ih +SEE ALSO +proc, ccdred.h +.endhelp ----------------------------------------------------------------------- + + +# COR1 -- Correct image lines with readout axis 1 (lines). + +procedure cor1s (cors, out, overscan, zero, dark, flat, illum, + fringe, n, darkscale, flatscale, illumscale, frgscale) + +int cors[ARB] # Correction flags +short out[n] # Output data +real overscan # Overscan value +short zero[n] # Zero level correction +short dark[n] # Dark count correction +short flat[n] # Flat field correction +short illum[n] # Illumination correction +short fringe[n] # Fringe correction +int n # Number of pixels +real darkscale # Dark count scale factor +real flatscale # Flat field scale factor +real illumscale # Illumination scale factor +real frgscale # Fringe scale factor + +int i, op + +begin + op = cors[OVERSCAN] + cors[ZEROCOR] + cors[DARKCOR] + cors[FLATCOR] + switch (op) { + case O: # overscan + do i = 1, n + out[i] = out[i] - overscan + case Z: # zero level + do i = 1, n + out[i] = out[i] - zero[i] + + case ZO: # zero level + overscan + do i = 1, n + out[i] = out[i] - overscan - zero[i] + + case D: # dark count + do i = 1, n + out[i] = out[i] - darkscale * dark[i] + case DO: # dark count + overscan + do i = 1, n + out[i] = out[i] - overscan - darkscale * dark[i] + case DZ: # dark count + zero level + do i = 1, n + out[i] = out[i] - zero[i] - darkscale * dark[i] + case DZO: # dark count + zero level + overscan + do i = 1, n + out[i] = out[i] - overscan - zero[i] - darkscale * dark[i] + + case F: # flat field + do i = 1, n + out[i] = out[i] * flatscale / flat[i] + case FO: # flat field + overscan + do i = 1, n + out[i] = (out[i] - overscan) * flatscale / flat[i] + case FZ: # flat field + zero level + do i = 1, n + out[i] = (out[i] - zero[i]) * flatscale / flat[i] + case FZO: # flat field + zero level + overscan + do i = 1, n + out[i] = (out[i] - overscan - zero[i]) * flatscale / + flat[i] + case FD: # flat field + dark count + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatscale / flat[i] + case FDO: # flat field + dark count + overscan + do i = 1, n + out[i] = (out[i] - overscan - darkscale * dark[i]) * + flatscale / flat[i] + case FDZ: # flat field + dark count + zero level + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatscale / flat[i] + case FDZO: # flat field + dark count + zero level + overscan + do i = 1, n + out[i] = (out[i] - overscan - zero[i] - + darkscale * dark[i]) * flatscale / flat[i] + } + + # Often these operations will not be performed so test for no + # correction rather than go through the switch. + + op = cors[ILLUMCOR] + cors[FRINGECOR] + if (op != 0) { + switch (op) { + case I: # illumination + do i = 1, n + out[i] = out[i] * illumscale / illum[i] + case Q: # fringe + do i = 1, n + out[i] = out[i] - frgscale * fringe[i] + case QI: # fringe + illumination + do i = 1, n + out[i] = out[i]*illumscale/illum[i] - frgscale*fringe[i] + } + } +end + + +# COR2 -- Correct lines for readout axis 2 (columns). This procedure is +# more complex than when the readout is along the image lines because the +# zero level and/or flat field corrections may be single readout column +# vectors. + +procedure cor2s (line, cors, out, overscan, zero, dark, flat, illum, + fringe, n, zeroim, flatim, darkscale, flatscale, illumscale, frgscale) + +int line # Line to be corrected +int cors[ARB] # Correction flags +short out[n] # Output data +real overscan[n] # Overscan value +short zero[n] # Zero level correction +short dark[n] # Dark count correction +short flat[n] # Flat field correction +short illum[n] # Illumination correction +short fringe[n] # Fringe correction +int n # Number of pixels +pointer zeroim # Zero level IMIO pointer (NULL if 1D vector) +pointer flatim # Flat field IMIO pointer (NULL if 1D vector) +real darkscale # Dark count scale factor +real flatscale # Flat field scale factor +real illumscale # Illumination scale factor +real frgscale # Fringe scale factor + +short zeroval +real flatval +int i, op + +begin + op = cors[OVERSCAN] + cors[ZEROCOR] + cors[DARKCOR] + cors[FLATCOR] + switch (op) { + case O: # overscan + do i = 1, n + out[i] = out[i] - overscan[i] + case Z: # zero level + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - zero[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - zeroval + } + + case ZO: # zero level + overscan + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - overscan[i] - zero[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - overscan[i] - zeroval + } + + case D: # dark count + do i = 1, n + out[i] = out[i] - darkscale * dark[i] + case DO: # dark count + overscan + do i = 1, n + out[i] = out[i] - overscan[i] - darkscale * dark[i] + case DZ: # dark count + zero level + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - zero[i] - darkscale * dark[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - zeroval - darkscale * dark[i] + } + case DZO: # dark count + zero level + overscan + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - overscan[i] - zero[i] - + darkscale * dark[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - overscan[i] - zeroval - + darkscale * dark[i] + } + + case F: # flat field + if (flatim != NULL) { + do i = 1, n + out[i] = out[i] * flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = out[i] * flatval + } + case FO: # flat field + overscan + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i]) * flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - overscan[i]) * flatval + } + case FZ: # flat field + zero level + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i]) * flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval) * flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval) * flatval + } + } + case FZO: # flat field + zero level + overscan + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i]) * + flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval) * + flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval) * flatval + } + } + case FD: # flat field + dark count + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatscale/flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatval + } + case FDO: # flat field + dark count + overscan + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - darkscale * dark[i]) * + flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - darkscale * dark[i]) * + flatval + } + case FDZ: # flat field + dark count + zero level + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval - darkscale * dark[i]) * + flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval - darkscale * dark[i]) * + flatval + } + } + case FDZO: # flat field + dark count + zero level + overscan + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i] - + darkscale * dark[i]) * flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval - + darkscale * dark[i]) * flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i] - + darkscale * dark[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval - + darkscale * dark[i]) * flatval + } + } + } + + # Often these operations will not be performed so test for no + # correction rather than go through the switch. + + op = cors[ILLUMCOR] + cors[FRINGECOR] + if (op != 0) { + switch (op) { + case I: # illumination + do i = 1, n + out[i] = out[i] * illumscale / illum[i] + case Q: # fringe + do i = 1, n + out[i] = out[i] - frgscale * fringe[i] + case QI: # fringe + illumination + do i = 1, n + out[i] = out[i]*illumscale/illum[i] - frgscale*fringe[i] + } + } +end + +# COR1 -- Correct image lines with readout axis 1 (lines). + +procedure cor1r (cors, out, overscan, zero, dark, flat, illum, + fringe, n, darkscale, flatscale, illumscale, frgscale) + +int cors[ARB] # Correction flags +real out[n] # Output data +real overscan # Overscan value +real zero[n] # Zero level correction +real dark[n] # Dark count correction +real flat[n] # Flat field correction +real illum[n] # Illumination correction +real fringe[n] # Fringe correction +int n # Number of pixels +real darkscale # Dark count scale factor +real flatscale # Flat field scale factor +real illumscale # Illumination scale factor +real frgscale # Fringe scale factor + +int i, op + +begin + op = cors[OVERSCAN] + cors[ZEROCOR] + cors[DARKCOR] + cors[FLATCOR] + switch (op) { + case O: # overscan + do i = 1, n + out[i] = out[i] - overscan + case Z: # zero level + do i = 1, n + out[i] = out[i] - zero[i] + + case ZO: # zero level + overscan + do i = 1, n + out[i] = out[i] - overscan - zero[i] + + case D: # dark count + do i = 1, n + out[i] = out[i] - darkscale * dark[i] + case DO: # dark count + overscan + do i = 1, n + out[i] = out[i] - overscan - darkscale * dark[i] + case DZ: # dark count + zero level + do i = 1, n + out[i] = out[i] - zero[i] - darkscale * dark[i] + case DZO: # dark count + zero level + overscan + do i = 1, n + out[i] = out[i] - overscan - zero[i] - darkscale * dark[i] + + case F: # flat field + do i = 1, n + out[i] = out[i] * flatscale / flat[i] + case FO: # flat field + overscan + do i = 1, n + out[i] = (out[i] - overscan) * flatscale / flat[i] + case FZ: # flat field + zero level + do i = 1, n + out[i] = (out[i] - zero[i]) * flatscale / flat[i] + case FZO: # flat field + zero level + overscan + do i = 1, n + out[i] = (out[i] - overscan - zero[i]) * flatscale / + flat[i] + case FD: # flat field + dark count + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatscale / flat[i] + case FDO: # flat field + dark count + overscan + do i = 1, n + out[i] = (out[i] - overscan - darkscale * dark[i]) * + flatscale / flat[i] + case FDZ: # flat field + dark count + zero level + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatscale / flat[i] + case FDZO: # flat field + dark count + zero level + overscan + do i = 1, n + out[i] = (out[i] - overscan - zero[i] - + darkscale * dark[i]) * flatscale / flat[i] + } + + # Often these operations will not be performed so test for no + # correction rather than go through the switch. + + op = cors[ILLUMCOR] + cors[FRINGECOR] + if (op != 0) { + switch (op) { + case I: # illumination + do i = 1, n + out[i] = out[i] * illumscale / illum[i] + case Q: # fringe + do i = 1, n + out[i] = out[i] - frgscale * fringe[i] + case QI: # fringe + illumination + do i = 1, n + out[i] = out[i]*illumscale/illum[i] - frgscale*fringe[i] + } + } +end + + +# COR2 -- Correct lines for readout axis 2 (columns). This procedure is +# more complex than when the readout is along the image lines because the +# zero level and/or flat field corrections may be single readout column +# vectors. + +procedure cor2r (line, cors, out, overscan, zero, dark, flat, illum, + fringe, n, zeroim, flatim, darkscale, flatscale, illumscale, frgscale) + +int line # Line to be corrected +int cors[ARB] # Correction flags +real out[n] # Output data +real overscan[n] # Overscan value +real zero[n] # Zero level correction +real dark[n] # Dark count correction +real flat[n] # Flat field correction +real illum[n] # Illumination correction +real fringe[n] # Fringe correction +int n # Number of pixels +pointer zeroim # Zero level IMIO pointer (NULL if 1D vector) +pointer flatim # Flat field IMIO pointer (NULL if 1D vector) +real darkscale # Dark count scale factor +real flatscale # Flat field scale factor +real illumscale # Illumination scale factor +real frgscale # Fringe scale factor + +real zeroval +real flatval +int i, op + +begin + op = cors[OVERSCAN] + cors[ZEROCOR] + cors[DARKCOR] + cors[FLATCOR] + switch (op) { + case O: # overscan + do i = 1, n + out[i] = out[i] - overscan[i] + case Z: # zero level + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - zero[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - zeroval + } + + case ZO: # zero level + overscan + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - overscan[i] - zero[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - overscan[i] - zeroval + } + + case D: # dark count + do i = 1, n + out[i] = out[i] - darkscale * dark[i] + case DO: # dark count + overscan + do i = 1, n + out[i] = out[i] - overscan[i] - darkscale * dark[i] + case DZ: # dark count + zero level + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - zero[i] - darkscale * dark[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - zeroval - darkscale * dark[i] + } + case DZO: # dark count + zero level + overscan + if (zeroim != NULL) + do i = 1, n + out[i] = out[i] - overscan[i] - zero[i] - + darkscale * dark[i] + else { + zeroval = zero[line] + do i = 1, n + out[i] = out[i] - overscan[i] - zeroval - + darkscale * dark[i] + } + + case F: # flat field + if (flatim != NULL) { + do i = 1, n + out[i] = out[i] * flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = out[i] * flatval + } + case FO: # flat field + overscan + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i]) * flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - overscan[i]) * flatval + } + case FZ: # flat field + zero level + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i]) * flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval) * flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval) * flatval + } + } + case FZO: # flat field + zero level + overscan + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i]) * + flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval) * + flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval) * flatval + } + } + case FD: # flat field + dark count + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatscale/flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - darkscale * dark[i]) * flatval + } + case FDO: # flat field + dark count + overscan + if (flatim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - darkscale * dark[i]) * + flatscale / flat[i] + } else { + flatval = flatscale / flat[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - darkscale * dark[i]) * + flatval + } + case FDZ: # flat field + dark count + zero level + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval - darkscale * dark[i]) * + flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - zero[i] - darkscale * dark[i]) * + flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - zeroval - darkscale * dark[i]) * + flatval + } + } + case FDZO: # flat field + dark count + zero level + overscan + if (flatim != NULL) { + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i] - + darkscale * dark[i]) * flatscale / flat[i] + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval - + darkscale * dark[i]) * flatscale / flat[i] + } + } else { + flatval = flatscale / flat[line] + if (zeroim != NULL) { + do i = 1, n + out[i] = (out[i] - overscan[i] - zero[i] - + darkscale * dark[i]) * flatval + } else { + zeroval = zero[line] + do i = 1, n + out[i] = (out[i] - overscan[i] - zeroval - + darkscale * dark[i]) * flatval + } + } + } + + # Often these operations will not be performed so test for no + # correction rather than go through the switch. + + op = cors[ILLUMCOR] + cors[FRINGECOR] + if (op != 0) { + switch (op) { + case I: # illumination + do i = 1, n + out[i] = out[i] * illumscale / illum[i] + case Q: # fringe + do i = 1, n + out[i] = out[i] - frgscale * fringe[i] + case QI: # fringe + illumination + do i = 1, n + out[i] = out[i]*illumscale/illum[i] - frgscale*fringe[i] + } + } +end diff --git a/noao/imred/ccdred/src/generic/icaclip.x b/noao/imred/ccdred/src/generic/icaclip.x new file mode 100644 index 00000000..1530145c --- /dev/null +++ b/noao/imred/ccdred/src/generic/icaclip.x @@ -0,0 +1,1102 @@ +# 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 + 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow > 0) { + 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_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 + 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/generic/icaverage.x b/noao/imred/ccdred/src/generic/icaverage.x new file mode 100644 index 00000000..3646b725 --- /dev/null +++ b/noao/imred/ccdred/src/generic/icaverage.x @@ -0,0 +1,163 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + + +# IC_AVERAGE -- Compute the average image line. +# Options include a weight average. + +procedure ic_averages (d, m, n, wts, npts, 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 +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 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 to the blank value. + + 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] + average[i] = sum / n[i] + } + } + } else if (dflag == D_NONE) { + 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 + } + average[i] = sum / sumwt + } else + 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] + average[i] = sum / n[i] + } else + average[i] = blank + } + } + } +end + +# IC_AVERAGE -- Compute the average image line. +# Options include a weight average. + +procedure ic_averager (d, m, n, wts, npts, 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 +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 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 to the blank value. + + 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] + average[i] = sum / n[i] + } + } + } else if (dflag == D_NONE) { + 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 + } + average[i] = sum / sumwt + } else + 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] + average[i] = sum / n[i] + } else + average[i] = blank + } + } + } +end diff --git a/noao/imred/ccdred/src/generic/iccclip.x b/noao/imred/ccdred/src/generic/iccclip.x new file mode 100644 index 00000000..57709064 --- /dev/null +++ b/noao/imred/ccdred/src/generic/iccclip.x @@ -0,0 +1,898 @@ +# 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow > 0) { + 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_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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/generic/icgdata.x b/noao/imred/ccdred/src/generic/icgdata.x new file mode 100644 index 00000000..5c6ac18c --- /dev/null +++ b/noao/imred/ccdred/src/generic/icgdata.x @@ -0,0 +1,459 @@ +# 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 keeped 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 for nonaligned images +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, ndim, nused +real a, b +pointer buf, dp, ip, mp, 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) + return + + # Get data and fill data buffers. Correct for offsets if needed. + ndim = IM_NDIM(out[1]) + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (aligned) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = imgnls (in[i], d[i], v2) + } else { + v2[1] = v1[1] + do j = 2, ndim + v2[j] = v1[j] - offsets[i,j] + if (project) + v2[ndim+1] = i + j = imgnls (in[i], buf, v2) + call amovs (Mems[buf], Mems[dbuf[i]+offsets[i,1]], + IM_LEN(in[i],1)) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + dp = d[i] + if (lflag[i] == D_ALL) { + 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 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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 + 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 + } + } + } + } + + # 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 { + dp = d[i] + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + do j = 1, npts { + Mems[dp] = Mems[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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] + dp = d[i] + ip = id[i] + mp = m[i] + do j = 1, npts { + 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 > 0) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + dp = d[i] + mp = m[i] + do j = 1, npts { + 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 keeped 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 for nonaligned images +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, ndim, nused +real a, b +pointer buf, dp, ip, mp, 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) + return + + # Get data and fill data buffers. Correct for offsets if needed. + ndim = IM_NDIM(out[1]) + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (aligned) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = imgnlr (in[i], d[i], v2) + } else { + v2[1] = v1[1] + do j = 2, ndim + v2[j] = v1[j] - offsets[i,j] + if (project) + v2[ndim+1] = i + j = imgnlr (in[i], buf, v2) + call amovr (Memr[buf], Memr[dbuf[i]+offsets[i,1]], + IM_LEN(in[i],1)) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + dp = d[i] + if (lflag[i] == D_ALL) { + 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 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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 + 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 + } + } + } + } + + # 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 { + dp = d[i] + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + do j = 1, npts { + Memr[dp] = Memr[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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] + dp = d[i] + ip = id[i] + mp = m[i] + do j = 1, npts { + 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 > 0) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + dp = d[i] + mp = m[i] + do j = 1, npts { + 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 + diff --git a/noao/imred/ccdred/src/generic/icgrow.x b/noao/imred/ccdred/src/generic/icgrow.x new file mode 100644 index 00000000..b94e1cbc --- /dev/null +++ b/noao/imred/ccdred/src/generic/icgrow.x @@ -0,0 +1,148 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + + +# IC_GROW -- Reject neigbors of rejected pixels. +# The rejected pixels are marked by having nonzero ids beyond the number +# of included pixels. The pixels rejected here are given zero ids +# to avoid growing of the pixels rejected here. The unweighted average +# can be updated but any rejected pixels requires the median to be +# recomputed. When the number of pixels at a grow point reaches nkeep +# no further pixels are rejected. Note that the rejection order is not +# based on the magnitude of the residuals and so a grow from a weakly +# rejected image pixel may take precedence over a grow from a strongly +# rejected image pixel. + +procedure ic_grows (d, m, n, nimages, npts, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i1, i2, j1, j2, k1, k2, l, is, ie, n2, maxkeep +pointer mp1, mp2 + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + do i1 = 1, npts { + k1 = i1 - 1 + is = max (1, i1 - grow) + ie = min (npts, i1 + grow) + do j1 = n[i1]+1, nimages { + l = Memi[m[j1]+k1] + if (l == 0) + next + if (combine == MEDIAN) + docombine = true + + do i2 = is, ie { + if (i2 == i1) + next + k2 = i2 - 1 + n2 = n[i2] + if (nkeep < 0) + maxkeep = max (0, n2 + nkeep) + else + maxkeep = min (n2, nkeep) + if (n2 <= maxkeep) + next + do j2 = 1, n2 { + mp1 = m[j2] + k2 + if (Memi[mp1] == l) { + if (!docombine && n2 > 1) + average[i2] = + (n2*average[i2] - Mems[d[j2]+k2]) / (n2-1) + mp2 = m[n2] + k2 + if (j2 < n2) { + Mems[d[j2]+k2] = Mems[d[n2]+k2] + Memi[mp1] = Memi[mp2] + } + Memi[mp2] = 0 + n[i2] = n2 - 1 + break + } + } + } + } + } +end + +# IC_GROW -- Reject neigbors of rejected pixels. +# The rejected pixels are marked by having nonzero ids beyond the number +# of included pixels. The pixels rejected here are given zero ids +# to avoid growing of the pixels rejected here. The unweighted average +# can be updated but any rejected pixels requires the median to be +# recomputed. When the number of pixels at a grow point reaches nkeep +# no further pixels are rejected. Note that the rejection order is not +# based on the magnitude of the residuals and so a grow from a weakly +# rejected image pixel may take precedence over a grow from a strongly +# rejected image pixel. + +procedure ic_growr (d, m, n, nimages, npts, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +int nimages # Number of images +int npts # Number of output points per line +real average[npts] # Average + +int i1, i2, j1, j2, k1, k2, l, is, ie, n2, maxkeep +pointer mp1, mp2 + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + do i1 = 1, npts { + k1 = i1 - 1 + is = max (1, i1 - grow) + ie = min (npts, i1 + grow) + do j1 = n[i1]+1, nimages { + l = Memi[m[j1]+k1] + if (l == 0) + next + if (combine == MEDIAN) + docombine = true + + do i2 = is, ie { + if (i2 == i1) + next + k2 = i2 - 1 + n2 = n[i2] + if (nkeep < 0) + maxkeep = max (0, n2 + nkeep) + else + maxkeep = min (n2, nkeep) + if (n2 <= maxkeep) + next + do j2 = 1, n2 { + mp1 = m[j2] + k2 + if (Memi[mp1] == l) { + if (!docombine && n2 > 1) + average[i2] = + (n2*average[i2] - Memr[d[j2]+k2]) / (n2-1) + mp2 = m[n2] + k2 + if (j2 < n2) { + Memr[d[j2]+k2] = Memr[d[n2]+k2] + Memi[mp1] = Memi[mp2] + } + Memi[mp2] = 0 + n[i2] = n2 - 1 + break + } + } + } + } + } +end diff --git a/noao/imred/ccdred/src/generic/icmedian.x b/noao/imred/ccdred/src/generic/icmedian.x new file mode 100644 index 00000000..ec0166ba --- /dev/null +++ b/noao/imred/ccdred/src/generic/icmedian.x @@ -0,0 +1,343 @@ +# 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, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +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) { + 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 + 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 + median[i] = blank + } +end + +# IC_MEDIAN -- Median of lines + +procedure ic_medianr (d, n, npts, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +int npts # Number of output points per line +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) { + 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 + 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 + median[i] = blank + } +end + diff --git a/noao/imred/ccdred/src/generic/icmm.x b/noao/imred/ccdred/src/generic/icmm.x new file mode 100644 index 00000000..259759bd --- /dev/null +++ b/noao/imred/ccdred/src/generic/icmm.x @@ -0,0 +1,300 @@ +# 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 + Memi[m[jmax]+i1] = Memi[m[j]+i1] + } else { + Mems[kmax] = d1 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } + if (jmin < j) { + if (jmax != n1) { + Mems[kmin] = d1 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } else { + Mems[kmin] = d2 + Memi[m[jmin]+i1] = Memi[m[j]+i1] + } + } + } 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 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } + } 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 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } 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_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 + Memi[m[jmax]+i1] = Memi[m[j]+i1] + } else { + Memr[kmax] = d1 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } + if (jmin < j) { + if (jmax != n1) { + Memr[kmin] = d1 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } else { + Memr[kmin] = d2 + Memi[m[jmin]+i1] = Memi[m[j]+i1] + } + } + } 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 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } + } 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 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } 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 diff --git a/noao/imred/ccdred/src/generic/icombine.x b/noao/imred/ccdred/src/generic/icombine.x new file mode 100644 index 00000000..b4ff60be --- /dev/null +++ b/noao/imred/ccdred/src/generic/icombine.x @@ -0,0 +1,607 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "../icombine.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, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, npts, fd, stropen(), errcode(), imstati() +pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf +pointer buf, imgl1s(), impl1i() +errchk stropen, imgl1s, impl1i +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + 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 (scales, nimages, TY_REAL) + call salloc (zeros, nimages, TY_REAL) + call salloc (wts, nimages, TY_REAL) + call amovki (D_ALL, Memi[lflag], nimages) + + # If aligned use the IMIO buffer otherwise we need vectors of + # output length. + + if (!aligned) { + call salloc (dbuf, nimages, TY_POINTER) + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_SHORT) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 3 { + if (out[i] != NULL) + 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, 3 { + if (out[i] != NULL) + 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) + } + + do i = 1, nimages { + call imseti (in[i], IM_BUFSIZE, bufsize) + iferr (buf = imgl1s (in[i])) { + switch (errcode()) { + case SYS_MFULL: + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (imstati (in[i], IM_CLOSEFD) == YES) { + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + do j = i-2, nimages + call imseti (in[j], IM_CLOSEFD, YES) + buf = imgl1s (in[i]) + default: + 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, Memr[scales], Memr[zeros], + Memr[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, ctor() +real r, imgetr() +pointer sp, v1, v2, v3, outdata, buf, nm, impnli() +pointer impnlr() +errchk ic_scale, imgetr + +include "../icombine.com" + +begin + call smark (sp) + 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 || grow > 0) + 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 + if (grow > 0) + keepids = true + case PCLIP: + mclip = true + if (grow > 0) + keepids = true + case AVSIGCLIP, SIGCLIP: + if (doscale1 || grow > 0) + keepids = true + case NONE: + mclip = false + grow = 0 + } + + 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 (grow > 0) + call ic_grows (d, id, n, nimages, npts, Memr[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averages (d, id, n, wts, npts, Memr[outdata]) + case MEDIAN: + call ic_medians (d, n, npts, Memr[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + call sfree (sp) +end + +procedure icombiner (in, out, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, npts, fd, stropen(), errcode(), imstati() +pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf +pointer buf, imgl1r(), impl1i() +errchk stropen, imgl1r, impl1i +pointer impl1r() +errchk impl1r + +include "../icombine.com" + +begin + npts = IM_LEN(out[1],1) + + # Allocate memory. + call smark (sp) + 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 (scales, nimages, TY_REAL) + call salloc (zeros, nimages, TY_REAL) + call salloc (wts, nimages, TY_REAL) + call amovki (D_ALL, Memi[lflag], nimages) + + # If aligned use the IMIO buffer otherwise we need vectors of + # output length. + + if (!aligned) { + call salloc (dbuf, nimages, TY_POINTER) + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_REAL) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 3 { + if (out[i] != NULL) + 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, 3 { + if (out[i] != NULL) + 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) + } + + do i = 1, nimages { + call imseti (in[i], IM_BUFSIZE, bufsize) + iferr (buf = imgl1r (in[i])) { + switch (errcode()) { + case SYS_MFULL: + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (imstati (in[i], IM_CLOSEFD) == YES) { + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + do j = i-2, nimages + call imseti (in[j], IM_CLOSEFD, YES) + buf = imgl1r (in[i]) + default: + 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, Memr[scales], Memr[zeros], + Memr[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, ctor() +real r, imgetr() +pointer sp, v1, v2, v3, outdata, buf, nm, impnli() +pointer impnlr() +errchk ic_scale, imgetr + +include "../icombine.com" + +begin + call smark (sp) + 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 || grow > 0) + 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 + if (grow > 0) + keepids = true + case PCLIP: + mclip = true + if (grow > 0) + keepids = true + case AVSIGCLIP, SIGCLIP: + if (doscale1 || grow > 0) + keepids = true + case NONE: + mclip = false + grow = 0 + } + + 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 (grow > 0) + call ic_growr (d, id, n, nimages, npts, Memr[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_averager (d, id, n, wts, npts, Memr[outdata]) + case MEDIAN: + call ic_medianr (d, n, npts, Memr[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + + call sfree (sp) +end + diff --git a/noao/imred/ccdred/src/generic/icpclip.x b/noao/imred/ccdred/src/generic/icpclip.x new file mode 100644 index 00000000..da09bb75 --- /dev/null +++ b/noao/imred/ccdred/src/generic/icpclip.x @@ -0,0 +1,442 @@ +# 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 > 0)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+j] = Mems[d[k]+j] + if (grow > 0) { + 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_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 > 0)) { + k = max (nl, n4 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+j] = Memr[d[k]+j] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/generic/icsclip.x b/noao/imred/ccdred/src/generic/icsclip.x new file mode 100644 index 00000000..d7ccfd84 --- /dev/null +++ b/noao/imred/ccdred/src/generic/icsclip.x @@ -0,0 +1,964 @@ +# 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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Mems[d[l]+k] = Mems[d[j]+k] + if (grow > 0) { + 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_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 > 0)) { + j = max (nl, n1 + 1) + if (keepids) { + do l = 1, min (n1, nl-1) { + Memr[d[l]+k] = Memr[d[j]+k] + if (grow > 0) { + 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 diff --git a/noao/imred/ccdred/src/generic/icsigma.x b/noao/imred/ccdred/src/generic/icsigma.x new file mode 100644 index 00000000..bc0d9788 --- /dev/null +++ b/noao/imred/ccdred/src/generic/icsigma.x @@ -0,0 +1,205 @@ +# 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 + } + sigma[i] = sqrt (sum / sumwt * 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_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 + } + sigma[i] = sqrt (sum / sumwt * 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 diff --git a/noao/imred/ccdred/src/generic/icsort.x b/noao/imred/ccdred/src/generic/icsort.x new file mode 100644 index 00000000..a39b68e2 --- /dev/null +++ b/noao/imred/ccdred/src/generic/icsort.x @@ -0,0 +1,550 @@ +# 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_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 diff --git a/noao/imred/ccdred/src/generic/icstat.x b/noao/imred/ccdred/src/generic/icstat.x new file mode 100644 index 00000000..41512ccb --- /dev/null +++ b/noao/imred/ccdred/src/generic/icstat.x @@ -0,0 +1,444 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 10000 # 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() +short ic_modes() +real asums() + + +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, 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) + } + + 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.8 # 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_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 ic_moder() +real asumr() + + +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, 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) + } + + 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.8 # 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 + diff --git a/noao/imred/ccdred/src/generic/mkpkg b/noao/imred/ccdred/src/generic/mkpkg new file mode 100644 index 00000000..3d841680 --- /dev/null +++ b/noao/imred/ccdred/src/generic/mkpkg @@ -0,0 +1,11 @@ +# Make CCDRED Package. + +$checkout libpkg.a ../.. +$update libpkg.a +$checkin libpkg.a ../.. +$exit + +libpkg.a: + cor.x ccdred.h + proc.x ccdred.h <imhdr.h> + ; diff --git a/noao/imred/ccdred/src/generic/proc.x b/noao/imred/ccdred/src/generic/proc.x new file mode 100644 index 00000000..242da9c9 --- /dev/null +++ b/noao/imred/ccdred/src/generic/proc.x @@ -0,0 +1,735 @@ +include <imhdr.h> +include "ccdred.h" + + +.help proc Feb87 noao.imred.ccdred +.nf ---------------------------------------------------------------------------- +proc -- Process CCD images + +These are the main CCD reduction procedures. There is one for each +readout axis (lines or columns) and one for short and real image data. +They apply corrections for bad pixels, overscan levels, zero levels, +dark counts, flat field response, illumination response, and fringe +effects. The image is also trimmed if it was mapped with an image +section. The mean value for the output image is computed when the flat +field or illumination image is processed to form the scale factor for +these calibrations in order to avoid reading through these image a +second time. + +The processing information and parameters are specified in the CCD +structure. The processing operations to be performed are specified by +the correction array CORS in the ccd structure. There is one array +element for each operation with indices defined symbolically by macro +definitions (see ccdred.h); i.e. FLATCOR. The value of the array +element is an integer bit field in which the bit set is the same as the +array index; i.e element 3 will have the third bit set for an operation +with array value 2**(3-1)=4. If an operation is not to be performed +the bit is not set and the array element has the numeric value zero. +Note that the addition of several correction elements gives a unique +bit field describing a combination of operations. For efficiency the +most common combinations are implemented as separate units. + +The CCD structure also contains the correction or calibration data +consisting either pointers to data, IMIO pointers for the calibration +images, and scale factors. + +The processing is performed line-by-line. The procedure CORINPUT is +called to get an input line. This procedure trims and fixes bad pixels by +interpolation. The output line and lines from the various calibration +images are read. The image vectors as well as the overscan vector and +the scale factors are passed to the procedure COR (which also +dereferences the pointer data into simple arrays and variables). That +procedure does the actual corrections apart from bad pixel +corrections. + +The final optional step is to add each corrected output line to form a +mean. This adds efficiency since the operation is done only if desired +and the output image data is already in memory so there is no I/O +penalty. + +SEE ALSO + ccdred.h, cor, fixpix, setfixpix, setoverscan, settrim, + setzero, setdark, setflat, setillum, setfringe +.endhelp ---------------------------------------------------------------------- + + + +# PROC1 -- Process CCD images with readout axis 1 (lines). + +procedure proc1s (ccd) + +pointer ccd # CCD structure + +int line, ncols, nlines, findmean, rep +int overscan_type, overscan_c1, noverscan +real overscan, darkscale, flatscale, illumscale, frgscale, mean +short minrep +pointer in, out, zeroim, darkim, flatim, illumim, fringeim, overscan_vec +pointer inbuf, outbuf, zerobuf, darkbuf, flatbuf, illumbuf, fringebuf + +real asums() +real find_overscans() +pointer imgl2s(), impl2s(), ccd_gls(), xt_fpss() + +begin + # Initialize. If the correction image is 1D then just get the + # data once. + + in = IN_IM(ccd) + out = OUT_IM(ccd) + ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 + nlines = OUT_L2(ccd) - OUT_L1(ccd) + 1 + + findmean = CORS(ccd, FINDMEAN) + if (findmean == YES) + mean = 0. + rep = CORS(ccd, MINREP) + if (rep == YES) + minrep = MINREPLACE(ccd) + + if (CORS(ccd, OVERSCAN) == 0) + overscan_type = 0 + else { + overscan_type = OVERSCAN_TYPE(ccd) + overscan_vec = OVERSCAN_VEC(ccd) + overscan_c1 = BIAS_C1(ccd) - 1 + noverscan = BIAS_C2(ccd) - overscan_c1 + } + + if (CORS(ccd, ZEROCOR) == 0) { + zeroim = NULL + zerobuf = 1 + } else if (IM_LEN(ZERO_IM(ccd),2) == 1) { + zeroim = NULL + zerobuf = ccd_gls (ZERO_IM(ccd), ZERO_C1(ccd), ZERO_C2(ccd), 1) + } else + zeroim = ZERO_IM(ccd) + + if (CORS(ccd, DARKCOR) == 0) { + darkim = NULL + darkbuf = 1 + } else if (IM_LEN(DARK_IM(ccd),2) == 1) { + darkim = NULL + darkbuf = ccd_gls (DARK_IM(ccd), DARK_C1(ccd), DARK_C2(ccd), 1) + darkscale = FLATSCALE(ccd) + } else { + darkim = DARK_IM(ccd) + darkscale = DARKSCALE(ccd) + } + + if (CORS(ccd, FLATCOR) == 0) { + flatim = NULL + flatbuf = 1 + } else if (IM_LEN(FLAT_IM(ccd),2) == 1) { + flatim = NULL + flatbuf = ccd_gls (FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), 1) + flatscale = FLATSCALE(ccd) + } else { + flatim = FLAT_IM(ccd) + flatscale = FLATSCALE(ccd) + } + + if (CORS(ccd, ILLUMCOR) == 0) { + illumim = NULL + illumbuf = 1 + } else { + illumim = ILLUM_IM(ccd) + illumscale = ILLUMSCALE(ccd) + } + + if (CORS(ccd, FRINGECOR) == 0) { + fringeim = NULL + fringebuf = 1 + } else { + fringeim = FRINGE_IM(ccd) + frgscale = FRINGESCALE(ccd) + } + + # For each line read lines from the input. Procedure XT_FPS replaces + # bad pixels by interpolation. The trimmed region is copied to the + # output. Get lines from the output image and from the zero level, + # dark count, flat field, illumination, and fringe images. Call COR1 + # to do the actual pixel corrections. Finally, add the output pixels + # to a sum for computing the mean. We must copy data outside of the + # output data section. + + do line = 2 - OUT_L1(ccd), 0 + call amovs ( + Mems[imgl2s(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mems[impl2s(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + do line = 1, nlines { + outbuf = impl2s (out, OUT_L1(ccd)+line-1) + + inbuf = xt_fpss (MASK_FP(ccd), in, IN_L1(ccd)+line-1, IN_C1(ccd), + IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) + call amovs (Mems[inbuf+IN_C1(ccd)-OUT_C1(ccd)], Mems[outbuf], + IM_LEN(out,1)) + + outbuf = outbuf + OUT_C1(ccd) - 1 + if (overscan_type != 0) { + if (overscan_type < OVERSCAN_FIT) + overscan = find_overscans (Mems[inbuf+overscan_c1], + noverscan, overscan_type) + else + overscan = Memr[overscan_vec+line-1] + } + if (zeroim != NULL) + zerobuf = ccd_gls (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), + ZERO_L1(ccd)+line-1) + if (darkim != NULL) + darkbuf = ccd_gls (darkim, DARK_C1(ccd), DARK_C2(ccd), + DARK_L1(ccd)+line-1) + if (flatim != NULL) + flatbuf = ccd_gls (flatim, FLAT_C1(ccd), FLAT_C2(ccd), + FLAT_L1(ccd)+line-1) + if (illumim != NULL) + illumbuf = ccd_gls (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), + ILLUM_L1(ccd)+line-1) + if (fringeim != NULL) + fringebuf = ccd_gls (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), + FRINGE_L1(ccd)+line-1) + + call cor1s (CORS(ccd,1), Mems[outbuf], + overscan, Mems[zerobuf], Mems[darkbuf], + Mems[flatbuf], Mems[illumbuf], Mems[fringebuf], ncols, + darkscale, flatscale, illumscale, frgscale) + + if (rep == YES) + call amaxks (Mems[outbuf], minrep, Mems[outbuf], ncols) + if (findmean == YES) + mean = mean + asums (Mems[outbuf], ncols) + } + + do line = nlines+1, IM_LEN(out,2)-OUT_L1(ccd)+1 + call amovs ( + Mems[imgl2s(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mems[impl2s(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + # Compute the mean from the sum of the output pixels. + if (findmean == YES) + MEAN(ccd) = mean / ncols / nlines +end + + +# PROC2 -- Process CCD images with readout axis 2 (columns). + +procedure proc2s (ccd) + +pointer ccd # CCD structure + +int line, ncols, nlines, findmean, rep +real darkscale, flatscale, illumscale, frgscale, mean +short minrep +pointer in, out, zeroim, darkim, flatim, illumim, fringeim, overscan_vec +pointer inbuf, outbuf, zerobuf, darkbuf, flatbuf, illumbuf, fringebuf + +real asums() +pointer imgl2s(), impl2s(), imgs2s(), ccd_gls(), xt_fpss() + +begin + # Initialize. If the correction image is 1D then just get the + # data once. + + in = IN_IM(ccd) + out = OUT_IM(ccd) + ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 + nlines = OUT_L2(ccd) - OUT_L1(ccd) + 1 + + findmean = CORS(ccd, FINDMEAN) + if (findmean == YES) + mean = 0. + rep = CORS(ccd, MINREP) + if (rep == YES) + minrep = MINREPLACE(ccd) + + overscan_vec = OVERSCAN_VEC(ccd) + + if (CORS(ccd, ZEROCOR) == 0) { + zeroim = NULL + zerobuf = 1 + } else if (IM_LEN(ZERO_IM(ccd),1) == 1) { + zeroim = NULL + zerobuf = imgs2s (ZERO_IM(ccd), 1, 1, ZERO_L1(ccd), ZERO_L2(ccd)) + } else + zeroim = ZERO_IM(ccd) + + if (CORS(ccd, DARKCOR) == 0) { + darkim = NULL + darkbuf = 1 + } else if (IM_LEN(DARK_IM(ccd),1) == 1) { + darkim = NULL + darkbuf = imgs2s (DARK_IM(ccd), 1, 1, DARK_L1(ccd), DARK_L2(ccd)) + darkscale = DARKSCALE(ccd) + } else { + darkim = DARK_IM(ccd) + darkscale = DARKSCALE(ccd) + } + + if (CORS(ccd, FLATCOR) == 0) { + flatim = NULL + flatbuf = 1 + } else if (IM_LEN(FLAT_IM(ccd),1) == 1) { + flatim = NULL + flatbuf = imgs2s (FLAT_IM(ccd), 1, 1, FLAT_L1(ccd), FLAT_L2(ccd)) + flatscale = FLATSCALE(ccd) + } else { + flatim = FLAT_IM(ccd) + flatscale = FLATSCALE(ccd) + } + + if (CORS(ccd, ILLUMCOR) == 0) { + illumim = NULL + illumbuf = 1 + } else { + illumim = ILLUM_IM(ccd) + illumscale = ILLUMSCALE(ccd) + } + + if (CORS(ccd, FRINGECOR) == 0) { + fringeim = NULL + fringebuf = 1 + } else { + fringeim = FRINGE_IM(ccd) + frgscale = FRINGESCALE(ccd) + } + + # For each line read lines from the input. Procedure CORINPUT + # replaces bad pixels by interpolation and applies a trim to the + # input. Get lines from the output image and from the zero level, + # dark count, flat field, illumination, and fringe images. + # Call COR2 to do the actual pixel corrections. Finally, add the + # output pixels to a sum for computing the mean. + # We must copy data outside of the output data section. + + do line = 2 - OUT_L1(ccd), 0 + call amovs ( + Mems[imgl2s(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mems[impl2s(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + do line = 1, nlines { + outbuf = impl2s (out, OUT_L1(ccd)+line-1) + + inbuf = xt_fpss (MASK_FP(ccd), in, IN_L1(ccd)+line-1, IN_C1(ccd), + IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) + call amovs (Mems[inbuf+IN_C1(ccd)-OUT_C1(ccd)], Mems[outbuf], + IM_LEN(out,1)) + + outbuf = outbuf + OUT_C1(ccd) - 1 + if (zeroim != NULL) + zerobuf = ccd_gls (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), + ZERO_L1(ccd)+line-1) + if (darkim != NULL) + darkbuf = ccd_gls (darkim, DARK_C1(ccd), DARK_C2(ccd), + DARK_L1(ccd)+line-1) + if (flatim != NULL) + flatbuf = ccd_gls (flatim, FLAT_C1(ccd), FLAT_C2(ccd), + FLAT_L1(ccd)+line-1) + if (illumim != NULL) + illumbuf = ccd_gls (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), + ILLUM_L1(ccd)+line-1) + if (fringeim != NULL) + fringebuf = ccd_gls (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), + FRINGE_L1(ccd)+line-1) + + call cor2s (line, CORS(ccd,1), Mems[outbuf], + Memr[overscan_vec], Mems[zerobuf], Mems[darkbuf], + Mems[flatbuf], Mems[illumbuf], Mems[fringebuf], ncols, + zeroim, flatim, darkscale, flatscale, illumscale, frgscale) + + if (rep == YES) + call amaxks (Mems[outbuf], minrep, Mems[outbuf], ncols) + if (findmean == YES) + mean = mean + asums (Mems[outbuf], ncols) + } + + do line = nlines+1, IM_LEN(out,2)-OUT_L1(ccd)+1 + call amovs ( + Mems[imgl2s(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mems[impl2s(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + # Compute the mean from the sum of the output pixels. + if (findmean == YES) + MEAN(ccd) = mean / ncols / nlines +end + + +# FIND_OVERSCAN -- Find the overscan value for a line. +# No check is made on the number of pixels. +# The median is the (npix+1)/2 element. + +real procedure find_overscans (data, npix, type) + +short data[npix] #I Overscan data +int npix #I Number of overscan points +int type #I Type of overscan calculation + +int i +real overscan, d, dmin, dmax +short asoks() + +begin + if (type == OVERSCAN_MINMAX) { + overscan = data[1] + dmin = data[1] + dmax = data[1] + do i = 2, npix { + d = data[i] + overscan = overscan + d + if (d < dmin) + dmin = d + else if (d > dmax) + dmax = d + } + overscan = (overscan - dmin - dmax) / (npix - 2) + } else if (type == OVERSCAN_MEDIAN) + overscan = asoks (data, npix, (npix + 1) / 2) + else { + overscan = data[1] + do i = 2, npix + overscan = overscan + data[i] + overscan = overscan / npix + } + + return (overscan) +end + +# PROC1 -- Process CCD images with readout axis 1 (lines). + +procedure proc1r (ccd) + +pointer ccd # CCD structure + +int line, ncols, nlines, findmean, rep +int overscan_type, overscan_c1, noverscan +real overscan, darkscale, flatscale, illumscale, frgscale, mean +real minrep +pointer in, out, zeroim, darkim, flatim, illumim, fringeim, overscan_vec +pointer inbuf, outbuf, zerobuf, darkbuf, flatbuf, illumbuf, fringebuf + +real asumr() +real find_overscanr() +pointer imgl2r(), impl2r(), ccd_glr(), xt_fpsr() + +begin + # Initialize. If the correction image is 1D then just get the + # data once. + + in = IN_IM(ccd) + out = OUT_IM(ccd) + ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 + nlines = OUT_L2(ccd) - OUT_L1(ccd) + 1 + + findmean = CORS(ccd, FINDMEAN) + if (findmean == YES) + mean = 0. + rep = CORS(ccd, MINREP) + if (rep == YES) + minrep = MINREPLACE(ccd) + + if (CORS(ccd, OVERSCAN) == 0) + overscan_type = 0 + else { + overscan_type = OVERSCAN_TYPE(ccd) + overscan_vec = OVERSCAN_VEC(ccd) + overscan_c1 = BIAS_C1(ccd) - 1 + noverscan = BIAS_C2(ccd) - overscan_c1 + } + + if (CORS(ccd, ZEROCOR) == 0) { + zeroim = NULL + zerobuf = 1 + } else if (IM_LEN(ZERO_IM(ccd),2) == 1) { + zeroim = NULL + zerobuf = ccd_glr (ZERO_IM(ccd), ZERO_C1(ccd), ZERO_C2(ccd), 1) + } else + zeroim = ZERO_IM(ccd) + + if (CORS(ccd, DARKCOR) == 0) { + darkim = NULL + darkbuf = 1 + } else if (IM_LEN(DARK_IM(ccd),2) == 1) { + darkim = NULL + darkbuf = ccd_glr (DARK_IM(ccd), DARK_C1(ccd), DARK_C2(ccd), 1) + darkscale = FLATSCALE(ccd) + } else { + darkim = DARK_IM(ccd) + darkscale = DARKSCALE(ccd) + } + + if (CORS(ccd, FLATCOR) == 0) { + flatim = NULL + flatbuf = 1 + } else if (IM_LEN(FLAT_IM(ccd),2) == 1) { + flatim = NULL + flatbuf = ccd_glr (FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), 1) + flatscale = FLATSCALE(ccd) + } else { + flatim = FLAT_IM(ccd) + flatscale = FLATSCALE(ccd) + } + + if (CORS(ccd, ILLUMCOR) == 0) { + illumim = NULL + illumbuf = 1 + } else { + illumim = ILLUM_IM(ccd) + illumscale = ILLUMSCALE(ccd) + } + + if (CORS(ccd, FRINGECOR) == 0) { + fringeim = NULL + fringebuf = 1 + } else { + fringeim = FRINGE_IM(ccd) + frgscale = FRINGESCALE(ccd) + } + + # For each line read lines from the input. Procedure XT_FPS replaces + # bad pixels by interpolation. The trimmed region is copied to the + # output. Get lines from the output image and from the zero level, + # dark count, flat field, illumination, and fringe images. Call COR1 + # to do the actual pixel corrections. Finally, add the output pixels + # to a sum for computing the mean. We must copy data outside of the + # output data section. + + do line = 2 - OUT_L1(ccd), 0 + call amovr ( + Memr[imgl2r(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Memr[impl2r(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + do line = 1, nlines { + outbuf = impl2r (out, OUT_L1(ccd)+line-1) + + inbuf = xt_fpsr (MASK_FP(ccd), in, IN_L1(ccd)+line-1, IN_C1(ccd), + IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) + call amovr (Memr[inbuf+IN_C1(ccd)-OUT_C1(ccd)], Memr[outbuf], + IM_LEN(out,1)) + + outbuf = outbuf + OUT_C1(ccd) - 1 + if (overscan_type != 0) { + if (overscan_type < OVERSCAN_FIT) + overscan = find_overscanr (Memr[inbuf+overscan_c1], + noverscan, overscan_type) + else + overscan = Memr[overscan_vec+line-1] + } + if (zeroim != NULL) + zerobuf = ccd_glr (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), + ZERO_L1(ccd)+line-1) + if (darkim != NULL) + darkbuf = ccd_glr (darkim, DARK_C1(ccd), DARK_C2(ccd), + DARK_L1(ccd)+line-1) + if (flatim != NULL) + flatbuf = ccd_glr (flatim, FLAT_C1(ccd), FLAT_C2(ccd), + FLAT_L1(ccd)+line-1) + if (illumim != NULL) + illumbuf = ccd_glr (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), + ILLUM_L1(ccd)+line-1) + if (fringeim != NULL) + fringebuf = ccd_glr (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), + FRINGE_L1(ccd)+line-1) + + call cor1r (CORS(ccd,1), Memr[outbuf], + overscan, Memr[zerobuf], Memr[darkbuf], + Memr[flatbuf], Memr[illumbuf], Memr[fringebuf], ncols, + darkscale, flatscale, illumscale, frgscale) + + if (rep == YES) + call amaxkr (Memr[outbuf], minrep, Memr[outbuf], ncols) + if (findmean == YES) + mean = mean + asumr (Memr[outbuf], ncols) + } + + do line = nlines+1, IM_LEN(out,2)-OUT_L1(ccd)+1 + call amovr ( + Memr[imgl2r(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Memr[impl2r(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + # Compute the mean from the sum of the output pixels. + if (findmean == YES) + MEAN(ccd) = mean / ncols / nlines +end + + +# PROC2 -- Process CCD images with readout axis 2 (columns). + +procedure proc2r (ccd) + +pointer ccd # CCD structure + +int line, ncols, nlines, findmean, rep +real darkscale, flatscale, illumscale, frgscale, mean +real minrep +pointer in, out, zeroim, darkim, flatim, illumim, fringeim, overscan_vec +pointer inbuf, outbuf, zerobuf, darkbuf, flatbuf, illumbuf, fringebuf + +real asumr() +pointer imgl2r(), impl2r(), imgs2r(), ccd_glr(), xt_fpsr() + +begin + # Initialize. If the correction image is 1D then just get the + # data once. + + in = IN_IM(ccd) + out = OUT_IM(ccd) + ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 + nlines = OUT_L2(ccd) - OUT_L1(ccd) + 1 + + findmean = CORS(ccd, FINDMEAN) + if (findmean == YES) + mean = 0. + rep = CORS(ccd, MINREP) + if (rep == YES) + minrep = MINREPLACE(ccd) + + overscan_vec = OVERSCAN_VEC(ccd) + + if (CORS(ccd, ZEROCOR) == 0) { + zeroim = NULL + zerobuf = 1 + } else if (IM_LEN(ZERO_IM(ccd),1) == 1) { + zeroim = NULL + zerobuf = imgs2r (ZERO_IM(ccd), 1, 1, ZERO_L1(ccd), ZERO_L2(ccd)) + } else + zeroim = ZERO_IM(ccd) + + if (CORS(ccd, DARKCOR) == 0) { + darkim = NULL + darkbuf = 1 + } else if (IM_LEN(DARK_IM(ccd),1) == 1) { + darkim = NULL + darkbuf = imgs2r (DARK_IM(ccd), 1, 1, DARK_L1(ccd), DARK_L2(ccd)) + darkscale = DARKSCALE(ccd) + } else { + darkim = DARK_IM(ccd) + darkscale = DARKSCALE(ccd) + } + + if (CORS(ccd, FLATCOR) == 0) { + flatim = NULL + flatbuf = 1 + } else if (IM_LEN(FLAT_IM(ccd),1) == 1) { + flatim = NULL + flatbuf = imgs2r (FLAT_IM(ccd), 1, 1, FLAT_L1(ccd), FLAT_L2(ccd)) + flatscale = FLATSCALE(ccd) + } else { + flatim = FLAT_IM(ccd) + flatscale = FLATSCALE(ccd) + } + + if (CORS(ccd, ILLUMCOR) == 0) { + illumim = NULL + illumbuf = 1 + } else { + illumim = ILLUM_IM(ccd) + illumscale = ILLUMSCALE(ccd) + } + + if (CORS(ccd, FRINGECOR) == 0) { + fringeim = NULL + fringebuf = 1 + } else { + fringeim = FRINGE_IM(ccd) + frgscale = FRINGESCALE(ccd) + } + + # For each line read lines from the input. Procedure CORINPUT + # replaces bad pixels by interpolation and applies a trim to the + # input. Get lines from the output image and from the zero level, + # dark count, flat field, illumination, and fringe images. + # Call COR2 to do the actual pixel corrections. Finally, add the + # output pixels to a sum for computing the mean. + # We must copy data outside of the output data section. + + do line = 2 - OUT_L1(ccd), 0 + call amovr ( + Memr[imgl2r(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Memr[impl2r(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + do line = 1, nlines { + outbuf = impl2r (out, OUT_L1(ccd)+line-1) + + inbuf = xt_fpsr (MASK_FP(ccd), in, IN_L1(ccd)+line-1, IN_C1(ccd), + IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) + call amovr (Memr[inbuf+IN_C1(ccd)-OUT_C1(ccd)], Memr[outbuf], + IM_LEN(out,1)) + + outbuf = outbuf + OUT_C1(ccd) - 1 + if (zeroim != NULL) + zerobuf = ccd_glr (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), + ZERO_L1(ccd)+line-1) + if (darkim != NULL) + darkbuf = ccd_glr (darkim, DARK_C1(ccd), DARK_C2(ccd), + DARK_L1(ccd)+line-1) + if (flatim != NULL) + flatbuf = ccd_glr (flatim, FLAT_C1(ccd), FLAT_C2(ccd), + FLAT_L1(ccd)+line-1) + if (illumim != NULL) + illumbuf = ccd_glr (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), + ILLUM_L1(ccd)+line-1) + if (fringeim != NULL) + fringebuf = ccd_glr (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), + FRINGE_L1(ccd)+line-1) + + call cor2r (line, CORS(ccd,1), Memr[outbuf], + Memr[overscan_vec], Memr[zerobuf], Memr[darkbuf], + Memr[flatbuf], Memr[illumbuf], Memr[fringebuf], ncols, + zeroim, flatim, darkscale, flatscale, illumscale, frgscale) + + if (rep == YES) + call amaxkr (Memr[outbuf], minrep, Memr[outbuf], ncols) + if (findmean == YES) + mean = mean + asumr (Memr[outbuf], ncols) + } + + do line = nlines+1, IM_LEN(out,2)-OUT_L1(ccd)+1 + call amovr ( + Memr[imgl2r(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Memr[impl2r(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + # Compute the mean from the sum of the output pixels. + if (findmean == YES) + MEAN(ccd) = mean / ncols / nlines +end + + +# FIND_OVERSCAN -- Find the overscan value for a line. +# No check is made on the number of pixels. +# The median is the (npix+1)/2 element. + +real procedure find_overscanr (data, npix, type) + +real data[npix] #I Overscan data +int npix #I Number of overscan points +int type #I Type of overscan calculation + +int i +real overscan, d, dmin, dmax +real asokr() + +begin + if (type == OVERSCAN_MINMAX) { + overscan = data[1] + dmin = data[1] + dmax = data[1] + do i = 2, npix { + d = data[i] + overscan = overscan + d + if (d < dmin) + dmin = d + else if (d > dmax) + dmax = d + } + overscan = (overscan - dmin - dmax) / (npix - 2) + } else if (type == OVERSCAN_MEDIAN) + overscan = asokr (data, npix, (npix + 1) / 2) + else { + overscan = data[1] + do i = 2, npix + overscan = overscan + data[i] + overscan = overscan / npix + } + + return (overscan) +end diff --git a/noao/imred/ccdred/src/hdrmap.com b/noao/imred/ccdred/src/hdrmap.com new file mode 100644 index 00000000..5aa74185 --- /dev/null +++ b/noao/imred/ccdred/src/hdrmap.com @@ -0,0 +1,4 @@ +# Common for HDRMAP package. + +pointer stp # Symbol table pointer +common /hdmcom/ stp diff --git a/noao/imred/ccdred/src/hdrmap.x b/noao/imred/ccdred/src/hdrmap.x new file mode 100644 index 00000000..ebcb253e --- /dev/null +++ b/noao/imred/ccdred/src/hdrmap.x @@ -0,0 +1,544 @@ +include <error.h> +include <syserr.h> + +.help hdrmap +.nf----------------------------------------------------------------------------- +HDRMAP -- Map translation between task parameters and image header parameters. + +In order for tasks to be partially independent of the image header +parameter names used by different instruments and observatories a +translation is made between task parameters and image header +parameters. This translation is given in a file consisting of the task +parameter name, the image header parameter name, and an optional +default value. This file is turned into a symbol table. If the +translation file is not found a null pointer is returned. The package will +then use the task parameter names directly. Also if there is no +translation given in the file for a particular parameter it is passed +on directly. If a parameter is not in the image header then the symbol +table default value, if given, is returned. This package is layered on +the IMIO header package. + + hdmopen (fname) + hdmclose () + hdmwrite (fname, mode) + hdmname (parameter, str, max_char) + hdmgdef (parameter, str, max_char) + hdmpdef (parameter, str, max_char) + y/n = hdmaccf (im, parameter) + hdmgstr (im, parameter, str, max_char) + ival = hdmgeti (im, parameter) + rval = hdmgetr (im, parameter) + hdmpstr (im, parameter, str) + hdmputi (im, parameter, value) + hdmputr (im, parameter, value) + hdmgstp (stp) + hdmpstp (stp) + hdmdelf (im, parameter) + hdmparm (name, parameter, max_char) + +hdmopen -- Open the translation file and map it into a symbol table pointer. +hdmclose -- Close the symbol table pointer. +hdmwrite -- Write out translation file. +hdmname -- Return the image header parameter name. +hdmpname -- Put the image header parameter name. +hdmgdef -- Get the default value as a string (null if none). +hdmpdef -- Put the default value as a string. +hdmaccf -- Return whether the image header parameter exists (regardless of + whether there is a default value). +hdmgstr -- Get a string valued parameter. Return default value if not in the + image header. Return null string if no default or image value. +hdmgeti -- Get an integer valued parameter. Return default value if not in + the image header and error condition if no default or image value. +hdmgetr -- Get a real valued parameter. Return default value if not in + the image header or error condition if no default or image value. +hdmpstr -- Put a string valued parameter in the image header. +hdmputi -- Put an integer valued parameter in the image header. +hdmputr -- Put a real valued parameter in the image header. +hdmgstp -- Get the symbol table pointer to save it while another map is used. +hdmpstp -- Put the symbol table pointer to restore a map. +hdmdelf -- Delete a field. +hdmparm -- Return the parameter name corresponding to an image header name. +.endhelp ----------------------------------------------------------------------- + +# Symbol table definitions. +define LEN_INDEX 32 # Length of symtab index +define LEN_STAB 1024 # Length of symtab string buffer +define SZ_SBUF 128 # Size of symtab string buffer + +define SZ_NAME 79 # Size of translation symbol name +define SZ_DEFAULT 79 # Size of default string +define SYMLEN 80 # Length of symbol structure + +# Symbol table structure +define NAME Memc[P2C($1)] # Translation name for symbol +define DEFAULT Memc[P2C($1+40)] # Default value of parameter + + +# HDMOPEN -- Open the translation file and map it into a symbol table pointer. + +procedure hdmopen (fname) + +char fname[ARB] # Image header map file + +int fd, open(), fscan(), nscan(), errcode() +pointer sp, parameter, sym, stopen(), stenter() +include "hdrmap.com" + +begin + # Create an empty symbol table. + stp = stopen (fname, LEN_INDEX, LEN_STAB, SZ_SBUF) + + # Return if file not found. + iferr (fd = open (fname, READ_ONLY, TEXT_FILE)) { + if (errcode () != SYS_FNOFNAME) + call erract (EA_WARN) + return + } + + call smark (sp) + call salloc (parameter, SZ_NAME, TY_CHAR) + + # Read the file an enter the translations in the symbol table. + while (fscan(fd) != EOF) { + call gargwrd (Memc[parameter], SZ_NAME) + if ((nscan() == 0) || (Memc[parameter] == '#')) + next + sym = stenter (stp, Memc[parameter], SYMLEN) + call gargwrd (NAME(sym), SZ_NAME) + call gargwrd (DEFAULT(sym), SZ_DEFAULT) + } + + call close (fd) + call sfree (sp) +end + + +# HDMCLOSE -- Close the symbol table pointer. + +procedure hdmclose () + +include "hdrmap.com" + +begin + if (stp != NULL) + call stclose (stp) +end + + +# HDMWRITE -- Write out translation file. + +procedure hdmwrite (fname, mode) + +char fname[ARB] # Image header map file +int mode # Access mode (APPEND, NEW_FILE) + +int fd, open(), stridxs() +pointer sym, sthead(), stnext(), stname() +errchk open +include "hdrmap.com" + +begin + # If there is no symbol table do nothing. + if (stp == NULL) + return + + fd = open (fname, mode, TEXT_FILE) + + sym = sthead (stp) + for (sym = sthead (stp); sym != NULL; sym = stnext (stp, sym)) { + if (stridxs (" ", Memc[stname (stp, sym)]) > 0) + call fprintf (fd, "'%s'%30t") + else + call fprintf (fd, "%s%30t") + call pargstr (Memc[stname (stp, sym)]) + if (stridxs (" ", NAME(sym)) > 0) + call fprintf (fd, " '%s'%10t") + else + call fprintf (fd, " %s%10t") + call pargstr (NAME(sym)) + if (DEFAULT(sym) != EOS) { + if (stridxs (" ", DEFAULT(sym)) > 0) + call fprintf (fd, " '%s'") + else + call fprintf (fd, " %s") + call pargstr (DEFAULT(sym)) + } + call fprintf (fd, "\n") + } + + call close (fd) +end + + +# HDMNAME -- Return the image header parameter name + +procedure hdmname (parameter, str, max_char) + +char parameter[ARB] # Parameter name +char str[max_char] # String containing mapped parameter name +int max_char # Maximum characters in string + +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) + call strcpy (NAME(sym), str, max_char) + else + call strcpy (parameter, str, max_char) +end + + +# HDMPNAME -- Put the image header parameter name + +procedure hdmpname (parameter, str) + +char parameter[ARB] # Parameter name +char str[ARB] # String containing mapped parameter name + +pointer sym, stfind(), stenter() +include "hdrmap.com" + +begin + if (stp == NULL) + return + + sym = stfind (stp, parameter) + if (sym == NULL) { + sym = stenter (stp, parameter, SYMLEN) + DEFAULT(sym) = EOS + } + + call strcpy (str, NAME(sym), SZ_NAME) +end + + +# HDMGDEF -- Get the default value as a string (null string if none). + +procedure hdmgdef (parameter, str, max_char) + +char parameter[ARB] # Parameter name +char str[max_char] # String containing default value +int max_char # Maximum characters in string + +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) + call strcpy (DEFAULT(sym), str, max_char) + else + str[1] = EOS +end + + +# HDMPDEF -- PUt the default value as a string. + +procedure hdmpdef (parameter, str) + +char parameter[ARB] # Parameter name +char str[ARB] # String containing default value + +pointer sym, stfind(), stenter() +include "hdrmap.com" + +begin + if (stp == NULL) + return + + sym = stfind (stp, parameter) + if (sym == NULL) { + sym = stenter (stp, parameter, SYMLEN) + call strcpy (parameter, NAME(sym), SZ_NAME) + } + + call strcpy (str, DEFAULT(sym), SZ_DEFAULT) +end + + +# HDMACCF -- Return whether the image header parameter exists (regardless of +# whether there is a default value). + +int procedure hdmaccf (im, parameter) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name + +int imaccf() +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) + return (imaccf (im, NAME(sym))) + else + return (imaccf (im, parameter)) +end + + +# HDMGSTR -- Get a string valued parameter. Return default value if not in +# the image header. Return null string if no default or image value. + +procedure hdmgstr (im, parameter, str, max_char) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name +char str[max_char] # String value to return +int max_char # Maximum characters in returned string + +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) { + iferr (call imgstr (im, NAME(sym), str, max_char)) + call strcpy (DEFAULT(sym), str, max_char) + } else { + iferr (call imgstr (im, parameter, str, max_char)) + str[1] = EOS + } +end + + +# HDMGETR -- Get a real valued parameter. Return default value if not in +# the image header. Return error condition if no default or image value. + +real procedure hdmgetr (im, parameter) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name + +int ip, ctor() +real value, imgetr() +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) { + iferr (value = imgetr (im, NAME(sym))) { + ip = 1 + if (ctor (DEFAULT(sym), ip, value) == 0) + call error (0, "HDMGETR: No value found") + } + } else + value = imgetr (im, parameter) + + return (value) +end + + +# HDMGETI -- Get an integer valued parameter. Return default value if not in +# the image header. Return error condition if no default or image value. + +int procedure hdmgeti (im, parameter) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name + +int ip, ctoi() +int value, imgeti() +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) { + iferr (value = imgeti (im, NAME(sym))) { + ip = 1 + if (ctoi (DEFAULT(sym), ip, value) == 0) + call error (0, "HDMGETI: No value found") + } + } else + value = imgeti (im, parameter) + + return (value) +end + + +# HDMPSTR -- Put a string valued parameter in the image header. + +procedure hdmpstr (im, parameter, str) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name +char str[ARB] # String value + +int imaccf(), imgftype() +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) { + if (imaccf (im, NAME(sym)) == YES) + if (imgftype (im, NAME(sym)) != TY_CHAR) + call imdelf (im, NAME(sym)) + call imastr (im, NAME(sym), str) + } else { + if (imaccf (im, parameter) == YES) + if (imgftype (im, parameter) != TY_CHAR) + call imdelf (im, parameter) + call imastr (im, parameter, str) + } +end + + +# HDMPUTI -- Put an integer valued parameter in the image header. + +procedure hdmputi (im, parameter, value) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name +int value # Integer value to put + +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) + call imaddi (im, NAME(sym), value) + else + call imaddi (im, parameter, value) +end + + +# HDMPUTR -- Put a real valued parameter in the image header. + +procedure hdmputr (im, parameter, value) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name +real value # Real value to put + +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) + call imaddr (im, NAME(sym), value) + else + call imaddr (im, parameter, value) +end + + +# HDMGSTP -- Get the symbol table pointer to save a translation map. +# The symbol table is restored with HDMPSTP. + +procedure hdmgstp (ptr) + +pointer ptr # Symbol table pointer to return + +include "hdrmap.com" + +begin + ptr = stp +end + + +# HDMPSTP -- Put a symbol table pointer to restore a header map. +# The symbol table is optained with HDMGSTP. + +procedure hdmpstp (ptr) + +pointer ptr # Symbol table pointer to restore + +include "hdrmap.com" + +begin + stp = ptr +end + + +# HDMDELF -- Delete a field. It is an error if the field does not exist. + +procedure hdmdelf (im, parameter) + +pointer im # IMIO pointer +char parameter[ARB] # Parameter name + +pointer sym, stfind() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = stfind (stp, parameter) + else + sym = NULL + + if (sym != NULL) + call imdelf (im, NAME(sym)) + else + call imdelf (im, parameter) +end + + +# HDMPARAM -- Get parameter given the image header name. + +procedure hdmparam (name, parameter, max_char) + +char name[ARB] # Image header name +char parameter[max_char] # Parameter +int max_char # Maximum size of parameter string + +bool streq() +pointer sym, sthead(), stname(), stnext() +include "hdrmap.com" + +begin + if (stp != NULL) + sym = sthead (stp) + else + sym = NULL + + while (sym != NULL) { + if (streq (NAME(sym), name)) { + call strcpy (Memc[stname(stp, sym)], parameter, max_char) + return + } + sym = stnext (stp, sym) + } + call strcpy (name, parameter, max_char) +end diff --git a/noao/imred/ccdred/src/icaclip.gx b/noao/imred/ccdred/src/icaclip.gx new file mode 100644 index 00000000..bb592542 --- /dev/null +++ b/noao/imred/ccdred/src/icaclip.gx @@ -0,0 +1,573 @@ +# 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 (sr) +# 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 + 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/icaverage.gx b/noao/imred/ccdred/src/icaverage.gx new file mode 100644 index 00000000..c145bb33 --- /dev/null +++ b/noao/imred/ccdred/src/icaverage.gx @@ -0,0 +1,93 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +$for (sr) +# IC_AVERAGE -- Compute the average image line. +# Options include a weight average. + +procedure ic_average$t (d, m, n, wts, npts, 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 +$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 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 to the blank value. + + 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] + average[i] = sum / n[i] + } + } + } else if (dflag == D_NONE) { + 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 + } + average[i] = sum / sumwt + } else + 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] + average[i] = sum / n[i] + } else + average[i] = blank + } + } + } +end +$endfor diff --git a/noao/imred/ccdred/src/iccclip.gx b/noao/imred/ccdred/src/iccclip.gx new file mode 100644 index 00000000..69df984c --- /dev/null +++ b/noao/imred/ccdred/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 (sr) +# 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/icgdata.gx b/noao/imred/ccdred/src/icgdata.gx new file mode 100644 index 00000000..41cf5810 --- /dev/null +++ b/noao/imred/ccdred/src/icgdata.gx @@ -0,0 +1,233 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <mach.h> +include "../icombine.h" + +$for (sr) +# 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 keeped 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 for nonaligned images +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, ndim, nused +real a, b +pointer buf, dp, ip, mp, 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) + return + + # Get data and fill data buffers. Correct for offsets if needed. + ndim = IM_NDIM(out[1]) + do i = 1, nimages { + if (lflag[i] == D_NONE) + next + if (aligned) { + call amovl (v1, v2, IM_MAXDIM) + if (project) + v2[ndim+1] = i + j = imgnl$t (in[i], d[i], v2) + } else { + v2[1] = v1[1] + do j = 2, ndim + v2[j] = v1[j] - offsets[i,j] + if (project) + v2[ndim+1] = i + j = imgnl$t (in[i], buf, v2) + call amov$t (Mem$t[buf], Mem$t[dbuf[i]+offsets[i,1]], + IM_LEN(in[i],1)) + d[i] = dbuf[i] + } + } + + # Apply threshold if needed + if (dothresh) { + do i = 1, nimages { + dp = d[i] + if (lflag[i] == D_ALL) { + 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 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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 + 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 + } + } + } + } + + # 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 { + dp = d[i] + a = scales[i] + b = -zeros[i] + if (lflag[i] == D_ALL) { + do j = 1, npts { + Mem$t[dp] = Mem$t[dp] / a + b + dp = dp + 1 + } + } else if (lflag[i] == D_MIX) { + mp = m[i] + do j = 1, npts { + 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] + dp = d[i] + ip = id[i] + mp = m[i] + do j = 1, npts { + 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 > 0) { + do j = 1, npts { + do i = n[j]+1, nimages + Memi[id[i]+j-1] = 0 + } + } + } else { + do i = 1, nused { + dp = d[i] + mp = m[i] + do j = 1, npts { + 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/imred/ccdred/src/icgrow.gx b/noao/imred/ccdred/src/icgrow.gx new file mode 100644 index 00000000..e3cf6228 --- /dev/null +++ b/noao/imred/ccdred/src/icgrow.gx @@ -0,0 +1,81 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sr) +# IC_GROW -- Reject neigbors of rejected pixels. +# The rejected pixels are marked by having nonzero ids beyond the number +# of included pixels. The pixels rejected here are given zero ids +# to avoid growing of the pixels rejected here. The unweighted average +# can be updated but any rejected pixels requires the median to be +# recomputed. When the number of pixels at a grow point reaches nkeep +# no further pixels are rejected. Note that the rejection order is not +# based on the magnitude of the residuals and so a grow from a weakly +# rejected image pixel may take precedence over a grow from a strongly +# rejected image pixel. + +procedure ic_grow$t (d, m, n, nimages, npts, average) + +pointer d[ARB] # Data pointers +pointer m[ARB] # Image id pointers +int n[npts] # Number of good pixels +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 i1, i2, j1, j2, k1, k2, l, is, ie, n2, maxkeep +pointer mp1, mp2 + +include "../icombine.com" + +begin + if (dflag == D_NONE) + return + + do i1 = 1, npts { + k1 = i1 - 1 + is = max (1, i1 - grow) + ie = min (npts, i1 + grow) + do j1 = n[i1]+1, nimages { + l = Memi[m[j1]+k1] + if (l == 0) + next + if (combine == MEDIAN) + docombine = true + + do i2 = is, ie { + if (i2 == i1) + next + k2 = i2 - 1 + n2 = n[i2] + if (nkeep < 0) + maxkeep = max (0, n2 + nkeep) + else + maxkeep = min (n2, nkeep) + if (n2 <= maxkeep) + next + do j2 = 1, n2 { + mp1 = m[j2] + k2 + if (Memi[mp1] == l) { + if (!docombine && n2 > 1) + average[i2] = + (n2*average[i2] - Mem$t[d[j2]+k2]) / (n2-1) + mp2 = m[n2] + k2 + if (j2 < n2) { + Mem$t[d[j2]+k2] = Mem$t[d[n2]+k2] + Memi[mp1] = Memi[mp2] + } + Memi[mp2] = 0 + n[i2] = n2 - 1 + break + } + } + } + } + } +end +$endfor diff --git a/noao/imred/ccdred/src/icimstack.x b/noao/imred/ccdred/src/icimstack.x new file mode 100644 index 00000000..2a19751d --- /dev/null +++ b/noao/imred/ccdred/src/icimstack.x @@ -0,0 +1,125 @@ +# 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 (images, nimages, output) + +char images[SZ_FNAME-1, nimages] #I Input images +int nimages #I Number of images +char output #I Name of output image + +int i, j, npix +long line_in[IM_MAXDIM], line_out[IM_MAXDIM] +pointer sp, key, in, out, buf_in, buf_out, ptr + +int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() +int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() +pointer immap() +errchk immap + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + + iferr { + # Add each input image to the output image. + out = NULL + do i = 1, nimages { + in = NULL + ptr = immap (images[1,i], 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)) = nimages + npix = IM_LEN(out, 1) + call amovkl (long(1), line_out, 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], images[1,i]) + + # 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) + } + } + call imunmap (in) + } + } then { + if (out != NULL) { + call imunmap (out) + call imdelete (out) + } + if (in != NULL) + call imunmap (in) + call sfree (sp) + call erract (EA_ERROR) + } + + # Finish up. + call imunmap (out) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/iclog.x b/noao/imred/ccdred/src/iclog.x new file mode 100644 index 00000000..82135866 --- /dev/null +++ b/noao/imred/ccdred/src/iclog.x @@ -0,0 +1,378 @@ +# 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, expname, exposure) + +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 +char expname[ARB] # Exposure name +real exposure # Output exposure + +int i, j, stack, ctor() +real rval, imgetr() +long clktime() +bool prncombine, prexptime, prmode, prmedian, prmean, prmask +bool prrdn, prgain, prsn +pointer sp, fname, key +errchk imgetr + +include "icombine.com" + +begin + if (logfd == NULL) + return + + call smark (sp) + call salloc (fname, 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: IMCOMBINE\n") + call pargstr (Memc[fname]) + switch (combine) { + case AVERAGE: + call fprintf (logfd, " combine = average, ") + case MEDIAN: + call fprintf (logfd, " combine = median, ") + } + 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 > 0) { + call fprintf (logfd, " grow = %d\n") + call pargi (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) + call clgstr ("statsec", Memc[fname], SZ_LINE) + if (Memc[fname] != 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 && Memi[ICM_PMS(icm)+i-1] != NULL) + 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 { + 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 && Memi[ICM_PMS(icm)+i-1] != NULL) { + call imgstr (in[i], "BPM", Memc[fname], SZ_LINE) + call fprintf (logfd, " %s") + call pargstr (Memc[fname]) + } + 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) + if (expname[1] != EOS) { + call fprintf (logfd, ", %s = %g") + call pargstr (expname) + call pargr (exposure) + } + call fprintf (logfd, "\n") + + if (out[2] != NULL) { + call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE) + call fprintf (logfd, " Pixel list image = %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/imred/ccdred/src/icmask.com b/noao/imred/ccdred/src/icmask.com new file mode 100644 index 00000000..baba6f6a --- /dev/null +++ b/noao/imred/ccdred/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/imred/ccdred/src/icmask.h b/noao/imred/ccdred/src/icmask.h new file mode 100644 index 00000000..b2d30530 --- /dev/null +++ b/noao/imred/ccdred/src/icmask.h @@ -0,0 +1,7 @@ +# ICMASK -- Data structure for IMCOMBINE mask interface. + +define ICM_LEN 4 # 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 diff --git a/noao/imred/ccdred/src/icmask.x b/noao/imred/ccdred/src/icmask.x new file mode 100644 index 00000000..ba448b68 --- /dev/null +++ b/noao/imred/ccdred/src/icmask.x @@ -0,0 +1,354 @@ +include <imhdr.h> +include <pmset.h> +include "icombine.h" +include "icmask.h" + +# IC_MASK -- ICOMBINE mask interface +# +# IC_MOPEN -- Open masks +# 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_MOPEN -- Open masks. +# Parse and interpret the mask selection parameters. + +procedure ic_mopen (in, out, nimages) + +pointer in[nimages] #I Input images +pointer out[ARB] #I Output images +int nimages #I 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 + +int i, npix, npms, clgwrd() +real clgetr() +pointer sp, fname, title, pm, pm_open() +bool invert, pm_empty() +errchk calloc, pm_open, pm_loadf + +include "icombine.com" + +begin + icm = NULL + if (IM_NDIM(out[1]) == 0) + return + + call smark (sp) + call salloc (fname, 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 = clgwrd ("masktype", Memc[title], SZ_FNAME, MASKTYPES) + mvalue = clgetr ("maskvalue") + npix = IM_LEN(out[1],1) + call calloc (pms, nimages, TY_POINTER) + call calloc (bufs, 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. + + npms = 0 + do i = 1, nimages { + if (mtype != M_NONE) { + ifnoerr (call imgstr (in[i], "BPM", Memc[fname], SZ_FNAME)) { + pm = pm_open (NULL) + call pm_loadf (pm, Memc[fname], Memc[title], SZ_FNAME) + call pm_seti (pm, P_REFIM, in[i]) + if (pm_empty (pm) && !invert) + call pm_close (pm) + else { + if (project) { + npms = nimages + call amovki (pm, Memi[pms], nimages) + } else { + npms = npms + 1 + Memi[pms+i-1] = pm + } + } + if (project) + break + } + } + } + + # 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 + + 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_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_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 + +int i, j, ndim, nout, npix +pointer buf, pm +bool pm_linenotempty() +errchk pm_glpi + +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) + + # 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 { + npix = IM_LEN(in[i],1) + j = offsets[i,1] + m[i] = Memi[bufs+i-1] + buf = Memi[bufs+i-1] + j + pm = Memi[pms+i-1] + if (npix == nout) + lflag[i] = D_ALL + else + lflag[i] = D_MIX + + v2[1] = v1[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) + next + + if (pm == NULL) { + call aclri (Memi[buf], npix) + next + } + + # Do mask I/O and convert to appropriate values in order of + # expected usage. + + 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, offset, v, m) + +pointer in # Input image pointer +int image # Image index +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 + +int i, npix +pointer buf, pm +bool pm_linenotempty() +errchk pm_glpi + +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) + + npix = IM_LEN(in,1) + m = Memi[bufs+image-1] + offset + pm = Memi[pms+image-1] + if (pm == NULL) + return + + # 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 diff --git a/noao/imred/ccdred/src/icmedian.gx b/noao/imred/ccdred/src/icmedian.gx new file mode 100644 index 00000000..dc8488d9 --- /dev/null +++ b/noao/imred/ccdred/src/icmedian.gx @@ -0,0 +1,228 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sr) +# IC_MEDIAN -- Median of lines + +procedure ic_median$t (d, n, npts, median) + +pointer d[ARB] # Input data line pointers +int n[npts] # Number of good pixels +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, 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) { + 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 + 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 + median[i] = blank + } +end +$endfor diff --git a/noao/imred/ccdred/src/icmm.gx b/noao/imred/ccdred/src/icmm.gx new file mode 100644 index 00000000..90837ae5 --- /dev/null +++ b/noao/imred/ccdred/src/icmm.gx @@ -0,0 +1,177 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include "../icombine.h" + +$for (sr) +# 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 + Memi[m[jmax]+i1] = Memi[m[j]+i1] + } else { + Mem$t[kmax] = d1 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } + if (jmin < j) { + if (jmax != n1) { + Mem$t[kmin] = d1 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } else { + Mem$t[kmin] = d2 + Memi[m[jmin]+i1] = Memi[m[j]+i1] + } + } + } 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 + Memi[m[jmin]+i1] = Memi[m[n1]+i1] + } + } 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 + Memi[m[jmax]+i1] = Memi[m[n1]+i1] + } + } 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/imred/ccdred/src/icombine.com b/noao/imred/ccdred/src/icombine.com new file mode 100644 index 00000000..cb826d58 --- /dev/null +++ b/noao/imred/ccdred/src/icombine.com @@ -0,0 +1,40 @@ +# ICOMBINE Common + +int combine # Combine algorithm +int reject # Rejection algorithm +bool project # Combine across the highest dimension? +real blank # Blank value +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 +int 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? + +pointer icm # Mask data structure + +common /imccom/ combine, reject, blank, 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, icm diff --git a/noao/imred/ccdred/src/icombine.gx b/noao/imred/ccdred/src/icombine.gx new file mode 100644 index 00000000..d6e93ef0 --- /dev/null +++ b/noao/imred/ccdred/src/icombine.gx @@ -0,0 +1,395 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "../icombine.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 (sr) +procedure icombine$t (in, out, offsets, nimages, bufsize) + +pointer in[nimages] # Input images +pointer out[ARB] # Output images +int offsets[nimages,ARB] # Input image offsets +int nimages # Number of input images +int bufsize # IMIO buffer size + +char str[1] +int i, j, npts, fd, stropen(), errcode(), imstati() +pointer sp, d, id, n, m, lflag, scales, zeros, wts, dbuf +pointer buf, imgl1$t(), impl1i() +errchk stropen, imgl1$t, impl1i +$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 (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 (scales, nimages, TY_REAL) + call salloc (zeros, nimages, TY_REAL) + call salloc (wts, nimages, TY_REAL) + call amovki (D_ALL, Memi[lflag], nimages) + + # If aligned use the IMIO buffer otherwise we need vectors of + # output length. + + if (!aligned) { + call salloc (dbuf, nimages, TY_POINTER) + do i = 1, nimages + call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) + } + + if (project) { + call imseti (in[1], IM_NBUFS, nimages) + call imseti (in[1], IM_BUFSIZE, bufsize) + do i = 1, 3 { + if (out[i] != NULL) + 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, 3 { + if (out[i] != NULL) + 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) + } + + do i = 1, nimages { + call imseti (in[i], IM_BUFSIZE, bufsize) + iferr (buf = imgl1$t (in[i])) { + switch (errcode()) { + case SYS_MFULL: + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (imstati (in[i], IM_CLOSEFD) == YES) { + call sfree (sp) + call strclose (fd) + call erract (EA_ERROR) + } + do j = i-2, nimages + call imseti (in[j], IM_CLOSEFD, YES) + buf = imgl1$t (in[i]) + default: + 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, Memr[scales], Memr[zeros], + Memr[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, ctor() +real r, imgetr() +pointer sp, v1, v2, v3, outdata, buf, nm, impnli() +$if (datatype == sil) +pointer impnlr() +$else +pointer impnl$t() +$endif +errchk ic_scale, imgetr + +include "../icombine.com" + +begin + call smark (sp) + 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 || grow > 0) + 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 + if (grow > 0) + keepids = true + case PCLIP: + mclip = true + if (grow > 0) + keepids = true + case AVSIGCLIP, SIGCLIP: + if (doscale1 || grow > 0) + keepids = true + case NONE: + mclip = false + grow = 0 + } + + 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 (grow > 0) + call ic_grow$t (d, id, n, nimages, npts, Memr[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, Memr[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, Memr[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + 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 (grow > 0) + call ic_grow$t (d, id, n, nimages, npts, Mem$t[outdata]) + + if (docombine) { + switch (combine) { + case AVERAGE: + call ic_average$t (d, id, n, wts, npts, Mem$t[outdata]) + case MEDIAN: + call ic_median$t (d, n, npts, Mem$t[outdata]) + } + } + + if (out[2] != NULL) { + call amovl (Meml[v2], Meml[v1], IM_MAXDIM) + i = impnli (out[2], buf, Meml[v1]) + call amovki (nimages, Memi[buf], npts) + call asubi (Memi[buf], n, Memi[buf], npts) + } + + 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]) + } + call amovl (Meml[v1], Meml[v2], IM_MAXDIM) + } + $endif + + call sfree (sp) +end +$endfor diff --git a/noao/imred/ccdred/src/icombine.h b/noao/imred/ccdred/src/icombine.h new file mode 100644 index 00000000..13b77117 --- /dev/null +++ b/noao/imred/ccdred/src/icombine.h @@ -0,0 +1,52 @@ +# ICOMBINE Definitions + +# Memory management parameters; +define DEFBUFSIZE 65536 # default IMIO buffer size +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|" +define AVERAGE 1 +define MEDIAN 2 + +# 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/imred/ccdred/src/icpclip.gx b/noao/imred/ccdred/src/icpclip.gx new file mode 100644 index 00000000..223396c3 --- /dev/null +++ b/noao/imred/ccdred/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 (sr) +# 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/icscale.x b/noao/imred/ccdred/src/icscale.x new file mode 100644 index 00000000..fc4efb2f --- /dev/null +++ b/noao/imred/ccdred/src/icscale.x @@ -0,0 +1,376 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include <imset.h> +include <error.h> +include "icombine.h" + +# IC_SCALE -- Get the scale factors for the images. +# 1. This procedure does CLIO to determine the type of scaling desired. +# 2. The output header parameters for exposure time and NCOMBINE are set. + +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, exposure, zmean, darktime, dark +pointer sp, ncombine, exptime, modes, medians, means +pointer section, str, sname, zname, wname, imref +bool domode, domedian, domean, dozero, snorm, znorm, wflag + +bool clgetb() +int hdmgeti(), strdic(), ic_gscale() +real hdmgetr(), asumr(), asumi() +errchk ic_gscale, 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_FNAME, 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) + + # Set the defaults. + call amovki (1, Memi[ncombine], nimages) + call amovkr (0., Memr[exptime], nimages) + call amovkr (INDEF, Memr[modes], nimages) + call amovkr (INDEF, Memr[medians], nimages) + call amovkr (INDEF, Memr[means], nimages) + call amovkr (1., scales, nimages) + call amovkr (0., zeros, nimages) + call amovkr (1., wts, nimages) + + # 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] = hdmgeti (in[i], "ncombine")) + Memi[ncombine+i-1] = 1 + iferr (Memr[exptime+i-1] = hdmgetr (in[i], "exptime")) + Memr[exptime+i-1] = 0. + if (project) { + call amovki (Memi[ncombine], Memi[ncombine], nimages) + call amovkr (Memr[exptime], Memr[exptime], nimages) + break + } + } + + # Set scaling 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 only if needed. + 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)) + if (domode || domedian || domean) { + Memc[section] = EOS + Memc[str] = EOS + call clgstr ("statsec", Memc[section], SZ_FNAME) + call sscan (Memc[section]) + 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 { + if (imref != out[1]) + imref = in[i] + call ic_statr (in[i], imref, Memc[section], offsets, + i, nimages, domode, domedian, domean, mode, median, mean) + if (domode) { + Memr[modes+i-1] = mode + if (stype == S_MODE) + scales[i] = mode + if (ztype == S_MODE) + zeros[i] = mode + if (wtype == S_MODE) + wts[i] = mode + } + if (domedian) { + Memr[medians+i-1] = median + if (stype == S_MEDIAN) + scales[i] = median + if (ztype == S_MEDIAN) + zeros[i] = median + if (wtype == S_MEDIAN) + wts[i] = median + } + if (domean) { + Memr[means+i-1] = mean + if (stype == S_MEAN) + scales[i] = mean + if (ztype == S_MEAN) + zeros[i] = mean + if (wtype == S_MEAN) + wts[i] = mean + } + } + } + + 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 relative factors if needed. + 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) + else { + mean = asumr (scales, nimages) / nimages + call adivkr (scales, mean, scales, nimages) + } + call adivr (zeros, scales, zeros, nimages) + zmean = asumr (zeros, nimages) / 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] * zmean / 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. + + call asubkr (zeros, zmean, 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) + call adivkr (wts, mean, wts, nimages) + + # 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 + } + } + if (!doscale1 && zmean > 0.) { + do i = 1, nimages { + if (abs (zeros[i] / zmean) > sigscale) { + doscale1 = true + break + } + } + } + } + + # Set the output header parameters. + nout = asumi (Memi[ncombine], nimages) + call hdmputi (out[1], "ncombine", nout) + exposure = 0. + darktime = 0. + mean = 0. + do i = 1, nimages { + exposure = exposure + wts[i] * Memr[exptime+i-1] / scales[i] + ifnoerr (dark = hdmgetr (in[i], "darktime")) + darktime = darktime + wts[i] * dark / scales[i] + else + darktime = darktime + wts[i] * Memr[exptime+i-1] / scales[i] + ifnoerr (mode = hdmgetr (in[i], "ccdmean")) + mean = mean + wts[i] * mode / scales[i] + } + call hdmputr (out[1], "exptime", exposure) + call hdmputr (out[1], "darktime", darktime) + ifnoerr (mode = hdmgetr (out[1], "ccdmean")) { + call hdmputr (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 (clgetb ("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, "", exposure) + + 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, + "", exposure) + + doscale = (doscale || dozero) + + call sfree (sp) +end + + +# IC_GSCALE -- Get scale values as directed by CL parameter +# 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, hdmgetr() +pointer errstr +errchk open, hdmgetr() + +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 + 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 + values[i] = rval + } + call close (fd) + if (i < nimages) { + call salloc (errstr, SZ_LINE, TY_CHAR) + call sprintf (Memc[errstr], SZ_FNAME, + "Insufficient %s values in %s") + call pargstr (param) + call pargstr (name[2]) + call error (1, Memc[errstr]) + } + } else if (name[1] == '!') { + type = S_KEYWORD + do i = 1, nimages { + values[i] = hdmgetr (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 + values[i] = max (0.001, exptime[i]) + } + + return (type) +end diff --git a/noao/imred/ccdred/src/icsclip.gx b/noao/imred/ccdred/src/icsclip.gx new file mode 100644 index 00000000..f70611aa --- /dev/null +++ b/noao/imred/ccdred/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 (sr) +# 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 > 0)) { + 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 > 0) { + 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/imred/ccdred/src/icsection.x b/noao/imred/ccdred/src/icsection.x new file mode 100644 index 00000000..746c1f51 --- /dev/null +++ b/noao/imred/ccdred/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/imred/ccdred/src/icsetout.x b/noao/imred/ccdred/src/icsetout.x new file mode 100644 index 00000000..bd1d75ec --- /dev/null +++ b/noao/imred/ccdred/src/icsetout.x @@ -0,0 +1,193 @@ +include <imhdr.h> +include <mwset.h> + +# 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 +real val +bool reloff, streq() +pointer sp, fname, lref, wref, cd, coord, shift, axno, axval +pointer mw, ct, mw_openim(), mw_sctran() +int open(), fscan(), nscan(), mw_stati() +errchk mw_openim, mw_gwtermd, mw_gltermd, mw_gaxmap +errchk mw_sctran, mw_ctrand, open + +include "icombine.com" +define newscan_ 10 + +begin + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + 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]) + if (project) { + outdim = indim - 1 + IM_NDIM(out[1]) = outdim + } else { + 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]) + 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 (project) + Memd[lref+outdim] = 1 + + # Parse the user offset string. If "none" then there are no offsets. + # If "wcs" then set the offsets based on the image 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 || streq (Memc[fname], "none")) { + call aclri (offsets, outdim*nimages) + reloff = true + } else if (streq (Memc[fname], "wcs")) { + do j = 1, outdim + offsets[1,j] = 0 + if (project) { + 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 { + 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 + } else if (streq (Memc[fname], "grid")) { + amin = 1 + do j = 1, outdim { + call gargi (a) + call gargi (b) + if (nscan() < 1+2*j) + break + do i = 1, nimages + offsets[i,j] = mod ((i-1)/amin, a) * b + amin = amin * a + } + reloff = true + } else { + 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 + } + } + + # Update the WCS. + if (project || !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] + } + call mw_sltermd (mw, Memd[cd], Memd[lref], mwdim) + } + if (project) { + # 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) + } + call mw_saveim (mw, out) + } + call mw_close (mw) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/icsigma.gx b/noao/imred/ccdred/src/icsigma.gx new file mode 100644 index 00000000..d0ae28d4 --- /dev/null +++ b/noao/imred/ccdred/src/icsigma.gx @@ -0,0 +1,115 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +$for (sr) +# 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 + } + sigma[i] = sqrt (sum / sumwt * 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/imred/ccdred/src/icsort.gx b/noao/imred/ccdred/src/icsort.gx new file mode 100644 index 00000000..2235dbd0 --- /dev/null +++ b/noao/imred/ccdred/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 (sr) +# 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/imred/ccdred/src/icstat.gx b/noao/imred/ccdred/src/icstat.gx new file mode 100644 index 00000000..099ddf5e --- /dev/null +++ b/noao/imred/ccdred/src/icstat.gx @@ -0,0 +1,237 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "../icombine.h" + +define NMAX 10000 # Maximum number of pixels to sample + +$for (sr) +# 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() +PIXEL ic_mode$t() +$if (datatype == irs) +real asum$t() +$endif +$if (datatype == dl) +double asum$t() +$endif +$if (datatype == x) +complex asum$t() +$endif + + +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, 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) + } + + 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.8 # 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/imred/ccdred/src/mkpkg b/noao/imred/ccdred/src/mkpkg new file mode 100644 index 00000000..d2d46598 --- /dev/null +++ b/noao/imred/ccdred/src/mkpkg @@ -0,0 +1,75 @@ +# Make CCDRED Package. + +$checkout libpkg.a .. +$update libpkg.a +$checkin libpkg.a .. +$exit + +generic: + $set GEN = "$$generic -k" + + $ifolder (generic/ccdred.h, ccdred.h) + $copy ccdred.h generic/ccdred.h $endif + $ifolder (generic/proc.x, proc.gx) + $(GEN) proc.gx -o generic/proc.x $endif + $ifolder (generic/cor.x, cor.gx) + $(GEN) cor.gx -o generic/cor.x $endif + ; + +libpkg.a: + $ifeq (USE_GENERIC, yes) $call generic $endif + @generic + + @combine + + calimage.x ccdtypes.h <error.h> <imset.h> + ccdcache.x ccdcache.com ccdcache.h ccdcache.com <imhdr.h>\ + <imset.h> <mach.h> + ccdcheck.x ccdtypes.h <imhdr.h> + ccdcmp.x + ccdcopy.x <imhdr.h> + ccddelete.x + ccdflag.x + ccdlog.x <imhdr.h> <imset.h> + ccdmean.x <imhdr.h> + ccdnscan.x ccdtypes.h + ccdproc.x ccdred.h ccdtypes.h <error.h> + ccdsection.x <ctype.h> + ccdsubsets.x <ctype.h> + ccdtypes.x ccdtypes.h + doproc.x ccdred.h + hdrmap.x hdrmap.com <error.h> <syserr.h> + readcor.x <imhdr.h> + scancor.x <imhdr.h> <imset.h> + setdark.x ccdred.h ccdtypes.h <imhdr.h> + setfixpix.x ccdred.h <imhdr.h> <imset.h> <pmset.h> + setflat.x ccdred.h ccdtypes.h <imhdr.h> + setfringe.x ccdred.h ccdtypes.h <imhdr.h> + setheader.x ccdred.h <imhdr.h> + setillum.x ccdred.h ccdtypes.h <imhdr.h> + setinput.x ccdtypes.h <error.h> + setinteract.x <pkg/xtanswer.h> + setoutput.x <imhdr.h> <imset.h> + setoverscan.x ccdred.h <imhdr.h> <imset.h> <pkg/xtanswer.h>\ + <pkg/gtools.h> + setproc.x ccdred.h <imhdr.h> + setsections.x ccdred.h <imhdr.h> <mwset.h> + settrim.x ccdred.h <imhdr.h> <imset.h> + setzero.x ccdred.h ccdtypes.h <imhdr.h> + t_badpixim.x <imhdr.h> + t_ccdgroups.x <error.h> <math.h> + t_ccdhedit.x <error.h> + t_ccdinst.x ccdtypes.h <error.h> <imhdr.h> <imio.h> + t_ccdlist.x ccdtypes.h <error.h> <imhdr.h> + t_ccdmask.x <imhdr.h> + t_ccdproc.x ccdred.h ccdtypes.h <error.h> <imhdr.h> + t_combine.x ccdred.h combine/icombine.com combine/icombine.h\ + <error.h> <imhdr.h> <mach.h> <syserr.h> + t_mkfringe.x ccdred.h <imhdr.h> + t_mkillumcor.x ccdred.h + t_mkillumft.x ccdred.h <imhdr.h> + t_mkskycor.x ccdred.h <mach.h> <imhdr.h> <imset.h> + t_mkskyflat.x ccdred.h ccdtypes.h <imhdr.h> + t_skyreplace.x <imhdr.h> + timelog.x <time.h> + ; diff --git a/noao/imred/ccdred/src/proc.gx b/noao/imred/ccdred/src/proc.gx new file mode 100644 index 00000000..3161d2e6 --- /dev/null +++ b/noao/imred/ccdred/src/proc.gx @@ -0,0 +1,408 @@ +include <imhdr.h> +include "ccdred.h" + + +.help proc Feb87 noao.imred.ccdred +.nf ---------------------------------------------------------------------------- +proc -- Process CCD images + +These are the main CCD reduction procedures. There is one for each +readout axis (lines or columns) and one for short and real image data. +They apply corrections for bad pixels, overscan levels, zero levels, +dark counts, flat field response, illumination response, and fringe +effects. The image is also trimmed if it was mapped with an image +section. The mean value for the output image is computed when the flat +field or illumination image is processed to form the scale factor for +these calibrations in order to avoid reading through these image a +second time. + +The processing information and parameters are specified in the CCD +structure. The processing operations to be performed are specified by +the correction array CORS in the ccd structure. There is one array +element for each operation with indices defined symbolically by macro +definitions (see ccdred.h); i.e. FLATCOR. The value of the array +element is an integer bit field in which the bit set is the same as the +array index; i.e element 3 will have the third bit set for an operation +with array value 2**(3-1)=4. If an operation is not to be performed +the bit is not set and the array element has the numeric value zero. +Note that the addition of several correction elements gives a unique +bit field describing a combination of operations. For efficiency the +most common combinations are implemented as separate units. + +The CCD structure also contains the correction or calibration data +consisting either pointers to data, IMIO pointers for the calibration +images, and scale factors. + +The processing is performed line-by-line. The procedure CORINPUT is +called to get an input line. This procedure trims and fixes bad pixels by +interpolation. The output line and lines from the various calibration +images are read. The image vectors as well as the overscan vector and +the scale factors are passed to the procedure COR (which also +dereferences the pointer data into simple arrays and variables). That +procedure does the actual corrections apart from bad pixel +corrections. + +The final optional step is to add each corrected output line to form a +mean. This adds efficiency since the operation is done only if desired +and the output image data is already in memory so there is no I/O +penalty. + +SEE ALSO + ccdred.h, cor, fixpix, setfixpix, setoverscan, settrim, + setzero, setdark, setflat, setillum, setfringe +.endhelp ---------------------------------------------------------------------- + + +$for (sr) +# PROC1 -- Process CCD images with readout axis 1 (lines). + +procedure proc1$t (ccd) + +pointer ccd # CCD structure + +int line, ncols, nlines, findmean, rep +int overscan_type, overscan_c1, noverscan +real overscan, darkscale, flatscale, illumscale, frgscale, mean +PIXEL minrep +pointer in, out, zeroim, darkim, flatim, illumim, fringeim, overscan_vec +pointer inbuf, outbuf, zerobuf, darkbuf, flatbuf, illumbuf, fringebuf + +$if (datatype == csir) +real asum$t() +$else $if (datatype == ld) +double asum$t() +$else +PIXEL asum$t() +$endif $endif +real find_overscan$t() +pointer imgl2$t(), impl2$t(), ccd_gl$t(), xt_fps$t() + +begin + # Initialize. If the correction image is 1D then just get the + # data once. + + in = IN_IM(ccd) + out = OUT_IM(ccd) + ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 + nlines = OUT_L2(ccd) - OUT_L1(ccd) + 1 + + findmean = CORS(ccd, FINDMEAN) + if (findmean == YES) + mean = 0. + rep = CORS(ccd, MINREP) + if (rep == YES) + minrep = MINREPLACE(ccd) + + if (CORS(ccd, OVERSCAN) == 0) + overscan_type = 0 + else { + overscan_type = OVERSCAN_TYPE(ccd) + overscan_vec = OVERSCAN_VEC(ccd) + overscan_c1 = BIAS_C1(ccd) - 1 + noverscan = BIAS_C2(ccd) - overscan_c1 + } + + if (CORS(ccd, ZEROCOR) == 0) { + zeroim = NULL + zerobuf = 1 + } else if (IM_LEN(ZERO_IM(ccd),2) == 1) { + zeroim = NULL + zerobuf = ccd_gl$t (ZERO_IM(ccd), ZERO_C1(ccd), ZERO_C2(ccd), 1) + } else + zeroim = ZERO_IM(ccd) + + if (CORS(ccd, DARKCOR) == 0) { + darkim = NULL + darkbuf = 1 + } else if (IM_LEN(DARK_IM(ccd),2) == 1) { + darkim = NULL + darkbuf = ccd_gl$t (DARK_IM(ccd), DARK_C1(ccd), DARK_C2(ccd), 1) + darkscale = FLATSCALE(ccd) + } else { + darkim = DARK_IM(ccd) + darkscale = DARKSCALE(ccd) + } + + if (CORS(ccd, FLATCOR) == 0) { + flatim = NULL + flatbuf = 1 + } else if (IM_LEN(FLAT_IM(ccd),2) == 1) { + flatim = NULL + flatbuf = ccd_gl$t (FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), 1) + flatscale = FLATSCALE(ccd) + } else { + flatim = FLAT_IM(ccd) + flatscale = FLATSCALE(ccd) + } + + if (CORS(ccd, ILLUMCOR) == 0) { + illumim = NULL + illumbuf = 1 + } else { + illumim = ILLUM_IM(ccd) + illumscale = ILLUMSCALE(ccd) + } + + if (CORS(ccd, FRINGECOR) == 0) { + fringeim = NULL + fringebuf = 1 + } else { + fringeim = FRINGE_IM(ccd) + frgscale = FRINGESCALE(ccd) + } + + # For each line read lines from the input. Procedure XT_FPS replaces + # bad pixels by interpolation. The trimmed region is copied to the + # output. Get lines from the output image and from the zero level, + # dark count, flat field, illumination, and fringe images. Call COR1 + # to do the actual pixel corrections. Finally, add the output pixels + # to a sum for computing the mean. We must copy data outside of the + # output data section. + + do line = 2 - OUT_L1(ccd), 0 + call amov$t ( + Mem$t[imgl2$t(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mem$t[impl2$t(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + do line = 1, nlines { + outbuf = impl2$t (out, OUT_L1(ccd)+line-1) + + inbuf = xt_fps$t (MASK_FP(ccd), in, IN_L1(ccd)+line-1, IN_C1(ccd), + IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) + call amov$t (Mem$t[inbuf+IN_C1(ccd)-OUT_C1(ccd)], Mem$t[outbuf], + IM_LEN(out,1)) + + outbuf = outbuf + OUT_C1(ccd) - 1 + if (overscan_type != 0) { + if (overscan_type < OVERSCAN_FIT) + overscan = find_overscan$t (Mem$t[inbuf+overscan_c1], + noverscan, overscan_type) + else + overscan = Memr[overscan_vec+line-1] + } + if (zeroim != NULL) + zerobuf = ccd_gl$t (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), + ZERO_L1(ccd)+line-1) + if (darkim != NULL) + darkbuf = ccd_gl$t (darkim, DARK_C1(ccd), DARK_C2(ccd), + DARK_L1(ccd)+line-1) + if (flatim != NULL) + flatbuf = ccd_gl$t (flatim, FLAT_C1(ccd), FLAT_C2(ccd), + FLAT_L1(ccd)+line-1) + if (illumim != NULL) + illumbuf = ccd_gl$t (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), + ILLUM_L1(ccd)+line-1) + if (fringeim != NULL) + fringebuf = ccd_gl$t (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), + FRINGE_L1(ccd)+line-1) + + call cor1$t (CORS(ccd,1), Mem$t[outbuf], + overscan, Mem$t[zerobuf], Mem$t[darkbuf], + Mem$t[flatbuf], Mem$t[illumbuf], Mem$t[fringebuf], ncols, + darkscale, flatscale, illumscale, frgscale) + + if (rep == YES) + call amaxk$t (Mem$t[outbuf], minrep, Mem$t[outbuf], ncols) + if (findmean == YES) + mean = mean + asum$t (Mem$t[outbuf], ncols) + } + + do line = nlines+1, IM_LEN(out,2)-OUT_L1(ccd)+1 + call amov$t ( + Mem$t[imgl2$t(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mem$t[impl2$t(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + # Compute the mean from the sum of the output pixels. + if (findmean == YES) + MEAN(ccd) = mean / ncols / nlines +end + + +# PROC2 -- Process CCD images with readout axis 2 (columns). + +procedure proc2$t (ccd) + +pointer ccd # CCD structure + +int line, ncols, nlines, findmean, rep +real darkscale, flatscale, illumscale, frgscale, mean +PIXEL minrep +pointer in, out, zeroim, darkim, flatim, illumim, fringeim, overscan_vec +pointer inbuf, outbuf, zerobuf, darkbuf, flatbuf, illumbuf, fringebuf + +$if (datatype == csir) +real asum$t() +$else $if (datatype == ld) +double asum$t() +$else +PIXEL asum$t() +$endif $endif +pointer imgl2$t(), impl2$t(), imgs2$t(), ccd_gl$t(), xt_fps$t() + +begin + # Initialize. If the correction image is 1D then just get the + # data once. + + in = IN_IM(ccd) + out = OUT_IM(ccd) + ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 + nlines = OUT_L2(ccd) - OUT_L1(ccd) + 1 + + findmean = CORS(ccd, FINDMEAN) + if (findmean == YES) + mean = 0. + rep = CORS(ccd, MINREP) + if (rep == YES) + minrep = MINREPLACE(ccd) + + overscan_vec = OVERSCAN_VEC(ccd) + + if (CORS(ccd, ZEROCOR) == 0) { + zeroim = NULL + zerobuf = 1 + } else if (IM_LEN(ZERO_IM(ccd),1) == 1) { + zeroim = NULL + zerobuf = imgs2$t (ZERO_IM(ccd), 1, 1, ZERO_L1(ccd), ZERO_L2(ccd)) + } else + zeroim = ZERO_IM(ccd) + + if (CORS(ccd, DARKCOR) == 0) { + darkim = NULL + darkbuf = 1 + } else if (IM_LEN(DARK_IM(ccd),1) == 1) { + darkim = NULL + darkbuf = imgs2$t (DARK_IM(ccd), 1, 1, DARK_L1(ccd), DARK_L2(ccd)) + darkscale = DARKSCALE(ccd) + } else { + darkim = DARK_IM(ccd) + darkscale = DARKSCALE(ccd) + } + + if (CORS(ccd, FLATCOR) == 0) { + flatim = NULL + flatbuf = 1 + } else if (IM_LEN(FLAT_IM(ccd),1) == 1) { + flatim = NULL + flatbuf = imgs2$t (FLAT_IM(ccd), 1, 1, FLAT_L1(ccd), FLAT_L2(ccd)) + flatscale = FLATSCALE(ccd) + } else { + flatim = FLAT_IM(ccd) + flatscale = FLATSCALE(ccd) + } + + if (CORS(ccd, ILLUMCOR) == 0) { + illumim = NULL + illumbuf = 1 + } else { + illumim = ILLUM_IM(ccd) + illumscale = ILLUMSCALE(ccd) + } + + if (CORS(ccd, FRINGECOR) == 0) { + fringeim = NULL + fringebuf = 1 + } else { + fringeim = FRINGE_IM(ccd) + frgscale = FRINGESCALE(ccd) + } + + # For each line read lines from the input. Procedure CORINPUT + # replaces bad pixels by interpolation and applies a trim to the + # input. Get lines from the output image and from the zero level, + # dark count, flat field, illumination, and fringe images. + # Call COR2 to do the actual pixel corrections. Finally, add the + # output pixels to a sum for computing the mean. + # We must copy data outside of the output data section. + + do line = 2 - OUT_L1(ccd), 0 + call amov$t ( + Mem$t[imgl2$t(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mem$t[impl2$t(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + do line = 1, nlines { + outbuf = impl2$t (out, OUT_L1(ccd)+line-1) + + inbuf = xt_fps$t (MASK_FP(ccd), in, IN_L1(ccd)+line-1, IN_C1(ccd), + IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) + call amov$t (Mem$t[inbuf+IN_C1(ccd)-OUT_C1(ccd)], Mem$t[outbuf], + IM_LEN(out,1)) + + outbuf = outbuf + OUT_C1(ccd) - 1 + if (zeroim != NULL) + zerobuf = ccd_gl$t (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), + ZERO_L1(ccd)+line-1) + if (darkim != NULL) + darkbuf = ccd_gl$t (darkim, DARK_C1(ccd), DARK_C2(ccd), + DARK_L1(ccd)+line-1) + if (flatim != NULL) + flatbuf = ccd_gl$t (flatim, FLAT_C1(ccd), FLAT_C2(ccd), + FLAT_L1(ccd)+line-1) + if (illumim != NULL) + illumbuf = ccd_gl$t (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), + ILLUM_L1(ccd)+line-1) + if (fringeim != NULL) + fringebuf = ccd_gl$t (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), + FRINGE_L1(ccd)+line-1) + + call cor2$t (line, CORS(ccd,1), Mem$t[outbuf], + Memr[overscan_vec], Mem$t[zerobuf], Mem$t[darkbuf], + Mem$t[flatbuf], Mem$t[illumbuf], Mem$t[fringebuf], ncols, + zeroim, flatim, darkscale, flatscale, illumscale, frgscale) + + if (rep == YES) + call amaxk$t (Mem$t[outbuf], minrep, Mem$t[outbuf], ncols) + if (findmean == YES) + mean = mean + asum$t (Mem$t[outbuf], ncols) + } + + do line = nlines+1, IM_LEN(out,2)-OUT_L1(ccd)+1 + call amov$t ( + Mem$t[imgl2$t(in,IN_L1(ccd)+line-1)+IN_C1(ccd)-OUT_C1(ccd)], + Mem$t[impl2$t(out,OUT_L1(ccd)+line-1)], IM_LEN(out,1)) + + # Compute the mean from the sum of the output pixels. + if (findmean == YES) + MEAN(ccd) = mean / ncols / nlines +end + + +# FIND_OVERSCAN -- Find the overscan value for a line. +# No check is made on the number of pixels. +# The median is the (npix+1)/2 element. + +real procedure find_overscan$t (data, npix, type) + +PIXEL data[npix] #I Overscan data +int npix #I Number of overscan points +int type #I Type of overscan calculation + +int i +real overscan, d, dmin, dmax +PIXEL asok$t() + +begin + if (type == OVERSCAN_MINMAX) { + overscan = data[1] + dmin = data[1] + dmax = data[1] + do i = 2, npix { + d = data[i] + overscan = overscan + d + if (d < dmin) + dmin = d + else if (d > dmax) + dmax = d + } + overscan = (overscan - dmin - dmax) / (npix - 2) + } else if (type == OVERSCAN_MEDIAN) + overscan = asok$t (data, npix, (npix + 1) / 2) + else { + overscan = data[1] + do i = 2, npix + overscan = overscan + data[i] + overscan = overscan / npix + } + + return (overscan) +end +$endfor diff --git a/noao/imred/ccdred/src/readcor.x b/noao/imred/ccdred/src/readcor.x new file mode 100644 index 00000000..61fbd836 --- /dev/null +++ b/noao/imred/ccdred/src/readcor.x @@ -0,0 +1,138 @@ +include <imhdr.h> + +# READCOR -- Create a readout image. +# Assume it is appropriate to perform this operation on the input image. +# There is no CCD type checking. + +procedure readcor (input) + +char input[ARB] # Input image +int readaxis # Readout axis + +int i, nc, nl, c1, c2, cs, l1, l2, ls +int in_c1, in_c2, in_l1, in_l2, ccd_c1, ccd_c2, ccd_l1, ccd_l2 +pointer sp, output, str, in, out, data + +real asumr() +int clgwrd() +bool clgetb(), ccdflag() +pointer immap(), imgl2r(), impl2r(), imps2r() +errchk immap, ccddelete + +begin + # Check if this operation is desired. + if (!clgetb ("readcor")) + return + + # Check if this operation has been done. Unfortunately this requires + # mapping the image. + + in = immap (input, READ_ONLY, 0) + if (ccdflag (in, "readcor")) { + call imunmap (in) + return + } + + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Convert %s to readout correction\n") + call pargstr (input) + call imunmap (in) + return + } + + call smark (sp) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # The default data section is the entire image. + nc = IM_LEN(in,1) + nl = IM_LEN(in,2) + c1 = 1 + c2 = nc + cs = 1 + l1 = 1 + l2 = nl + ls = 1 + call hdmgstr (in, "datasec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) + call error (0, "Error in DATASEC parameter") + in_c1 = c1 + in_c2 = c2 + in_l1 = l1 + in_l2 = l2 + + # The default ccd section is the data section. + call hdmgstr (in, "ccdsec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((cs != 1) || (ls != 1)) + call error (0, "Error in CCDSEC parameter") + ccd_c1 = c1 + ccd_c2 = c2 + ccd_l1 = l1 + ccd_l2 = l2 + if ((in_c2-in_c1 != ccd_c2-ccd_c1) || (in_l2-in_l1 != ccd_l2-ccd_l1)) + call error (0, "Size of DATASEC and CCDSEC do not agree") + + # Determine the readout axis. + readaxis = clgwrd ("readaxis", Memc[str], SZ_LINE, "|lines|columns|") + + # Create output. + call mktemp ("tmp", Memc[output], SZ_FNAME) + call set_output (in, out, Memc[output]) + + # Average across the readout axis. + switch (readaxis) { + case 1: + IM_LEN(out,2) = 1 + data = impl2r (out, 1) + call aclrr (Memr[data], nc) + nc = in_c2 - in_c1 + 1 + nl = in_l2 - in_l1 + 1 + data = data + in_c1 - 1 + do i = in_l1, in_l2 + call aaddr (Memr[imgl2r(in,i)+in_c1-1], Memr[data], + Memr[data], nc) + call adivkr (Memr[data], real (nl), Memr[data], nc) + call sprintf (Memc[str], SZ_LINE, "[%d:%d,1:1]") + call pargi (in_c1) + call pargi (in_c2) + call hdmpstr (out, "datasec", Memc[str]) + call sprintf (Memc[str], SZ_LINE, "[%d:%d,*]") + call pargi (ccd_c1) + call pargi (ccd_c2) + call hdmpstr (out, "ccdsec", Memc[str]) + case 2: + IM_LEN(out,1) = 1 + data = imps2r (out, 1, 1, 1, nl) + call aclrr (Memr[data], nl) + nc = in_c2 - in_c1 + 1 + nl = in_l2 - in_l1 + 1 + do i = in_l1, in_l2 + Memr[data+i-1] = asumr (Memr[imgl2r(in,i)+in_c1-1], nc) / nc + call sprintf (Memc[str], SZ_LINE, "[1:1,%d:%d]") + call pargi (in_l1) + call pargi (in_l2) + call hdmpstr (out, "datasec", Memc[str]) + call sprintf (Memc[str], SZ_LINE, "[*,%d:%d]") + call pargi (ccd_l1) + call pargi (ccd_l2) + call hdmpstr (out, "ccdsec", Memc[str]) + } + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, + "Converted to readout format") + call timelog (Memc[str], SZ_LINE) + call ccdlog (in, Memc[str]) + call hdmpstr (out, "readcor", Memc[str]) + + # Replace the input image by the output image. + call imunmap (in) + call imunmap (out) + call ccddelete (input) + call imrename (Memc[output], input) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/scancor.x b/noao/imred/ccdred/src/scancor.x new file mode 100644 index 00000000..6a5eb84c --- /dev/null +++ b/noao/imred/ccdred/src/scancor.x @@ -0,0 +1,340 @@ +include <imhdr.h> +include <imset.h> + +define SCANTYPES "|shortscan|longscan|" +define SHORTSCAN 1 # Short scan accumulation, normal readout +define LONGSCAN 2 # Long scan continuous readout + +# SCANCOR -- Create a scanned image from an unscanned image. + +procedure scancor (input, output, nscan, minreplace) + +char input[ARB] # Input image +char output[ARB] # Output image (must be new image) +int nscan # Number of scan lines +real minreplace # Minmum value of output + +int scantype # Type of scan format +int readaxis # Readout axis + +int clgwrd() +pointer sp, str, in, out, immap() +errchk immap + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Determine readout axis and create the temporary output image. + scantype = clgwrd ("scantype", Memc[str], SZ_LINE, SCANTYPES) + readaxis = clgwrd ("readaxis", Memc[str], SZ_LINE, "|lines|columns|") + + # Make the output scanned image. + in = immap (input, READ_ONLY, 0) + call set_output (in, out, output) + + switch (scantype) { + case SHORTSCAN: + call shortscan (in, out, nscan, minreplace, readaxis) + case LONGSCAN: + call longscan (in, out, readaxis) + } + + # Log the operation. + switch (scantype) { + case SHORTSCAN: + call sprintf (Memc[str], SZ_LINE, + "Converted to shortscan from %s with nscan=%d") + call pargstr (input) + call pargi (nscan) + call hdmputi (out, "nscanrow", nscan) + case LONGSCAN: + call sprintf (Memc[str], SZ_LINE, "Converted to longscan from %s") + call pargstr (input) + } + call timelog (Memc[str], SZ_LINE) + call ccdlog (out, Memc[str]) + call hdmpstr (out, "scancor", Memc[str]) + + call imunmap (in) + call imunmap (out) + + call sfree (sp) +end + + +# SHORTSCAN -- Make a shortscan mode image by using a moving average. +# +# NOTE!! The value of nscan used here is increased by 1 because the +# current information in the image header is actually the number of +# scan steps and NOT the number of rows. + +procedure shortscan (in, out, nscan, minreplace, readaxis) + +pointer in # Input image +pointer out # Output image +int nscan # Number of lines scanned before readout +real minreplace # Minimum output value +int readaxis # Readout axis + +bool replace +real nscanr, sum, mean, asumr() +int i, j, k, l, len1, len2, nc, nl, nscani, c1, c2, cs, l1, l2, ls +pointer sp, str, bufs, datain, dataout, data, imgl2r(), impl2r() +long clktime() +errchk malloc, calloc + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # The default data section is the entire image. + len1 = IM_LEN(in,1) + len2 = IM_LEN(in,2) + c1 = 1 + c2 = len1 + cs = 1 + l1 = 1 + l2 = len2 + ls = 1 + call hdmgstr (in, "datasec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>len1)||(l1<1)||(l2>len2)||(cs!=1)||(ls!=1)) + call error (0, "Error in DATASEC parameter") + nc = c2 - c1 + 1 + nl = l2 - l1 + 1 + + # Copy initial lines. + do i = 1, l1 - 1 + call amovr (Memr[imgl2r(in,i)], Memr[impl2r(out,i)], len1) + + replace = !IS_INDEF(minreplace) + mean = 0. + switch (readaxis) { + case 1: + nscani = max (1, min (nscan, nl) + 1) + nscanr = nscani + call imseti (in, IM_NBUFS, nscani) + call malloc (bufs, nscani, TY_INT) + call calloc (data, nc, TY_REAL) + j = 1 + k = 1 + l = 1 + + # Ramp up + while (j <= nscani) { + i = j + l1 - 1 + datain = imgl2r (in, i) + if (nc < len1) + call amovr (Memr[datain], Memr[impl2r(out,i)], len1) + datain = datain + c1 - 1 + Memi[bufs+mod(j,nscani)] = datain + call aaddr (Memr[data], Memr[datain], Memr[data], nc) + j = j + 1 + } + dataout = impl2r (out, l+l1-1) + c1 - 1 + call adivkr (Memr[data], nscanr, Memr[dataout], nc) + if (replace) + call amaxkr (Memr[dataout], minreplace, Memr[dataout], nc) + mean = mean + asumr (Memr[dataout], nc) + l = l + 1 + + # Moving average + while (j <= nl) { + datain = Memi[bufs+mod(k,nscani)] + call asubr (Memr[data], Memr[datain], Memr[data], nc) + i = j + l1 - 1 + datain = imgl2r (in, i) + if (nc < len1) + call amovr (Memr[datain], Memr[impl2r(out,i)], len1) + datain = datain + c1 - 1 + Memi[bufs+mod(j,nscani)] = datain + call aaddr (Memr[data], Memr[datain], Memr[data], nc) + dataout = impl2r (out, l+l1-1) + c1 - 1 + call adivkr (Memr[data], nscanr, Memr[dataout], nc) + if (replace) + call amaxkr (Memr[dataout], minreplace, Memr[dataout], nc) + mean = mean + asumr (Memr[dataout], nc) + + j = j + 1 + k = k + 1 + l = l + 1 + } + + # Ramp down. + while (l <= nl) { + datain = Memi[bufs+mod(k,nscani)] + call asubr (Memr[data], Memr[datain], Memr[data], nc) + dataout = impl2r (out, l+l1-1) + c1 - 1 + call adivkr (Memr[data], nscanr, Memr[dataout], nc) + if (replace) + call amaxkr (Memr[dataout], minreplace, Memr[dataout], nc) + mean = mean + asumr (Memr[dataout], nc) + + k = k + 1 + l = l + 1 + } + + call mfree (bufs, TY_INT) + call mfree (data, TY_REAL) + + case 2: + nscani = max (1, min (nscan, nc) + 1) + nscanr = nscani + do i = 1, nl { + datain = imgl2r (in, i + l1 - 1) + datain = datain + c1 - 1 + data = impl2r (out, i + l1 - 1) + call amovr (Memr[datain], Memr[data], len1) + datain = datain + c1 - 1 + data = data + c1 - 1 + sum = 0 + j = 0 + k = 0 + l = 0 + + # Ramp up + while (j < nscani) { + sum = sum + Memr[datain+j] + j = j + 1 + } + if (replace) + Memr[data] = max (minreplace, sum / nscani) + else + Memr[data] = sum / nscani + mean = mean + Memr[data] + l = l + 1 + + # Moving average + while (j < nl) { + sum = sum + Memr[datain+j] - Memr[datain+k] + if (replace) + Memr[data+l] = max (minreplace, sum / nscani) + else + Memr[data+l] = sum / nscani + mean = mean + Memr[data+l] + j = j + 1 + k = k + 1 + l = l + 1 + } + + # Ramp down + while (l < nl) { + sum = sum - Memr[datain+k] + if (replace) + Memr[data+l] = max (minreplace, sum / nscani) + else + Memr[data+l] = sum / nscani + mean = mean + Memr[data+l] + k = k + 1 + l = l + 1 + } + } + } + + # Copy final lines. + do i = l2+1, len2 + call amovr (Memr[imgl2r(in,i)], Memr[impl2r(out,i)], len1) + + mean = mean / nc / nl + call hdmputr (out, "ccdmean", mean) + call hdmputi (out, "ccdmeant", int (clktime (long (0)))) + + call sfree (sp) +end + + +# LONGSCAN -- Make a longscan mode readout flat field correction by averaging +# across the readout axis. + +procedure longscan (in, out, readaxis) + +pointer in # Input image +pointer out # Output image +int readaxis # Readout axis + +int i, nc, nl, c1, c2, cs, l1, l2, ls +int in_c1, in_c2, in_l1, in_l2, ccd_c1, ccd_c2, ccd_l1, ccd_l2 +real mean, asumr() +long clktime() +pointer sp, str, data, imgl2r(), impl2r(), imps2r() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # The default data section is the entire image. + nc = IM_LEN(in,1) + nl = IM_LEN(in,2) + c1 = 1 + c2 = nc + cs = 1 + l1 = 1 + l2 = nl + ls = 1 + call hdmgstr (in, "datasec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) + call error (0, "Error in DATASEC parameter") + in_c1 = c1 + in_c2 = c2 + in_l1 = l1 + in_l2 = l2 + + # The default ccd section is the data section. + call hdmgstr (in, "ccdsec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((cs != 1) || (ls != 1)) + call error (0, "Error in CCDSEC parameter") + ccd_c1 = c1 + ccd_c2 = c2 + ccd_l1 = l1 + ccd_l2 = l2 + if ((in_c2-in_c1 != ccd_c2-ccd_c1) || (in_l2-in_l1 != ccd_l2-ccd_l1)) + call error (0, "Size of DATASEC and CCDSEC do not agree") + + switch (readaxis) { + case 1: + IM_LEN(out,2) = 1 + data = impl2r (out, 1) + call aclrr (Memr[data], nc) + nc = in_c2 - in_c1 + 1 + nl = in_l2 - in_l1 + 1 + data = data + in_c1 - 1 + do i = in_l1, in_l2 + call aaddr (Memr[imgl2r(in,i)+in_c1-1], Memr[data], + Memr[data], nc) + call adivkr (Memr[data], real (nl), Memr[data], nc) + call sprintf (Memc[str], SZ_LINE, "[%d:%d,1:1]") + call pargi (in_c1) + call pargi (in_c2) + call hdmpstr (out, "datasec", Memc[str]) + call sprintf (Memc[str], SZ_LINE, "[%d:%d,*]") + call pargi (ccd_c1) + call pargi (ccd_c2) + call hdmpstr (out, "ccdsec", Memc[str]) + mean = asumr (Memr[data], nc) / nl + case 2: + IM_LEN(out,1) = 1 + data = imps2r (out, 1, 1, 1, nl) + call aclrr (Memr[data], nl) + nc = in_c2 - in_c1 + 1 + nl = in_l2 - in_l1 + 1 + do i = in_l1, in_l2 + Memr[data+i-1] = asumr (Memr[imgl2r(in,i)+in_c1-1], nc) / nc + call sprintf (Memc[str], SZ_LINE, "[1:1,%d:%d]") + call pargi (in_l1) + call pargi (in_l2) + call hdmpstr (out, "datasec", Memc[str]) + call sprintf (Memc[str], SZ_LINE, "[*,%d:%d]") + call pargi (ccd_l1) + call pargi (ccd_l2) + call hdmpstr (out, "ccdsec", Memc[str]) + mean = asumr (Memr[data], nl) / nc + } + + call hdmputr (out, "ccdmean", mean) + call hdmputi (out, "ccdmeant", int (clktime (long (0)))) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setdark.x b/noao/imred/ccdred/src/setdark.x new file mode 100644 index 00000000..c872aba4 --- /dev/null +++ b/noao/imred/ccdred/src/setdark.x @@ -0,0 +1,160 @@ +include <imhdr.h> +include "ccdred.h" +include "ccdtypes.h" + + +# SET_DARK -- Set parameters for dark count correction. +# +# 1. Return immediately if the dark count correction is not requested or +# if the image has been previously corrected. +# 2. Get the dark count correction image and return an error if not found. +# 3. If the dark count image has not been processed call PROC. +# 4. Compute the dark count integration time scale factor. +# 5. Set the processing flags. +# 6. Log the operation (to user, logfile, and output image header). + +procedure set_dark (ccd) + +pointer ccd # CCD structure + +int nscan, nc, nl, c1, c2, cs, l1, l2, ls, data_c1, ccd_c1, data_l1, ccd_l1 +real darktime1, darktime2 +pointer sp, image, str, im + +bool clgetb(), ccdflag(), ccdcheck() +int ccdnscan(), ccdtypei() +real hdmgetr() +pointer ccd_cache() +errchk cal_image, ccd_cache, ccdproc, hdmgetr + +begin + # Check if the user wants this operation or it has already been done. + if (!clgetb ("darkcor") || ccdflag (IN_IM(ccd), "darkcor")) + return + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the dark count correction image name. + if (clgetb ("scancor")) + nscan = ccdnscan (IN_IM(ccd), ccdtypei(IN_IM(ccd))) + else + nscan = 1 + call cal_image (IN_IM(ccd), DARK, nscan, Memc[image], SZ_FNAME) + + # If no processing is desired print dark count image and return. + if (clgetb ("noproc")) { + call eprintf (" [TO BE DONE] Dark count correction image is %s.\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Map the image and return on an error. + # Process the dark count image if necessary. + # If nscan > 1 then the dark may not yet exist so create it + # from the unscanned dark. + + iferr (im = ccd_cache (Memc[image], DARK)) { + call cal_image (IN_IM(ccd), DARK, 1, Memc[str], SZ_LINE) + im = ccd_cache (Memc[str], DARK) + if (ccdcheck (im, DARK)) { + call ccd_flush (im) + call ccdproc (Memc[str], DARK) + } + call scancor (Memc[str], Memc[image], nscan, INDEF) + im = ccd_cache (Memc[image], DARK) + } + + if (ccdcheck (im, DARK)) { + call ccd_flush (im) + call ccdproc (Memc[image], DARK) + im = ccd_cache (Memc[image], DARK) + } + + # Set the processing parameters in the CCD structure. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + c1 = 1 + c2 = nc + l1 = 1 + l2 = nl + cs = 1 + ls = 1 + call hdmgstr (im, "datasec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) { + call sprintf (Memc[str], SZ_LINE, + "Data section error: image=%s[%d,%d], datasec=[%d:%d,%d:%d]") + call pargstr (Memc[image]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + data_c1 = c1 + data_l1 = l1 + call hdmgstr (im, "ccdsec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if (nc == 1) { + c1 = CCD_C1(ccd) + c2 = CCD_C2(ccd) + } + if (nl == 1) { + l1 = CCD_L1(ccd) + l2 = CCD_L2(ccd) + } + ccd_c1 = c1 + ccd_l1 = l1 + if ((c1 > CCD_C1(ccd)) || (c2 < CCD_C2(ccd)) || + (l1 > CCD_L1(ccd)) || (l2 < CCD_L2(ccd))) { + call sprintf (Memc[str], SZ_LINE, + "CCD section error: input=[%d:%d,%d:%d], %s=[%d:%d,%d:%d]") + call pargi (CCD_C1(ccd)) + call pargi (CCD_C2(ccd)) + call pargi (CCD_L1(ccd)) + call pargi (CCD_L2(ccd)) + call pargstr (Memc[image]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + + DARK_IM(ccd) = im + DARK_C1(ccd) = CCD_C1(ccd) - ccd_c1 + data_c1 + DARK_C2(ccd) = CCD_C2(ccd) - ccd_c1 + data_c1 + DARK_L1(ccd) = CCD_L1(ccd) - ccd_l1 + data_l1 + DARK_L2(ccd) = CCD_L2(ccd) - ccd_l1 + data_l1 + + # Get the dark count integration times. Return an error if not found. + iferr (darktime1 = hdmgetr (IN_IM(ccd), "darktime")) + darktime1 = hdmgetr (IN_IM(ccd), "exptime") + iferr (darktime2 = hdmgetr (im, "darktime")) + darktime2 = hdmgetr (im, "exptime") + if (darktime2 <= 0.) { + call sprintf (Memc[str], SZ_LINE, "Dark time is zero for `%s'") + call pargstr (Memc[image]) + call error (1, Memc[str]) + } + + DARKSCALE(ccd) = darktime1 / darktime2 + CORS(ccd, DARKCOR) = D + COR(ccd) = YES + + # Record the operation in the output image and write a log record. + call sprintf (Memc[str], SZ_LINE, + "Dark count correction image is %s with scale=%g") + call pargstr (Memc[image]) + call pargr (DARKSCALE(ccd)) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "darkcor", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setfixpix.x b/noao/imred/ccdred/src/setfixpix.x new file mode 100644 index 00000000..e6b96298 --- /dev/null +++ b/noao/imred/ccdred/src/setfixpix.x @@ -0,0 +1,74 @@ +include <imhdr.h> +include <imset.h> +include <pmset.h> +include "ccdred.h" + + +# SET_FIXPIX -- Set parameters for bad pixel correction. +# 1. Return immediately if the bad pixel correction is not requested or +# if the image has been previously corrected. +# 2. Get the bad pixel mask. Return an error if not found. +# 3. If the bad pixel mask has not been processed call PROC. +# 4. Set the processing flag. +# 5. Log the operation (to user, logfile, and output image header). +# +# This routine relies on the physical coordinate system and assumes +# XT_PMMAP has taken care of matching the pixel mask to the input image. + +procedure set_fixpix (ccd) + +pointer ccd # CCD structure + +pointer sp, image, str, im + +int imstati() +bool clgetb(), streq(), ccdflag() +pointer xt_pmmap(), xt_fpinit() +errchk xt_pmmap(), xt_fpinit() + +begin + # Check if the user wants this operation or it has been done. + if (!clgetb ("fixpix") || ccdflag (IN_IM(ccd), "fixpix")) + return + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the bad pixel file. If the name is "image" then get the file + # name from the image header or symbol table. + + call clgstr ("fixfile", Memc[image], SZ_FNAME) + if (streq (Memc[image], "image")) + call hdmgstr (IN_IM(ccd), "fixfile", Memc[image], SZ_FNAME) + + # If no processing is desired print message and return. + if (clgetb ("noproc")) { + call eprintf (" [TO BE DONE] Bad pixel file is %s\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Map the bad pixel image and return on an error. + im = xt_pmmap (Memc[image], IN_IM(ccd), Memc[image], SZ_FNAME) + if (Memc[image] == EOS) + call error (1, "No bad pixel mask found") + if (im != NULL) { + MASK_IM(ccd) = im + MASK_PM(ccd) = imstati (im, IM_PMDES) + MASK_FP(ccd) = xt_fpinit (MASK_PM(ccd), 2, 3) + + CORS(ccd, FIXPIX) = YES + COR(ccd) = YES + } + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, "Bad pixel file is %s") + call pargstr (Memc[image]) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "fixpix", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setflat.x b/noao/imred/ccdred/src/setflat.x new file mode 100644 index 00000000..87713404 --- /dev/null +++ b/noao/imred/ccdred/src/setflat.x @@ -0,0 +1,146 @@ +include <imhdr.h> +include "ccdred.h" +include "ccdtypes.h" + +# SET_FLAT -- Set parameters for flat field correction. +# +# 1. Return immediately if the flat field correction is not requested or +# if the image has been previously corrected. +# 2. Get the flat field image and return on an error. +# 3. If the flat field image has not been processed call PROC. +# 4. Set the processing flags and record the operation in the output +# image and write a log record. + +procedure set_flat (ccd) + +pointer ccd # CCD structure + +int nc, nl, c1, c2, cs, l1, l2, ls, data_c1, ccd_c1, data_l1, ccd_l1 +pointer sp, str, image, im, ccd_cache() +bool clgetb(), ccdflag(), ccdcheck() +int nscan, ccdnscan(), ccdtypei() +real hdmgetr() +errchk cal_image, ccd_cache, ccdproc, hdmgetr + +begin + # Check if the user wants this operation or if it has been done. + if (!clgetb ("flatcor") || ccdflag (IN_IM(ccd), "flatcor")) + return + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the flat field correction image. + if (clgetb ("scancor")) + nscan = ccdnscan (IN_IM(ccd), ccdtypei(IN_IM(ccd))) + else + nscan = 1 + call cal_image (IN_IM(ccd), FLAT, nscan, Memc[image], SZ_FNAME) + + # If no processing is desired print flat field image name and return. + if (clgetb ("noproc")) { + call eprintf (" [TO BE DONE] Flat correction image is %s.\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Map the image and return on an error. + # Process the flat field image if necessary. + # If nscan > 1 then the flat field may not yet exist so create it + # from the unscanned flat field. + + iferr (im = ccd_cache (Memc[image], FLAT)) { + call cal_image (IN_IM(ccd), FLAT, 1, Memc[str], SZ_LINE) + im = ccd_cache (Memc[str], FLAT) + if (ccdcheck (im, FLAT)) { + call ccd_flush (im) + call ccdproc (Memc[str], FLAT) + } + call scancor (Memc[str], Memc[image], nscan, MINREPLACE(ccd)) + im = ccd_cache (Memc[image], FLAT) + } + + if (ccdcheck (im, FLAT)) { + call ccd_flush (im) + call ccdproc (Memc[image], FLAT) + im = ccd_cache (Memc[image], FLAT) + } + + # Set the processing parameters in the CCD structure. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + c1 = 1 + c2 = nc + l1 = 1 + l2 = nl + cs = 1 + ls = 1 + call hdmgstr (im, "datasec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) { + call sprintf (Memc[str], SZ_LINE, + "Data section error: image=%s[%d,%d], datasec=[%d:%d,%d:%d]") + call pargstr (Memc[image]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + data_c1 = c1 + data_l1 = l1 + call hdmgstr (im, "ccdsec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if (nc == 1) { + c1 = CCD_C1(ccd) + c2 = CCD_C2(ccd) + } + if (nl == 1) { + l1 = CCD_L1(ccd) + l2 = CCD_L2(ccd) + } + ccd_c1 = c1 + ccd_l1 = l1 + if ((c1 > CCD_C1(ccd)) || (c2 < CCD_C2(ccd)) || + (l1 > CCD_L1(ccd)) || (l2 < CCD_L2(ccd))) { + call sprintf (Memc[str], SZ_LINE, + "CCD section error: input=[%d:%d,%d:%d], %s=[%d:%d,%d:%d]") + call pargi (CCD_C1(ccd)) + call pargi (CCD_C2(ccd)) + call pargi (CCD_L1(ccd)) + call pargi (CCD_L2(ccd)) + call pargstr (Memc[image]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + + FLAT_IM(ccd) = im + FLAT_C1(ccd) = CCD_C1(ccd) - ccd_c1 + data_c1 + FLAT_C2(ccd) = CCD_C2(ccd) - ccd_c1 + data_c1 + FLAT_L1(ccd) = CCD_L1(ccd) - ccd_l1 + data_l1 + FLAT_L2(ccd) = CCD_L2(ccd) - ccd_l1 + data_l1 + + # If no mean value use 1 as the scale factor. + iferr (FLATSCALE(ccd) = hdmgetr (im, "ccdmean")) + FLATSCALE(ccd) = 1. + CORS(ccd, FLATCOR) = F + COR(ccd) = YES + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, + "Flat field image is %s with scale=%g") + call pargstr (Memc[image]) + call pargr (FLATSCALE(ccd)) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "flatcor", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setfringe.x b/noao/imred/ccdred/src/setfringe.x new file mode 100644 index 00000000..7055f35f --- /dev/null +++ b/noao/imred/ccdred/src/setfringe.x @@ -0,0 +1,123 @@ +include <imhdr.h> +include "ccdred.h" +include "ccdtypes.h" + +# SET_FRINGE -- Set parameters for fringe correction. +# +# 1. Return immediately if the fringe correction is not requested or +# if the image has been previously corrected. +# 2. Get the fringe image and return error if the mkfringe flag is missing. +# 3. Set the processing flags and record the operation in the output +# image and write a log record. + +procedure set_fringe (ccd) + +pointer ccd # CCD structure + +int nc, nl, c1, c2, cs, l1, l2, ls, data_c1, ccd_c1, data_l1, ccd_l1 +real exptime1, exptime2, fringescale +pointer sp, str, image, im + +bool clgetb(), ccdflag() +real hdmgetr() +pointer ccd_cache() +errchk cal_image, ccd_cache, ccdproc, hdmgetr + +begin + # Check if the user wants this operation or if it has been done. + if (!clgetb ("fringecor") || ccdflag (IN_IM(ccd), "fringcor")) + return + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the fringe correction image. + call cal_image (IN_IM(ccd), FRINGE, 1, Memc[image], SZ_FNAME) + + # If no processing is desired print fringe image name and return. + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Fringe correction image is %s.\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Return an error if the fringe flag is missing. + im = ccd_cache (Memc[image], FRINGE) + if (!ccdflag (im, "mkfringe")) + call error (0, "MKFRINGE flag missing from fringe image.") + + # Set the processing parameters in the CCD structure. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + c1 = 1 + c2 = nc + l1 = 1 + l2 = nl + cs = 1 + ls = 1 + call hdmgstr (im, "datasec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) { + call sprintf (Memc[str], SZ_LINE, + "Data section error: image=%s[%d,%d], datasec=[%d:%d,%d:%d]") + call pargstr (Memc[image]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + data_c1 = c1 + data_l1 = l1 + call hdmgstr (im, "ccdsec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + ccd_c1 = c1 + ccd_l1 = l1 + if ((c1 > CCD_C1(ccd)) || (c2 < CCD_C2(ccd)) || + (l1 > CCD_L1(ccd)) || (l2 < CCD_L2(ccd))) { + call sprintf (Memc[str], SZ_LINE, + "CCD section error: input=[%d:%d,%d:%d], %s=[%d:%d,%d:%d]") + call pargi (CCD_C1(ccd)) + call pargi (CCD_C2(ccd)) + call pargi (CCD_L1(ccd)) + call pargi (CCD_L2(ccd)) + call pargstr (Memc[image]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + + FRINGE_IM(ccd) = im + FRINGE_C1(ccd) = CCD_C1(ccd) - ccd_c1 + data_c1 + FRINGE_C2(ccd) = CCD_C2(ccd) - ccd_c1 + data_c1 + FRINGE_L1(ccd) = CCD_L1(ccd) - ccd_l1 + data_l1 + FRINGE_L2(ccd) = CCD_L2(ccd) - ccd_l1 + data_l1 + + # Get the scaling factors. If no fringe scale factor assume 1. + exptime1 = hdmgetr (IN_IM(ccd), "exptime") + exptime2 = hdmgetr (im, "exptime") + iferr (fringescale = hdmgetr (im, "fringscl")) + fringescale = 1. + + FRINGESCALE(ccd) = exptime1 / exptime2 * fringescale + CORS(ccd, FRINGECOR) = Q + COR(ccd) = YES + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, + "Fringe image is %s with scale=%g") + call pargstr (Memc[image]) + call pargr (FRINGESCALE(ccd)) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "fringcor", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setheader.x b/noao/imred/ccdred/src/setheader.x new file mode 100644 index 00000000..aa13730a --- /dev/null +++ b/noao/imred/ccdred/src/setheader.x @@ -0,0 +1,83 @@ +include <imhdr.h> +include "ccdred.h" + +# SET_HEADER -- Set the output image header. + +procedure set_header (ccd) + +pointer ccd # CCD structure + +int nc, nl +real shift[2] +pointer sp, str, out, mw, mw_openim() +long clktime() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + out = OUT_IM(ccd) + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + + # Set the data section if it is not the whole image. + if ((OUT_C1(ccd) != 1) || (OUT_C2(ccd) != nc) || + (OUT_L1(ccd) != 1) || (OUT_L2(ccd) != nl)) { + call sprintf (Memc[str], SZ_LINE, "[%d:%d,%d:%d]") + call pargi (OUT_C1(ccd)) + call pargi (OUT_C2(ccd)) + call pargi (OUT_L1(ccd)) + call pargi (OUT_L2(ccd)) + call hdmpstr (out, "datasec", Memc[str]) + } else { + iferr (call hdmdelf (out, "datasec")) + ; + } + + # Set the CCD section. + call sprintf (Memc[str], SZ_LINE, "[%d:%d,%d:%d]") + call pargi (CCD_C1(ccd)) + call pargi (CCD_C2(ccd)) + call pargi (CCD_L1(ccd)) + call pargi (CCD_L2(ccd)) + call hdmpstr (out, "ccdsec", Memc[str]) + + # If trimming update the trim and bias section parameters. + if (CORS(ccd, TRIM) == YES) { + iferr (call hdmdelf (out, "trimsec")) + ; + iferr (call hdmdelf (out, "biassec")) + ; + BIAS_C1(ccd) = max (1, BIAS_C1(ccd) - TRIM_C1(ccd) + 1) + BIAS_C2(ccd) = min (nc, BIAS_C2(ccd) - TRIM_C1(ccd) + 1) + BIAS_L1(ccd) = max (1, BIAS_L1(ccd) - TRIM_L1(ccd) + 1) + BIAS_L2(ccd) = min (nl, BIAS_L2(ccd) - TRIM_L1(ccd) + 1) + if ((BIAS_C1(ccd)<=BIAS_C2(ccd)) && (BIAS_L1(ccd)<=BIAS_L2(ccd))) { + call sprintf (Memc[str], SZ_LINE, "[%d:%d,%d:%d]") + call pargi (BIAS_C1(ccd)) + call pargi (BIAS_C2(ccd)) + call pargi (BIAS_L1(ccd)) + call pargi (BIAS_L2(ccd)) + call hdmpstr (out, "biassec", Memc[str]) + } + + mw = mw_openim (out) + shift[1] = 1 - IN_C1(ccd) + shift[2] = 1 - IN_L1(ccd) + call mw_shift (mw, shift, 3) + call mw_saveim (mw, out) + } + + # Set mean value if desired. + if (CORS(ccd, FINDMEAN) == YES) { + call hdmputr (out, "ccdmean", MEAN(ccd)) + call hdmputi (out, "ccdmeant", int (clktime (long (0)))) + } + + # Mark image as processed. + call sprintf (Memc[str], SZ_LINE, "CCD processing done") + call timelog (Memc[str], SZ_LINE) + call hdmpstr (out, "ccdproc", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setillum.x b/noao/imred/ccdred/src/setillum.x new file mode 100644 index 00000000..d1677301 --- /dev/null +++ b/noao/imred/ccdred/src/setillum.x @@ -0,0 +1,132 @@ +include <imhdr.h> +include "ccdred.h" +include "ccdtypes.h" + +# SET_ILLUM -- Set parameters for illumination correction. +# +# 1. Return immediately if the illumination correction is not requested or +# if the image has been previously corrected. +# 2. Get the illumination image and return error if mkillum flag missing. +# 3. Set the processing flags and record the operation in the output +# image and write a log record. + +procedure set_illum (ccd) + +pointer ccd # CCD structure + +int nc, nl, c1, c2, cs, l1, l2, ls, data_c1, ccd_c1, data_l1, ccd_l1 +long time +pointer sp, str, image, im + +bool clgetb(), ccdflag() +long hdmgeti() +real hdmgetr() +pointer ccd_cache() +errchk cal_image, ccd_cache, ccdproc, hdmgetr, hdmgeti + +begin + # Check if the user wants this operation or if it has been done. + if (!clgetb ("illumcor") || ccdflag (IN_IM(ccd), "illumcor")) + return + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the illumcor correction image. + call cal_image (IN_IM(ccd), ILLUM, 1, Memc[image], SZ_FNAME) + + # If no processing is desired print illumination image name and return. + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Illumination correction image is %s.\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Return a warning if the illumination flag is missing. + im = ccd_cache (Memc[image], ILLUM) + if (!ccdflag (im, "mkillum")) { + call ccd_flush (im) + call error (0, "MKILLUM flag missing from illumination image") + } + + # If no mean value for the scale factor compute it. + iferr (ILLUMSCALE(ccd) = hdmgetr (im, "ccdmean")) + ILLUMSCALE(ccd) = INDEF + iferr (time = hdmgeti (im, "ccdmeant")) + time = IM_MTIME(im) + if (IS_INDEF(ILLUMSCALE(ccd)) || time < IM_MTIME(im)) { + call ccd_flush (im) + call ccdmean (Memc[image]) + im = ccd_cache (Memc[image], ILLUM) + } + iferr (ILLUMSCALE(ccd) = hdmgetr (im, "ccdmean")) + ILLUMSCALE(ccd) = 1. + + # Set the processing parameters in the CCD structure. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + c1 = 1 + c2 = nc + l1 = 1 + l2 = nl + cs = 1 + ls = 1 + call hdmgstr (im, "datasec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) { + call sprintf (Memc[str], SZ_LINE, + "Data section error: image=%s[%d,%d], datasec=[%d:%d,%d:%d]") + call pargstr (Memc[image]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + data_c1 = c1 + data_l1 = l1 + call hdmgstr (im, "ccdsec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + ccd_c1 = c1 + ccd_l1 = l1 + if ((c1 > CCD_C1(ccd)) || (c2 < CCD_C2(ccd)) || + (l1 > CCD_L1(ccd)) || (l2 < CCD_L2(ccd))) { + call sprintf (Memc[str], SZ_LINE, + "CCD section error: input=[%d:%d,%d:%d], %s=[%d:%d,%d:%d]") + call pargi (CCD_C1(ccd)) + call pargi (CCD_C2(ccd)) + call pargi (CCD_L1(ccd)) + call pargi (CCD_L2(ccd)) + call pargstr (Memc[image]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + + ILLUM_IM(ccd) = im + ILLUM_C1(ccd) = CCD_C1(ccd) - ccd_c1 + data_c1 + ILLUM_C2(ccd) = CCD_C2(ccd) - ccd_c1 + data_c1 + ILLUM_L1(ccd) = CCD_L1(ccd) - ccd_l1 + data_l1 + ILLUM_L2(ccd) = CCD_L2(ccd) - ccd_l1 + data_l1 + + CORS(ccd, ILLUMCOR) = I + COR(ccd) = YES + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, + "Illumination image is %s with scale=%g") + call pargstr (Memc[image]) + call pargr (ILLUMSCALE(ccd)) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "illumcor", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setinput.x b/noao/imred/ccdred/src/setinput.x new file mode 100644 index 00000000..3d3170db --- /dev/null +++ b/noao/imred/ccdred/src/setinput.x @@ -0,0 +1,48 @@ +include <error.h> +include "ccdtypes.h" + +# SET_INPUT -- Set the input image and image type. +# +# 1. Open the input image. Return warning and NULL pointer for an error. +# 2. Get the requested CCD image type. +# a. If no type is requested then accept the image. +# b. If a type is requested then match against the image type. +# Unmap the image if no match. +# 3. If the image is acceptable then get the CCD type code. + +procedure set_input (image, im, ccdtype) + +char image[ARB] # Input image name +pointer im # IMIO pointer (returned) +int ccdtype # CCD image type + +bool strne() +int ccdtypei() +pointer sp, str1, str2, immap() + +begin + # Open the image. Return a warning and NULL pointer for an error. + iferr (im = immap (image, READ_ONLY, 0)) { + call erract (EA_WARN) + im = NULL + return + } + + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + # Get the requested CCD type. + call clgstr ("ccdtype", Memc[str1], SZ_LINE) + call xt_stripwhite (Memc[str1]) + if (Memc[str1] != EOS) { + call ccdtypes (im, Memc[str2], SZ_LINE) + if (strne (Memc[str1], Memc[str2])) + call imunmap (im) + } + + if (im != NULL) + ccdtype = ccdtypei (im) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setinteract.x b/noao/imred/ccdred/src/setinteract.x new file mode 100644 index 00000000..05bc0f71 --- /dev/null +++ b/noao/imred/ccdred/src/setinteract.x @@ -0,0 +1,31 @@ +include <pkg/xtanswer.h> + +# SET_INTERACTIVE -- Set the interactive flag. Query the user if necessary. +# +# This procedure initializes the interactive flag if there is no query. +# If there is a query it is issued by XT_ANSWER. The four valued +# interactive flag is returned. + +procedure set_interactive (query, interactive) + +char query[ARB] # Query prompt +int interactive # Fit overscan interactively? (returned) + +int interact # Saves last value of interactive flag +bool clgetb() + +begin + # If the query is null then initialize from the CL otherwise + # query the user. This response is four valued to allow the user + # to turn off the query when processing multiple images. + + if (query[1] == EOS) { + if (clgetb ("interactive")) + interact = YES + else + interact = ALWAYSNO + } else + call xt_answer (query, interact) + + interactive = interact +end diff --git a/noao/imred/ccdred/src/setoutput.x b/noao/imred/ccdred/src/setoutput.x new file mode 100644 index 00000000..b401b5aa --- /dev/null +++ b/noao/imred/ccdred/src/setoutput.x @@ -0,0 +1,52 @@ +include <imhdr.h> +include <imset.h> + +# SET_OUTPUT -- Setup the output image. +# The output image is a NEW_COPY of the input image. +# The user may select a pixel datatype with higher precision though not +# lower. + +procedure set_output (in, out, output) + +pointer in # Input IMIO pointer to copy +pointer out # Output IMIO pointer +char output[SZ_FNAME] # Output image name + +int i, clscan(), nscan() +char type[1] +pointer immap() +errchk immap + +begin + out = immap (output, NEW_COPY, in) + IM_PIXTYPE(out) = TY_REAL + if (clscan ("pixeltype") != EOF) { + call gargwrd (type, 1) + if (nscan() == 1) { + i = IM_PIXTYPE(in) + IM_PIXTYPE(out) = i + switch (type[1]) { + case 's': + if (i == TY_USHORT) + IM_PIXTYPE(out) = TY_SHORT + case 'u': + if (i == TY_SHORT) + IM_PIXTYPE(out) = TY_USHORT + case 'i': + if (i == TY_SHORT || i == TY_USHORT) + IM_PIXTYPE(out) = TY_INT + case 'l': + if (i == TY_SHORT || i == TY_USHORT || i == TY_INT) + IM_PIXTYPE(out) = TY_LONG + case 'r': + if (i != TY_DOUBLE) + IM_PIXTYPE(out) = TY_REAL + case 'd': + IM_PIXTYPE(out) = TY_DOUBLE + default: + call imunmap (out) + call error (0, "Unknown pixel type") + } + } + } +end diff --git a/noao/imred/ccdred/src/setoverscan.x b/noao/imred/ccdred/src/setoverscan.x new file mode 100644 index 00000000..e344aa92 --- /dev/null +++ b/noao/imred/ccdred/src/setoverscan.x @@ -0,0 +1,310 @@ +include <imhdr.h> +include <imset.h> +include <pkg/gtools.h> +include <pkg/xtanswer.h> +include "ccdred.h" + + +# SET_OVERSCAN -- Set the overscan vector. +# +# 1. Return immediately if the overscan correction is not requested or +# if the image has been previously corrected. +# 2. Determine the overscan columns or lines. This may be specifed +# directly or indirectly through the image header or symbol table. +# 3. Determine the type of overscan. +# 4. If fitting the overscan average the overscan columns or lines and +# fit a function with the ICFIT routines to smooth the overscan vector. +# 5. Set the processing flag. +# 6. Log the operation (to user, logfile, and output image header). + +procedure set_overscan (ccd) + +pointer ccd # CCD structure pointer + +int i, first, last, navg, npts, type +int nc, nl, c1, c2, l1, l2 +pointer sp, str, errstr, func, buf, x, overscan + +int clgwrd() +real asumr() +bool clgetb(), ccdflag() +pointer imgl2r(), imgs2r() +errchk imgl2r, imgs2r, fit_overscan + +begin + # Check if the user wants this operation or if it has been done. + if (!clgetb ("overscan") || ccdflag (IN_IM(ccd), "overscan")) + return + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (errstr, SZ_LINE, TY_CHAR) + call salloc (func, SZ_LINE, TY_CHAR) + call imstats (IN_IM(ccd), IM_IMAGENAME, Memc[str], SZ_LINE) + + # Check bias section. + nc = IM_LEN(IN_IM(ccd),1) + nl = IM_LEN(IN_IM(ccd),2) + c1 = BIAS_C1(ccd) + c2 = BIAS_C2(ccd) + l1 = BIAS_L1(ccd) + l2 = BIAS_L2(ccd) + if ((c1 < 1) || (c2 > nc) || (l1 < 1) || (l2 > nl)) { + call sprintf (Memc[errstr], SZ_LINE, + "Error in bias section: image=%s[%d,%d], biassec=[%d:%d,%d:%d]") + call pargstr (Memc[str]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[errstr]) + } + if ((c1 == 1) && (c2 == nc) && (l1 == 1) && (l2 == nl)) { + call error (0, "Bias section not specified or given as full image") + } + + # If no processing is desired then print overscan strip and return. + if (clgetb ("noproc")) { + call eprintf (" [TO BE DONE] Overscan section is [%d:%d,%d:%d].\n") + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call sfree (sp) + return + } + + # Determine the overscan section parameters. The readout axis + # determines the type of overscan. The step sizes are ignored. + # The limits in the long dimension are replaced by the trim limits. + + type = clgwrd ("function", Memc[func], SZ_LINE, OVERSCAN_TYPES) + if (type < OVERSCAN_FIT) { + overscan = NULL + if (READAXIS(ccd) == 2) + call error (1, + "Overscan function type not allowed with readaxis of 2") + } else { + if (READAXIS(ccd) == 1) { + first = c1 + last = c2 + navg = last - first + 1 + npts = nl + call salloc (buf, npts, TY_REAL) + do i = 1, npts + Memr[buf+i-1] = asumr (Memr[imgs2r (IN_IM(ccd), first, last, + i, i)], navg) + if (navg > 1) + call adivkr (Memr[buf], real (navg), Memr[buf], npts) + + # Trim the overscan vector and set the pixel coordinate. + npts = CCD_L2(ccd) - CCD_L1(ccd) + 1 + call malloc (overscan, npts, TY_REAL) + call salloc (x, npts, TY_REAL) + call trim_overscan (Memr[buf], npts, IN_L1(ccd), Memr[x], + Memr[overscan]) + + call fit_overscan (Memc[str], c1, c2, l1, l2, Memr[x], + Memr[overscan], npts) + + } else { + first = l1 + last = l2 + navg = last - first + 1 + npts = nc + call salloc (buf, npts, TY_REAL) + call aclrr (Memr[buf], npts) + do i = first, last + call aaddr (Memr[imgl2r(IN_IM(ccd),i)], Memr[buf], + Memr[buf], npts) + if (navg > 1) + call adivkr (Memr[buf], real (navg), Memr[buf], npts) + + # Trim the overscan vector and set the pixel coordinate. + npts = CCD_C2(ccd) - CCD_C1(ccd) + 1 + call malloc (overscan, npts, TY_REAL) + call salloc (x, npts, TY_REAL) + call trim_overscan (Memr[buf], npts, IN_C1(ccd), Memr[x], + Memr[overscan]) + + call fit_overscan (Memc[str], c1, c2, l1, l2, Memr[x], + Memr[overscan], npts) + } + } + + # Set the CCD structure overscan parameters. + CORS(ccd, OVERSCAN) = O + COR(ccd) = YES + OVERSCAN_TYPE(ccd) = type + OVERSCAN_VEC(ccd) = overscan + + # Log the operation. + if (type < OVERSCAN_FIT) { + call sprintf (Memc[str], SZ_LINE, + "Overscan section is [%d:%d,%d:%d] with function=%s") + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call pargstr (Memc[func]) + } else { + call sprintf (Memc[str], SZ_LINE, + "Overscan section is [%d:%d,%d:%d] with mean=%g") + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call pargr (asumr (Memr[overscan], npts) / npts) + } + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "overscan", Memc[str]) + + call sfree (sp) +end + + +# FIT_OVERSCAN -- Fit a function to smooth the overscan vector. +# The fitting uses the ICFIT procedures which may be interactive. +# Changes to these parameters are "learned". The user is queried with a four +# valued logical query (XT_ANSWER routine) which may be turned off when +# multiple images are processed. + +procedure fit_overscan (image, c1, c2, l1, l2, x, overscan, npts) + +char image[ARB] # Image name for query and title +int c1, c2, l1, l2 # Overscan strip +real x[npts] # Pixel coordinates of overscan +real overscan[npts] # Input overscan and output fitted overscan +int npts # Number of data points + +int interactive, fd +pointer sp, str, w, ic, cv, gp, gt + +int clgeti(), ic_geti(), open() +real clgetr(), ic_getr() +pointer gopen(), gt_init() +errchk gopen, open + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (w, npts, TY_REAL) + call amovkr (1., Memr[w], npts) + + # Open the ICFIT procedures, get the fitting parameters, and + # set the fitting limits. + + call ic_open (ic) + call clgstr ("function", Memc[str], SZ_LINE) + call ic_pstr (ic, "function", Memc[str]) + call ic_puti (ic, "order", clgeti ("order")) + call clgstr ("sample", Memc[str], SZ_LINE) + call ic_pstr (ic, "sample", Memc[str]) + call ic_puti (ic, "naverage", clgeti ("naverage")) + call ic_puti (ic, "niterate", clgeti ("niterate")) + call ic_putr (ic, "low", clgetr ("low_reject")) + call ic_putr (ic, "high", clgetr ("high_reject")) + call ic_putr (ic, "grow", clgetr ("grow")) + call ic_putr (ic, "xmin", min (x[1], x[npts])) + call ic_putr (ic, "xmax", max (x[1], x[npts])) + call ic_pstr (ic, "xlabel", "Pixel") + call ic_pstr (ic, "ylabel", "Overscan") + + # If the fitting is done interactively set the GTOOLS and GIO + # pointers. Also "learn" the fitting parameters since they may + # be changed when fitting interactively. + + call sprintf (Memc[str], SZ_LINE, + "Fit overscan vector for %s interactively") + call pargstr (image) + call set_interactive (Memc[str], interactive) + if ((interactive == YES) || (interactive == ALWAYSYES)) { + gt = gt_init () + call sprintf (Memc[str], SZ_LINE, + "Overscan vector for %s from section [%d:%d,%d:%d]\n") + call pargstr (image) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call gt_sets (gt, GTTITLE, Memc[str]) + call gt_sets (gt, GTTYPE, "line") + call gt_setr (gt, GTXMIN, x[1]) + call gt_setr (gt, GTXMAX, x[npts]) + call clgstr ("graphics", Memc[str], SZ_FNAME) + gp = gopen (Memc[str], NEW_FILE, STDGRAPH) + + call icg_fit (ic, gp, "cursor", gt, cv, x, overscan, Memr[w], npts) + + call ic_gstr (ic, "function", Memc[str], SZ_LINE) + call clpstr ("function", Memc[str]) + call clputi ("order", ic_geti (ic, "order")) + call ic_gstr (ic, "sample", Memc[str], SZ_LINE) + call clpstr ("sample", Memc[str]) + call clputi ("naverage", ic_geti (ic, "naverage")) + call clputi ("niterate", ic_geti (ic, "niterate")) + call clputr ("low_reject", ic_getr (ic, "low")) + call clputr ("high_reject", ic_getr (ic, "high")) + call clputr ("grow", ic_getr (ic, "grow")) + + call gclose (gp) + call gt_free (gt) + } else + call ic_fit (ic, cv, x, overscan, Memr[w], npts, YES, YES, YES, YES) + + # Make a log of the fit in the plot file if given. + call clgstr ("plotfile", Memc[str], SZ_LINE) + call xt_stripwhite (Memc[str]) + if (Memc[str] != EOS) { + fd = open (Memc[str], APPEND, BINARY_FILE) + gp = gopen ("stdvdm", NEW_FILE, fd) + gt = gt_init () + call sprintf (Memc[str], SZ_LINE, + "Overscan vector for %s from section [%d:%d,%d:%d]\n") + call pargstr (image) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call gt_sets (gt, GTTITLE, Memc[str]) + call gt_sets (gt, GTTYPE, "line") + call gt_setr (gt, GTXMIN, 1.) + call gt_setr (gt, GTXMAX, real (npts)) + call icg_graphr (ic, gp, gt, cv, x, overscan, Memr[w], npts) + call gclose (gp) + call close (fd) + call gt_free (gt) + } + + # Replace the raw overscan vector with the smooth fit. + call cvvector (cv, x, overscan, npts) + + # Finish up. + call ic_closer (ic) + call cvfree (cv) + call sfree (sp) +end + + +# TRIM_OVERSCAN -- Trim the overscan vector. + +procedure trim_overscan (data, npts, start, x, overscan) + +real data[ARB] # Full overscan vector +int npts # Length of trimmed vector +int start # Trim start +real x[npts] # Trimmed pixel coordinates (returned) +real overscan[npts] # Trimmed overscan vector (returned) + +int i, j + +begin + do i = 1, npts { + j = start + i - 1 + x[i] = j + overscan[i] = data[j] + } +end diff --git a/noao/imred/ccdred/src/setproc.x b/noao/imred/ccdred/src/setproc.x new file mode 100644 index 00000000..06c7977b --- /dev/null +++ b/noao/imred/ccdred/src/setproc.x @@ -0,0 +1,77 @@ +include <imhdr.h> +include "ccdred.h" + +# SET_PROC -- Set the processing parameter structure pointer. + +procedure set_proc (in, out, ccd) + +pointer in # Input IMIO pointer +pointer out # Output IMIO pointer +pointer ccd # CCD structure (returned) + +int clgwrd(), clscan(), nscan() +real clgetr() +pointer sp, str + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allocate the ccd structure. + call calloc (ccd, LEN_CCD, TY_STRUCT) + + IN_IM(ccd) = in + OUT_IM(ccd) = out + COR(ccd) = NO + CORS(ccd, FIXPIX) = NO + CORS(ccd, OVERSCAN) = NO + CORS(ccd, TRIM) = NO + READAXIS(ccd) = clgwrd ("readaxis",Memc[str],SZ_LINE,"|line|columns|") + MINREPLACE(ccd) = clgetr ("minreplace") + + CALCTYPE(ccd) = TY_REAL + if (clscan ("pixeltype") != EOF) { + call gargwrd (Memc[str], SZ_LINE) + call gargwrd (Memc[str], SZ_LINE) + if (nscan() == 2) { + if (Memc[str] == 'r') + CALCTYPE(ccd) = TY_REAL + else if (Memc[str] == 's') + CALCTYPE(ccd) = TY_SHORT + else + call error (1, "Invalid calculation datatype") + } + } + + call sfree (sp) +end + + +# FREE_PROC -- Free the processing structure pointer. + +procedure free_proc (ccd) + +pointer ccd # CCD structure + +begin + # Unmap calibration images. + if (MASK_IM(ccd) != NULL) + call imunmap (MASK_IM(ccd)) + if (ZERO_IM(ccd) != NULL) + call ccd_unmap (ZERO_IM(ccd)) + if (DARK_IM(ccd) != NULL) + call ccd_unmap (DARK_IM(ccd)) + if (FLAT_IM(ccd) != NULL) + call ccd_unmap (FLAT_IM(ccd)) + if (ILLUM_IM(ccd) != NULL) + call ccd_unmap (ILLUM_IM(ccd)) + if (FRINGE_IM(ccd) != NULL) + call ccd_unmap (FRINGE_IM(ccd)) + + # Free memory + if (OVERSCAN_VEC(ccd) != NULL) + call mfree (OVERSCAN_VEC(ccd), TY_REAL) + if (MASK_FP(ccd) != NULL) + call xt_fpfree (MASK_FP(ccd)) + call mfree (ccd, TY_STRUCT) +end diff --git a/noao/imred/ccdred/src/setsections.x b/noao/imred/ccdred/src/setsections.x new file mode 100644 index 00000000..80e61e49 --- /dev/null +++ b/noao/imred/ccdred/src/setsections.x @@ -0,0 +1,113 @@ +include <imhdr.h> +include <mwset.h> +include "ccdred.h" + +# SET_SECTIONS -- Set the data section, ccd section, trim section and +# bias section. Also set the WCS. + +procedure set_sections (ccd) + +pointer ccd # CCD structure (returned) + +pointer sp, str, mw, lterm, mw_openim() +int nc, nl, c1, c2, cs, l1, l2, ls, ndim, mw_stati() +bool streq() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + nc = IM_LEN(IN_IM(ccd),1) + nl = IM_LEN(IN_IM(ccd),2) + + # The default data section is the entire image. + c1 = 1 + c2 = nc + cs = 1 + l1 = 1 + l2 = nl + ls = 1 + call hdmgstr (IN_IM(ccd), "datasec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) + call error (0, "Error in DATASEC parameter") + IN_C1(ccd) = c1 + IN_C2(ccd) = c2 + IN_L1(ccd) = l1 + IN_L2(ccd) = l2 + + # The default trim section is the data section. + # Defer limit checking until actually used. + c1 = IN_C1(ccd) + c2 = IN_C2(ccd) + l1 = IN_L1(ccd) + l2 = IN_L2(ccd) + call clgstr ("trimsec", Memc[str], SZ_LINE) + if (streq (Memc[str], "image")) + call hdmgstr (IN_IM(ccd), "trimsec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((cs!=1)||(ls!=1)) + call error (0, "Error in TRIMSEC parameter") + TRIM_C1(ccd) = c1 + TRIM_C2(ccd) = c2 + TRIM_L1(ccd) = l1 + TRIM_L2(ccd) = l2 + + # The default bias section is the whole image. + # Defer limit checking until actually used. + c1 = 1 + c2 = nc + l1 = 1 + l2 = nl + call clgstr ("biassec", Memc[str], SZ_LINE) + if (streq (Memc[str], "image")) + call hdmgstr (IN_IM(ccd), "biassec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((cs!=1)||(ls!=1)) + call error (0, "Error in BIASSEC parameter") + BIAS_C1(ccd) = c1 + BIAS_C2(ccd) = c2 + BIAS_L1(ccd) = l1 + BIAS_L2(ccd) = l2 + + # The default ccd section is the size of the data section. + c1 = 1 + c2 = IN_C2(ccd) - IN_C1(ccd) + 1 + l1 = 1 + l2 = IN_L2(ccd) - IN_L1(ccd) + 1 + call hdmgstr (IN_IM(ccd), "ccdsec", Memc[str], SZ_LINE) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((cs != 1) || (ls != 1)) + call error (0, "Error in CCDSEC parameter") + CCD_C1(ccd) = c1 + CCD_C2(ccd) = c2 + CCD_L1(ccd) = l1 + CCD_L2(ccd) = l2 + if ((IN_C2(ccd)-IN_C1(ccd) != CCD_C2(ccd)-CCD_C1(ccd)) || + (IN_L2(ccd)-IN_L1(ccd) != CCD_L2(ccd)-CCD_L1(ccd))) + call error (0, "Size of DATASEC and CCDSEC do not agree") + + # The default output data section is the input data section. + OUT_C1(ccd) = IN_C1(ccd) + OUT_C2(ccd) = IN_C2(ccd) + OUT_L1(ccd) = IN_L1(ccd) + OUT_L2(ccd) = IN_L2(ccd) + + # Set the physical WCS to be CCD coordinates. + mw = mw_openim (IN_IM(ccd)) + ndim = mw_stati (mw, MW_NPHYSDIM) + call salloc (lterm, ndim * (1 + ndim), TY_REAL) + call mw_gltermr (mw, Memr[lterm+ndim], Memr[lterm], ndim) + Memr[lterm] = IN_C1(ccd) - CCD_C1(ccd) + Memr[lterm+1] = IN_L1(ccd) - CCD_L1(ccd) + Memr[lterm+ndim] = 1. / cs + Memr[lterm+ndim+1] = 0. + Memr[lterm+ndim+ndim] = 0. + Memr[lterm+ndim+ndim+1] = 1. / ls + call mw_sltermr (mw, Memr[lterm+ndim], Memr[lterm], ndim) + call mw_saveim (mw, IN_IM(ccd)) + call mw_saveim (mw, OUT_IM(ccd)) + call mw_close (mw) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/settrim.x b/noao/imred/ccdred/src/settrim.x new file mode 100644 index 00000000..65d5d09c --- /dev/null +++ b/noao/imred/ccdred/src/settrim.x @@ -0,0 +1,99 @@ +include <imhdr.h> +include <imset.h> +include "ccdred.h" + +# SET_TRIM -- Set the trim parameters. +# +# 1. Return immediately if the trim correction is not requested or +# if the image has been previously corrected. +# 2. Determine the trim section. This may be specifed directly or +# indirectly through the image header or symbol table. +# 3. Parse the trim section and apply it to the output image. +# 4. If the image is trimmed then log the operation and reset the output +# image size. + +procedure set_trim (ccd) + +pointer ccd # CCD structure + +int xt1, xt2, yt1, yt2 +int nc, nl, c1, c2, l1, l2 +pointer sp, str, image +bool clgetb(), ccdflag() + +begin + # Check if the user wants this operation or it has been done. + if (!clgetb ("trim") || ccdflag (IN_IM(ccd), "trim")) + return + + # Check trim section. + nc = IM_LEN(IN_IM(ccd),1) + nl = IM_LEN(IN_IM(ccd),2) + c1 = TRIM_C1(ccd) + c2 = TRIM_C2(ccd) + l1 = TRIM_L1(ccd) + l2 = TRIM_L2(ccd) + if ((c1 < 1) || (c2 > nc) || (l1 < 1) || (l2 > nl)) { + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (image, SZ_LINE, TY_CHAR) + call imstats (IN_IM(ccd), IM_IMAGENAME, Memc[image], SZ_FNAME) + call sprintf (Memc[str], SZ_LINE, + "Error in trim section: image=%s[%d,%d], trimsec=[%d:%d,%d:%d]") + call pargstr (Memc[image]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + + # If no processing is desired print trim section and return. + if (clgetb ("noproc")) { + call eprintf (" [TO BE DONE] Trim section is [%d:%d,%d:%d].\n") + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + return + } + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + xt1 = max (0, c1 - IN_C1(ccd)) + xt2 = min (0, c2 - IN_C2(ccd)) + yt1 = max (0, l1 - IN_L1(ccd)) + yt2 = min (0, l2 - IN_L2(ccd)) + + CCD_C1(ccd) = CCD_C1(ccd) + xt1 + CCD_C2(ccd) = CCD_C2(ccd) + xt2 + CCD_L1(ccd) = CCD_L1(ccd) + yt1 + CCD_L2(ccd) = CCD_L2(ccd) + yt2 + IN_C1(ccd) = IN_C1(ccd) + xt1 + IN_C2(ccd) = IN_C2(ccd) + xt2 + IN_L1(ccd) = IN_L1(ccd) + yt1 + IN_L2(ccd) = IN_L2(ccd) + yt2 + OUT_C1(ccd) = IN_C1(ccd) - c1 + 1 + OUT_C2(ccd) = IN_C2(ccd) - c1 + 1 + OUT_L1(ccd) = IN_L1(ccd) - l1 + 1 + OUT_L2(ccd) = IN_L2(ccd) - l1 + 1 + IM_LEN(OUT_IM(ccd),1) = c2 - c1 + 1 + IM_LEN(OUT_IM(ccd),2) = l2 - l1 + 1 + + CORS(ccd, TRIM) = YES + COR(ccd) = YES + + call sprintf (Memc[str], SZ_LINE, "Trim data section is [%d:%d,%d:%d]") + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "trim", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/setzero.x b/noao/imred/ccdred/src/setzero.x new file mode 100644 index 00000000..610aeee7 --- /dev/null +++ b/noao/imred/ccdred/src/setzero.x @@ -0,0 +1,141 @@ +# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. + +include <imhdr.h> +include "ccdred.h" +include "ccdtypes.h" + +# SET_ZERO -- Set parameters for zero level correction. +# 1. Return immediately if the zero level correction is not requested or +# if the image has been previously corrected. +# 2. Get the zero level correction image. Return an error if not found. +# 3. If the zero level image has not been processed call ZEROPROC. +# 4. Set the processing flag. +# 5. Log the operation (to user, logfile, and output image header). + +procedure set_zero (ccd) + +pointer ccd # CCD structure + +int nscan, nc, nl, c1, c2, cs, l1, l2, ls, data_c1, ccd_c1, data_l1, ccd_l1 +pointer sp, str, image, im, ccd_cache() +bool clgetb(), ccdflag(), ccdcheck() +int ccdtypei(), ccdnscan() +errchk cal_image, ccd_cache, ccdproc + +begin + # Check if the user wants this operation or it has been done. + if (!clgetb ("zerocor") || ccdflag (IN_IM(ccd), "zerocor")) + return + + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the zero level correction image. + if (clgetb ("scancor")) + nscan = ccdnscan (IN_IM(ccd), ccdtypei(IN_IM(ccd))) + else + nscan = 1 + call cal_image (IN_IM(ccd), ZERO, nscan, Memc[image], SZ_FNAME) + + # If no processing is desired print zero correction image and return. + if (clgetb ("noproc")) { + call eprintf (" [TO BE DONE] Zero level correction image is %s.\n") + call pargstr (Memc[image]) + call sfree (sp) + return + } + + # Map the image and return on an error. + # Process the zero image if necessary. + # If nscan > 1 then the zero may not yet exist so create it + # from the unscanned zero. + + iferr (im = ccd_cache (Memc[image], ZERO)) { + call cal_image (IN_IM(ccd), ZERO, 1, Memc[str], SZ_LINE) + im = ccd_cache (Memc[str], ZERO) + if (ccdcheck (im, ZERO)) { + call ccd_flush (im) + call ccdproc (Memc[str], ZERO) + } + call scancor (Memc[str], Memc[image], nscan, INDEF) + im = ccd_cache (Memc[image], ZERO) + } + + if (ccdcheck (im, ZERO)) { + call ccd_flush (im) + call ccdproc (Memc[image], ZERO) + im = ccd_cache (Memc[image], ZERO) + } + + # Set the processing parameters in the CCD structure. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + c1 = 1 + c2 = nc + l1 = 1 + l2 = nl + cs = 1 + ls = 1 + call hdmgstr (im, "datasec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) { + call sprintf (Memc[str], SZ_LINE, + "Data section error: image=%s[%d,%d], datasec=[%d:%d,%d:%d]") + call pargstr (Memc[image]) + call pargi (nc) + call pargi (nl) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + data_c1 = c1 + data_l1 = l1 + call hdmgstr (im, "ccdsec", Memc[str], SZ_FNAME) + call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) + if (nc == 1) { + c1 = CCD_C1(ccd) + c2 = CCD_C2(ccd) + } + if (nl == 1) { + l1 = CCD_L1(ccd) + l2 = CCD_L2(ccd) + } + ccd_c1 = c1 + ccd_l1 = l1 + if ((c1 > CCD_C1(ccd)) || (c2 < CCD_C2(ccd)) || + (l1 > CCD_L1(ccd)) || (l2 < CCD_L2(ccd))) { + call sprintf (Memc[str], SZ_LINE, + "CCD section error: input=[%d:%d,%d:%d], %s=[%d:%d,%d:%d]") + call pargi (CCD_C1(ccd)) + call pargi (CCD_C2(ccd)) + call pargi (CCD_L1(ccd)) + call pargi (CCD_L2(ccd)) + call pargstr (Memc[image]) + call pargi (c1) + call pargi (c2) + call pargi (l1) + call pargi (l2) + call error (0, Memc[str]) + } + + ZERO_IM(ccd) = im + ZERO_C1(ccd) = CCD_C1(ccd) - ccd_c1 + data_c1 + ZERO_C2(ccd) = CCD_C2(ccd) - ccd_c1 + data_c1 + ZERO_L1(ccd) = CCD_L1(ccd) - ccd_l1 + data_l1 + ZERO_L2(ccd) = CCD_L2(ccd) - ccd_l1 + data_l1 + + CORS(ccd, ZEROCOR) = Z + COR(ccd) = YES + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, "Zero level correction image is %s") + call pargstr (Memc[image]) + call timelog (Memc[str], SZ_LINE) + call ccdlog (IN_IM(ccd), Memc[str]) + call hdmpstr (OUT_IM(ccd), "zerocor", Memc[str]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/sigma.gx b/noao/imred/ccdred/src/sigma.gx new file mode 100644 index 00000000..8b59f1f6 --- /dev/null +++ b/noao/imred/ccdred/src/sigma.gx @@ -0,0 +1,89 @@ +$for (sr) +# SIGMA -- Compute sigma line from image lines with rejection. + +procedure sigma$t (data, nimages, mean, sigma, npts) + +pointer data[nimages] # Data vectors +int nimages # Number of data vectors +$if (datatype == sil) +real mean[npts] # Mean vector +real sigma[npts] # Sigma vector (returned) +$else +PIXEL mean[npts] # Mean vector +PIXEL sigma[npts] # Sigma vector (returned) +$endif +int npts # Number of points in each vector + +$if (datatype == sil) +real val, sig, pixval +$else +PIXEL val, sig, pixval +$endif +int i, j, n, n1 + +begin + n = nimages - 1 + do i = 1, npts { + val = mean[i] + sig = 0. + n1 = n + do j = 1, nimages { + pixval = Mem$t[data[j]+i-1] + if (IS_INDEF (pixval)) + n1 = n1 - 1 + else + sig = sig + (pixval - val) ** 2 + } + if (n1 > 0) + sigma[i] = sqrt (sig / n1) + else + sigma[i] = 0. + } +end + + +# WTSIGMA -- Compute scaled and weighted sigma line from image lines with +# rejection. + +procedure wtsigma$t (data, scales, zeros, wts, nimages, mean, sigma, npts) + +pointer data[nimages] # Data vectors +real scales[nimages] # Scale factors +real zeros[nimages] # Zero levels +real wts[nimages] # Weights +int nimages # Number of data vectors +$if (datatype == sil) +real mean[npts] # Mean vector +real sigma[npts] # Sigma vector (returned) +real val, sig, pixval +$else +PIXEL mean[npts] # Mean vector +PIXEL sigma[npts] # Sigma vector (returned) +PIXEL val, sig, pixval +$endif +int npts # Number of points in each vector + +int i, j, n +real sumwts + +begin + do i = 1, npts { + val = mean[i] + n = 0 + sig = 0. + sumwts = 0. + do j = 1, nimages { + pixval = Mem$t[data[j]+i-1] + if (!IS_INDEF (pixval)) { + n = n + 1 + sig = sig + wts[j]*(pixval/scales[j]-zeros[j]-val) ** 2 + sumwts = sumwts + wts[j] + } + } + if (n > 1) + sigma[i] = sqrt (sig / sumwts * n / (n - 1)) + else + sigma[i] = 0. + } +end +$endfor diff --git a/noao/imred/ccdred/src/t_badpixim.x b/noao/imred/ccdred/src/t_badpixim.x new file mode 100644 index 00000000..3a44dfa0 --- /dev/null +++ b/noao/imred/ccdred/src/t_badpixim.x @@ -0,0 +1,114 @@ +include <imhdr.h> + +# T_BADPIXIMAGE -- Create a bad pixel image mask from a bad pixel file. + +procedure t_badpiximage () + +pointer bpfile # Bad pixel file +pointer bpimage # Bad pixel image +pointer template # Template image +short goodval, badval # Good and bad values + +int i, nc, nl, c1, c2, l1, l2, fd, x1, x2, xstep, y1, y2, ystep +pointer sp, str, im, im1 + +short clgets() +bool ccdflag() +pointer immap(), impl2s(), imps2s() +int open(), fscan(), nscan(), stridxs(), strmatch() +errchk open, immap + +begin + call smark (sp) + call salloc (bpfile, SZ_FNAME, TY_CHAR) + call salloc (bpimage, SZ_FNAME, TY_CHAR) + call salloc (template, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get task parameters. + call clgstr ("fixfile", Memc[bpfile], SZ_FNAME) + call clgstr ("template", Memc[template], SZ_FNAME) + call clgstr ("image", Memc[bpimage], SZ_FNAME) + goodval = clgets ("goodvalue") + badval = clgets ("badvalue") + + # Open the files and abort on an error. + fd = open (Memc[bpfile], READ_ONLY, TEXT_FILE) + im1 = immap (Memc[template], READ_ONLY, 0) + im = immap (Memc[bpimage], NEW_COPY, im1) + + # Set the output image. + IM_PIXTYPE(im) = TY_SHORT + call sprintf (IM_TITLE(im), SZ_IMTITLE, + "Bad pixel image from bad pixel file %s") + call pargstr (Memc[bpfile]) + + # Set the good pixel values. + nc = IM_LEN(im,1) + nl = IM_LEN(im,2) + do i = 1, nl + call amovks (goodval, Mems[impl2s(im,i)], nc) + + # Set the bad pixel values. By default the bad pixel coordinates + # refer to the image directly but if the word "untrimmed" appears + # in a comment then the coordinates refer to the untrimmed image. + # This is the same algorithm as used in SETFIXPIX for CCDPROC. + + x1 = 1 + xstep = 1 + y1 = 1 + ystep = 1 + while (fscan (fd) != EOF) { + call gargwrd (Memc[str], SZ_LINE) + if (Memc[str] == '#') { + call gargstr (Memc[str], SZ_LINE) + if (strmatch (Memc[str], "{untrimmed}") != 0) { + if (ccdflag (im, "trim")) { + call hdmgstr (im, "trim", Memc[str], SZ_LINE) + x2 = stridxs ("[", Memc[str]) + if (x2 != 0) { + x1 = 1 + x2 = IM_LEN(im,1) + xstep = 1 + y1 = 1 + y2 = IM_LEN(im,2) + ystep = 1 + call ccd_section (Memc[str+x2-1], x1, x2, xstep, + y1, y2, ystep) + } + } + } + next + } + + call reset_scan() + call gargi (c1) + call gargi (c2) + call gargi (l1) + call gargi (l2) + if (nscan() != 4) { + if (nscan() == 2) { + l1 = c2 + c2 = c1 + l2 = l1 + } else + next + } + + c1 = max (1, (c1 - x1 + xstep - 1) / xstep + 1) + c2 = min (nc, (c2 - x1) / xstep + 1) + l1 = max (1, (l1 - y1 + ystep - 1) / ystep + 1) + l2 = min (nl, (l2 - y1) / ystep + 1) + + if ((c1 > c2) || (l1 > l2)) + next + + i = (c2 - c1 + 1) * (l2 - l1 + 1) + call amovks (badval, Mems[imps2s(im,c1,c2,l1,l2)], i) + } + + # Finish up. + call imunmap (im) + call imunmap (im1) + call close (fd) +end diff --git a/noao/imred/ccdred/src/t_ccdgroups.x b/noao/imred/ccdred/src/t_ccdgroups.x new file mode 100644 index 00000000..225589e5 --- /dev/null +++ b/noao/imred/ccdred/src/t_ccdgroups.x @@ -0,0 +1,258 @@ +include <error.h> +include <math.h> + +# Group type definitions. +define GROUPS "|position|title|date|ccdtype|subset|" +define POSITION 1 # Group by position +define TITLE 2 # Group by title +define DATE 3 # Group by date +define CCDTYPE 4 # Group by ccdtype +define SUBSET 5 # Group by subset + +define NALLOC 10 # Allocate memory in this size block + +# T_CCDGROUPS -- Group images into files based on parameters with common values. +# The output consists of files containing the image names of images from the +# input image list which have the same group type such as position, date, +# or title. + +procedure t_ccdgroups () + +int images # List of images +pointer root # Output group root name +int group # Group type +real radius # Position radius +bool verbose # Verbose output (package parameter) + +int ngroup, fd, ntitles, npositions, ndates, ccdtype +pointer im, sp, image, output, suffix, titles, positions, dates + +bool clgetb() +real clgetr() +int position_group(), title_group(), date_group() +int imtopenp(), imtgetim(), open(), clgwrd() +errchk set_input, position_group, title_group, date_group, open + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (suffix, SZ_FNAME, TY_CHAR) + + # Get the task parameters. + images = imtopenp ("images") + call clgstr ("output", Memc[root], SZ_FNAME) + group = clgwrd ("group", Memc[image], SZ_FNAME, GROUPS) + radius = clgetr ("radius") + call clgstr ("instrument", Memc[image], SZ_FNAME) + if (Memc[image] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[image]) + verbose = clgetb ("verbose") + + # Loop through the images and place them into groups. + positions = NULL + npositions = 0 + titles = NULL + ntitles = 0 + dates = NULL + ndates = 0 + while (imtgetim (images, Memc[image], SZ_FNAME) != EOF) { + call set_input (Memc[image], im, ccdtype) + if (im == NULL) + next + + iferr { + switch (group) { + case POSITION: + ngroup = position_group (im, positions, npositions, radius) + case TITLE: + ngroup = title_group (im, titles, ntitles) + case DATE: + ngroup = date_group (im, dates, ndates) + } + + # Define the output group file. + switch (group) { + case POSITION, TITLE, DATE: + call sprintf (Memc[output], SZ_FNAME, "%s%d") + call pargstr (Memc[root]) + call pargi (ngroup) + case CCDTYPE: + call ccdtypes (im, Memc[suffix], SZ_FNAME) + call sprintf (Memc[output], SZ_FNAME, "%s%d") + call pargstr (Memc[root]) + call pargstr (Memc[suffix]) + case SUBSET: + call ccdsubset (im, Memc[suffix], SZ_FNAME) + call sprintf (Memc[output], SZ_FNAME, "%s%d") + call pargstr (Memc[root]) + call pargstr (Memc[suffix]) + } + + # Print the operation if verbose. + if (verbose) { + call printf ("%s --> %s\n") + call pargstr (Memc[image]) + call pargstr (Memc[output]) + } + + # Enter the image in the appropriate group file. + fd = open (Memc[output], APPEND, TEXT_FILE) + call fprintf (fd, "%s\n") + call pargstr (Memc[image]) + call close (fd) + } then + call erract (EA_WARN) + + call imunmap (im) + } + + # Finish up. + call imtclose (images) + if (positions != NULL) + call mfree (positions, TY_REAL) + if (titles != NULL) + call mfree (titles, TY_CHAR) + if (dates != NULL) + call mfree (dates, TY_CHAR) + call sfree (sp) +end + + +# TITLE_GROUP -- Group images by title. + +int procedure title_group (im, titles, ntitles) + +pointer im # Image +pointer titles # Pointer to title strings +int ntitles # Number of titles + +int i, nalloc +pointer sp, title, ptr +bool streq() +errchk hdmgstr + +begin + call smark (sp) + call salloc (title, SZ_LINE, TY_CHAR) + call hdmgstr (im, "title", Memc[title], SZ_LINE) + + for (i=1; i<=ntitles; i=i+1) { + ptr = titles + (i - 1) * SZ_LINE + if (streq (Memc[title], Memc[ptr])) + break + } + if (i > ntitles) { + if (i == 1) { + nalloc = NALLOC + call malloc (titles, nalloc * SZ_LINE, TY_CHAR) + } else if (i > nalloc) { + nalloc = nalloc + NALLOC + call realloc (titles, nalloc * SZ_LINE, TY_CHAR) + } + ptr = titles + (i - 1) * SZ_LINE + call strcpy (Memc[title], Memc[ptr], SZ_LINE-1) + ntitles = i + } + + call sfree (sp) + return (i) +end + + +# POSITION_GROUP -- Group by RA and DEC position. The RA is in hours and +# the DEC is in degrees. The radius is in seconds of arc. + +int procedure position_group (im, positions, npositions, radius) + +pointer im # Image +pointer positions # Positions +int npositions # Number of positions +real radius # Matching radius + +real ra, dec, dra, ddec, r, hdmgetr() +int i, nalloc +pointer ptr +errchk hdmgetr + +begin + ra = hdmgetr (im, "ra") + dec = hdmgetr (im, "dec") + + for (i=1; i<=npositions; i=i+1) { + ptr = positions + 2 * i - 2 + dra = ra - Memr[ptr] + ddec = dec - Memr[ptr+1] + if (dra > 12.) + dra = dra - 24. + if (dra < -12.) + dra = dra + 24. + dra = dra * cos (DEGTORAD (dec)) * 15. + r = sqrt (dra ** 2 + ddec ** 2) * 3600. + if (r < radius) + break + } + if (i > npositions) { + if (i == 1) { + nalloc = NALLOC + call malloc (positions, nalloc * 2, TY_REAL) + } else if (i > nalloc) { + nalloc = nalloc + NALLOC + call realloc (positions, nalloc * 2, TY_REAL) + } + ptr = positions + 2 * i - 2 + Memr[ptr] = ra + Memr[ptr+1] = dec + npositions = i + } + + return (i) +end + + +# DATE_GROUP -- Group by date. + +int procedure date_group (im, dates, ndates) + +pointer im # Image +pointer dates # Pointer to date strings +int ndates # Number of dates + +int i, nalloc, stridxs() +pointer sp, date, ptr +bool streq() +errchk hdmgstr + +begin + call smark (sp) + call salloc (date, SZ_LINE, TY_CHAR) + call hdmgstr (im, "date-obs", Memc[date], SZ_LINE) + + # Strip time if present. + i = stridxs ("T", Memc[date]) + if (i > 0) + Memc[date+i-1] = EOS + + for (i=1; i<=ndates; i=i+1) { + ptr = dates + (i - 1) * SZ_LINE + if (streq (Memc[date], Memc[ptr])) + break + } + if (i > ndates) { + if (i == 1) { + nalloc = NALLOC + call malloc (dates, nalloc * SZ_LINE, TY_CHAR) + } else if (i > nalloc) { + nalloc = nalloc + NALLOC + call realloc (dates, nalloc * SZ_LINE, TY_CHAR) + } + ptr = dates + (i - 1) * SZ_LINE + call strcpy (Memc[date], Memc[ptr], SZ_LINE-1) + ndates = i + } + + call sfree (sp) + return (i) +end diff --git a/noao/imred/ccdred/src/t_ccdhedit.x b/noao/imred/ccdred/src/t_ccdhedit.x new file mode 100644 index 00000000..a7fd9121 --- /dev/null +++ b/noao/imred/ccdred/src/t_ccdhedit.x @@ -0,0 +1,87 @@ +include <error.h> + +define TYPES "|string|real|integer|" +define SVAL 1 # String value +define RVAL 2 # Real value +define IVAL 3 # Integer value + +# T_CCDHEDIT -- Add, delete, or change CCD image header parameters. +# This task differs from HEDIT in that it uses the CCD instrument translation +# file. + +procedure t_ccdhedit () + +int list # List of CCD images +pointer param # Parameter name +int type # Parameter type +pointer sval # Parameter value +pointer instrument # Instrument file + +int ip, ival, imtopenp(), imtgetim(), clgwrd(), ctoi(), ctor() +real rval +bool streq() +pointer sp, im, immap() +errchk hdmpstr, hdmputr, hdmputi + +begin + call smark (sp) + call salloc (param, SZ_LINE, TY_CHAR) + call salloc (sval, SZ_LINE, TY_CHAR) + call salloc (instrument, SZ_FNAME, TY_CHAR) + + # Get the task parameters. + list = imtopenp ("images") + call clgstr ("parameter", Memc[param], SZ_LINE) + type = clgwrd ("type", Memc[sval], SZ_LINE, TYPES) + call clgstr ("value", Memc[sval], SZ_LINE) + call clgstr ("instrument", Memc[instrument], SZ_FNAME) + call xt_stripwhite (Memc[sval]) + + # Open the instrument translation file. + call hdmopen (Memc[instrument]) + + # If the parameter is IMAGETYP then change the parameter value from + # the package form to the image form using the inverse mapping in the + # translation file. + + if (streq (Memc[param], "imagetyp")) + call hdmparm (Memc[sval], Memc[sval], SZ_LINE) + + # Edit each image in the input list. + while (imtgetim (list, Memc[instrument], SZ_FNAME) != EOF) { + iferr (im = immap (Memc[instrument], READ_WRITE, 0)) { + call erract (EA_WARN) + next + } + + # If the parameter value is null then delete the entry. + if (Memc[sval] == EOS) { + iferr (call hdmdelf (im, Memc[param])) + call erract (EA_WARN) + + # Otherwise add the parameter of the specified type. + } else { + switch (type) { + case SVAL: + call hdmpstr (im, Memc[param], Memc[sval]) + case RVAL: + ip = 1 + if (ctor (Memc[sval], ip, rval) == 0) + call error (0, "Parameter value is not a number") + call hdmputr (im, Memc[param], rval) + case IVAL: + ip = 1 + if (ctoi (Memc[sval], ip, ival) == 0) + call error (0, "Parameter value is not a number") + call hdmputi (im, Memc[param], ival) + } + } + + call imunmap (im) + } + + # Finish up. + call hdmclose () + call imtclose (list) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_ccdinst.x b/noao/imred/ccdred/src/t_ccdinst.x new file mode 100644 index 00000000..e98763fd --- /dev/null +++ b/noao/imred/ccdred/src/t_ccdinst.x @@ -0,0 +1,667 @@ +include <imhdr.h> +include <imio.h> +include <error.h> +include "ccdtypes.h" + +define HELP1 "noao$imred/ccdred/src/ccdinst1.key" +define HELP2 "noao$imred/ccdred/src/ccdinst2.key" +define HELP3 "noao$imred/ccdred/src/ccdinst3.key" + +define LEVELS "|basic|common|all|" + +define CMDS "|quit|?|help|show|instrument|imheader|read|write|newimage\ + |translate|imagetyp|subset|exptime|darktime|fixfile|biassec\ + |ccdsec|datasec|trimsec|darkcor|fixpix|flatcor|fringcor\ + |illumcor|overscan|readcor|scancor|trim|zerocor|ccdmean\ + |fringscl|illumflt|mkfringe|mkillum|skyflat|ncombine\ + |date-obs|dec|ra|title|next|nscanrow|" + +define QUIT 1 # Quit +define QUESTION 2 # Help +define HELP 3 # Help +define SHOW 4 # Show current translations +define INST 5 # Show instrument file +define IMHEADER 6 # Print image header +define READ 7 # Read instrument file +define WRITE 8 # Write instrument file +define NEWIMAGE 9 # Change image +define TRANSLATE 10 # Translate image type +define IMAGETYPE 11 # Image type +define SUBSET 12 # Subset parameter +define EXPTIME 13 # Exposure time +define DARKTIME 14 # Dark time +define FIXFILE 15 # Bad pixel file +define BIASSEC 16 # Bias section +define CCDSEC 17 # CCD section +define DATASEC 18 # Data section +define TRIMSEC 19 # Trim section +define DARKCOR 20 # Dark count flag +define FIXPIX 21 # Bad pixel flag +define FLATCOR 22 # Flat field flag +define FRINGCOR 23 # Fringe flag +define ILLUMCOR 24 # Illumination flag +define OVERSCAN 25 # Overscan flag +define READCOR 26 # Readout flag +define SCANCOR 27 # Scan mode flag +define NSCANROW 42 # Number of scan rows +define TRIM 28 # Trim flag +define ZEROCOR 29 # Zero level flag +define CCDMEAN 30 # CCD mean value +define FRINGSCL 31 # Fringe scale value +define ILLUMFLT 32 # Illumination flat flag +define MKFRINGE 33 # Illumination flag +define MKILLUM 34 # Illumination flag +define SKYFLAT 35 # Sky flat flag +define NCOMBINE 36 # NCOMBINE parameter +define DATEOBS 37 # Date +define DEC 38 # Dec +define RA 39 # RA +define TITLE 40 # Title +define NEXT 41 # Next image + +# T_CCDINST -- Check and modify instrument translations + +procedure t_ccdinst () + +int list, level, ncmd, imtopenp(), imtgetim(), scan(), access(), clgwrd() +pointer sp, image, inst, ssfile, im, immap() +bool update, clgetb() +errchk delete, hdmwrite + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (inst, SZ_FNAME, TY_CHAR) + call salloc (ssfile, SZ_FNAME, TY_CHAR) + + # Get the task parameters, open the translation file, set defaults. + list = imtopenp ("images") + call clgstr ("instrument", Memc[inst], SZ_FNAME) + call clgstr ("ssfile", Memc[ssfile], SZ_FNAME) + level = clgwrd ("parameters", Memc[image], SZ_FNAME, LEVELS) + if (Memc[image] == EOS) + call error (1, "No 'parameters' file value specified.") + call hdmopen (Memc[inst]) + ncmd = NEXT + update = false + + # Process each image. + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + + if (clgetb ("edit")) + call ccdinst_edit (im, Memc[image], Memc[inst], Memc[ssfile], + level, ncmd, update) + else + call ccdinst_hdr (im, Memc[image], Memc[inst], Memc[ssfile], + level) + call imunmap (im) + if (ncmd == QUIT) + break + } + + # Update instrument file if necessary. + if (update) { + call printf ("Update instrument file %s (%b)? ") + call pargstr (Memc[inst]) + call pargb (update) + call flush (STDOUT) + if (scan() != EOF) + call gargb (update) + if (update) { + iferr { + if (access (Memc[inst], 0, 0) == YES) + call delete (Memc[inst]) + call hdmwrite (Memc[inst], NEW_FILE) + } then + call erract (EA_WARN) + } + } + + # Finish up. + call hdmclose () + call imtclose (list) + call sfree (sp) +end + + +# CCDINST_EDIT -- Main instrument file editor loop. +# This returns the last command (quit or next) and the update flag. +# The image name may also be changed. + +procedure ccdinst_edit (im, image, inst, ssfile, level, ncmd, update) + +pointer im # Image pointer +char image[SZ_FNAME] # Image name +char inst[SZ_FNAME] # Instrument file +char ssfile[SZ_FNAME] # Subset file +int level # Parameter level +int ncmd # Last command +bool update # Update? + +bool strne() +int scan(), nscan(), strdic(), access() +pointer sp, cmd, key, def, imval, im1, immap() +errchk delete, hdmwrite + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (def, SZ_LINE, TY_CHAR) + call salloc (imval, SZ_LINE, TY_CHAR) + + call sscan ("show") + repeat { + call gargwrd (Memc[cmd], SZ_LINE) + ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) + switch (ncmd) { + case NEXT, QUIT: + break + case QUESTION, HELP: + if (level == 1) + call pagefile (HELP1, "ccdinstrument") + else if (level == 2) + call pagefile (HELP2, "ccdinstrument") + else if (level == 3) + call pagefile (HELP3, "ccdinstrument") + case SHOW: + call ccdinst_hdr (im, image, inst, ssfile, level) + case INST: + call hdmwrite ("STDOUT", APPEND) + call printf ("\n") + case IMHEADER: + call ccdinst_i (im, image) + case READ: + call gargwrd (Memc[imval], SZ_LINE) + if (nscan() < 2) + call ccdinst_g ("Instrument file", inst, Memc[imval]) + if (update) + call printf ("WARNING: Previous changes lost\n") + call hdmclose () + update = false + if (strne (inst, Memc[imval])) { + iferr (call hdmopen (Memc[imval])) { + call erract (EA_WARN) + call hdmopen (inst) + } else { + call ccdinst_hdr (im, image, inst, ssfile, level) + update = true + } + } + case WRITE: + call gargwrd (Memc[imval], SZ_LINE) + if (nscan() < 2) + call ccdinst_g ("Instrument file", inst, Memc[imval]) + iferr { + if (access (Memc[imval], 0, 0) == YES) + call delete (Memc[imval]) + call hdmwrite (Memc[imval], NEW_FILE) + update = false + } then + call erract (EA_WARN) + case NEWIMAGE: + call gargwrd (Memc[imval], SZ_LINE) + if (nscan() < 2) + call ccdinst_g ("New image name", image, Memc[imval]) + if (strne (image, Memc[imval])) { + iferr (im1 = immap (Memc[imval], READ_ONLY, 0)) { + call erract (EA_WARN) + im1 = NULL + } + if (im1 != NULL) { + call imunmap (im) + im = im1 + call strcpy (Memc[imval], image, SZ_FNAME) + call ccdinst_hdr (im, image, inst, ssfile, level) + } + } + case TRANSLATE: + call ccdtypes (im, Memc[cmd], SZ_LINE) + call hdmgstr (im, "imagetyp", Memc[imval], SZ_LINE) + + call gargwrd (Memc[def], SZ_FNAME) + if (nscan() < 2) { + call printf ("CCDRED image type for '%s' (%s): ") + call pargstr (Memc[imval]) + call pargstr (Memc[cmd]) + call flush (STDOUT) + if (scan() != EOF) + call gargwrd (Memc[def], SZ_FNAME) + if (nscan() == 0) + call strcpy (Memc[cmd], Memc[def], SZ_LINE) + } + if (strdic (Memc[def], Memc[def], SZ_LINE, CCDTYPES) == 0) { + call printf ("Unknown CCDRED image type\n") + call strcpy (Memc[cmd], Memc[def], SZ_LINE) + } + if (strne (Memc[def], Memc[cmd])) { + call hdmpname (Memc[imval], Memc[def]) + call ccdinst_p (im, "imagetyp", + Memc[key], Memc[def], Memc[imval]) + update = true + } + case IMAGETYPE: + call ccdinst_e (im, "image type", "imagetyp", + Memc[key], Memc[def], Memc[imval], update) + case SUBSET: + call ccdinst_e (im, "subset parameter", "subset", + Memc[key], Memc[def], Memc[imval], update) + case EXPTIME: + call ccdinst_e (im, "exposure time", "exptime", + Memc[key], Memc[def], Memc[imval], update) + case DARKTIME: + call ccdinst_e (im, "dark time", "darktime", + Memc[key], Memc[def], Memc[imval], update) + case FIXFILE: + call ccdinst_e (im, "bad pixel file", "fixfile", + Memc[key], Memc[def], Memc[imval], update) + case BIASSEC: + call ccdinst_e (im, "bias section", "biassec", + Memc[key], Memc[def], Memc[imval], update) + case CCDSEC: + call ccdinst_e (im, "original CCD section", "ccdsec", + Memc[key], Memc[def], Memc[imval], update) + case DATASEC: + call ccdinst_e (im, "data section", "datasec", + Memc[key], Memc[def], Memc[imval], update) + case TRIMSEC: + call ccdinst_e (im, "trim section", "trimsec", + Memc[key], Memc[def], Memc[imval], update) + case DARKCOR: + call ccdinst_e (im, "dark count flag", "darkcor", + Memc[key], Memc[def], Memc[imval], update) + case FIXPIX: + call ccdinst_e (im, "bad pixel flag", "fixpix", + Memc[key], Memc[def], Memc[imval], update) + case FLATCOR: + call ccdinst_e (im, "flat field flag", "flatcor", + Memc[key], Memc[def], Memc[imval], update) + case FRINGCOR: + call ccdinst_e (im, "fringe flag", "fringcor", + Memc[key], Memc[def], Memc[imval], update) + case ILLUMCOR: + call ccdinst_e (im, "illumination flag", "illumcor", + Memc[key], Memc[def], Memc[imval], update) + case OVERSCAN: + call ccdinst_e (im, "overscan flag", "overscan", + Memc[key], Memc[def], Memc[imval], update) + case READCOR: + call ccdinst_e (im, "read correction flag", "readcor", + Memc[key], Memc[def], Memc[imval], update) + case SCANCOR: + call ccdinst_e (im, "scan mode flag", "scancor", + Memc[key], Memc[def], Memc[imval], update) + case NSCANROW: + call ccdinst_e (im, "scan mode rows", "nscanrow", + Memc[key], Memc[def], Memc[imval], update) + case TRIM: + call ccdinst_e (im, "trim flag", "trim", + Memc[key], Memc[def], Memc[imval], update) + case ZEROCOR: + call ccdinst_e (im, "zero level flag", "zerocor", + Memc[key], Memc[def], Memc[imval], update) + case CCDMEAN: + call ccdinst_e (im, "mean value", "ccdmean", + Memc[key], Memc[def], Memc[imval], update) + case FRINGSCL: + call ccdinst_e (im, "fringe scale", "fringscl", + Memc[key], Memc[def], Memc[imval], update) + case ILLUMFLT: + call ccdinst_e (im, "illumination flat image", "illumflt", + Memc[key], Memc[def], Memc[imval], update) + case MKFRINGE: + call ccdinst_e (im, "fringe image", "mkfringe", + Memc[key], Memc[def], Memc[imval], update) + case MKILLUM: + call ccdinst_e (im, "illumination image", "mkillum", + Memc[key], Memc[def], Memc[imval], update) + case SKYFLAT: + call ccdinst_e (im, "sky flat image", "skyflat", + Memc[key], Memc[def], Memc[imval], update) + case NCOMBINE: + call ccdinst_e (im, "number of images combined", "ncombine", + Memc[key], Memc[def], Memc[imval], update) + case DATEOBS: + call ccdinst_e (im, "date of observation", "date-obs", + Memc[key], Memc[def], Memc[imval], update) + case DEC: + call ccdinst_e (im, "declination", "dec", + Memc[key], Memc[def], Memc[imval], update) + case RA: + call ccdinst_e (im, "ra", "ra", + Memc[key], Memc[def], Memc[imval], update) + case TITLE: + call ccdinst_e (im, "title", "title", + Memc[key], Memc[def], Memc[imval], update) + default: + if (nscan() > 0) + call eprintf ("Unrecognized or ambiguous command\007\n") + } + call printf ("ccdinstrument> ") + call flush (STDOUT) + } until (scan() == EOF) + + call sfree (sp) +end + + +# CCDINST_HDR -- Print the current instrument translations for an image. + +procedure ccdinst_hdr (im, image, inst, ssfile, level) + +pointer im # Image pointer +char image[SZ_FNAME] # Image name +char inst[SZ_FNAME] # Instrument file +char ssfile[SZ_FNAME] # Subset file +int level # Parameter level + +pointer sp, key, def, ccdval, imval + +begin + call smark (sp) + call salloc (key, SZ_FNAME, TY_CHAR) + call salloc (def, SZ_LINE, TY_CHAR) + call salloc (ccdval, SZ_LINE, TY_CHAR) + call salloc (imval, SZ_LINE, TY_CHAR) + + # General stuff + call printf ("Image: %s\n") + call pargstr (image) + call printf ("Instrument file: %s\n") + call pargstr (inst) + call printf ("Subset file: %s\n") + call pargstr (ssfile) + + # Table labels + call printf ("\n%-8s %-8s %-8s %-8s %-8s\n") + call pargstr ("CCDRED") + call pargstr ("IMAGE") + call pargstr ("DEFAULT") + call pargstr ("CCDRED") + call pargstr ("IMAGE") + call printf ("%-8s %-8s %-8s %-8s %-8s\n") + call pargstr ("PARAM") + call pargstr ("KEYWORD") + call pargstr ("VALUE") + call pargstr ("VALUE") + call pargstr ("VALUE") + call printf ("---------------------------------------") + call printf ("---------------------------------------\n") + + # Print translations. Select those printed only with the all parameter. + call ccdinst_p (im, "imagetyp", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "subset", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "exptime", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "darktime", Memc[key], Memc[def], Memc[imval]) + if (level > 1) { + call printf ("\n") + call ccdinst_p (im, "biassec", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "trimsec", Memc[key], Memc[def], Memc[imval]) + call printf ("\n") + call ccdinst_p (im, "fixpix", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "overscan", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "trim", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "zerocor", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "darkcor", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "flatcor", Memc[key], Memc[def], Memc[imval]) + } + if (level > 2) { + call ccdinst_p (im, "datasec", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "ccdsec", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "fixfile", Memc[key], Memc[def], Memc[imval]) + call printf ("\n") + call ccdinst_p (im, "illumcor", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "fringcor", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "readcor", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "scancor", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "nscanrow", Memc[key], Memc[def], Memc[imval]) + call printf ("\n") + call ccdinst_p (im, "illumflt", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "mkfringe", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "mkillum", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "skyflat", Memc[key], Memc[def], Memc[imval]) + call printf ("\n") + call ccdinst_p (im, "ccdmean", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "fringscl", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "ncombine", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "date-obs", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "dec", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "ra", Memc[key], Memc[def], Memc[imval]) + call ccdinst_p (im, "title", Memc[key], Memc[def], Memc[imval]) + } + + call printf ("\n") + call flush (STDOUT) + call sfree (sp) +end + + +# CCDINST_P -- Print the translation for the specified translation name. + +procedure ccdinst_p (im, name, key, def, value) + +pointer im # Image pointer +char name[SZ_FNAME] # CCDRED name +char key[SZ_FNAME] # Image header keyword +char def[SZ_LINE] # Default value +char value[SZ_LINE] # Value + +int i, strdic(), hdmaccf() +bool bval, ccdflag() + +begin + i = strdic (name, key, SZ_FNAME, CMDS) + if (i == 0) + return + + # Get translaltion image keyword, default, and image value. + call hdmname (name, key, SZ_FNAME) + call hdmgdef (name, def, SZ_LINE) + call hdmgstr (im, name, value, SZ_LINE) + if (value[1] == EOS) + call strcpy ("?", value, SZ_LINE) + + switch (i) { + case IMAGETYPE: + call printf ("%-8s %-8s %-8s") + call pargstr (name) + call pargstr (key) + call pargstr (def) + call ccdtypes (im, def, SZ_LINE) + call printf (" %-8s %-.39s\n") + call pargstr (def) + call pargstr (value) + case SUBSET: + call printf ("%-8s %-8s %-8s") + call pargstr (name) + call pargstr (key) + call pargstr (def) + call ccdsubset (im, def, SZ_LINE) + call printf (" %-8s %-.39s\n") + call pargstr (def) + call pargstr (value) + case FIXPIX, OVERSCAN, TRIM, ZEROCOR, DARKCOR, FLATCOR, ILLUMCOR, + FRINGCOR, READCOR, SCANCOR, ILLUMFLT, MKFRINGE, MKILLUM, + SKYFLAT: + bval = ccdflag (im, name) + if (hdmaccf (im, name) == NO) + call strcpy ("?", value, SZ_LINE) + call printf ("%-8s %-8s %-8s %-8b %-.39s\n") + call pargstr (name) + call pargstr (key) + call pargstr (def) + call pargb (bval) + call pargstr (value) + default: + call printf ("%-8s %-8s %-8s %-8s") + call pargstr (name) + call pargstr (key) + call pargstr (def) + call pargstr (value) + if (hdmaccf (im, name) == NO) + call strcpy ("?", value, SZ_LINE) + call printf (" %-.39s\n") + call pargstr (value) + } +end + + +# CCDINST_E -- Edit a single translation entry. +# This checks for parameters on the command line and if missing queries. +# The default value may only be changed on the command line. + +procedure ccdinst_e (im, prompt, name, key, def, imval, update) + +pointer im # Image pointer +char prompt[ARB] # Parameter prompt name +char name[SZ_FNAME] # CCDRED name +char key[SZ_FNAME] # Image header keyword +char def[SZ_LINE] # Default value +char imval[SZ_LINE] # Value +bool update # Update translation file? + +bool strne() +int i, scan(), nscan() +pointer sp, oldkey, olddef + +begin + call smark (sp) + call salloc (oldkey, SZ_FNAME, TY_CHAR) + call salloc (olddef, SZ_LINE, TY_CHAR) + + # Get command line values + call gargwrd (key, SZ_FNAME) + call gargwrd (def, SZ_LINE) + + # Get current values + call hdmname (name, Memc[oldkey], SZ_FNAME) + call hdmgdef (name, Memc[olddef], SZ_LINE) + + # Query for keyword if needed. + i = nscan() + if (i < 2) { + call printf ("Image keyword for %s (%s): ") + call pargstr (prompt) + call pargstr (Memc[oldkey]) + call flush (STDOUT) + if (scan() != EOF) + call gargwrd (key, SZ_FNAME) + if (nscan() == 0) + call strcpy (Memc[oldkey], key, SZ_FNAME) + } + if (i < 3) { + #call printf ("Default %s (%s): ") + # call pargstr (prompt) + # call pargstr (Memc[olddef]) + #call flush (STDOUT) + #if (scan() != EOF) + # call gargwrd (def, SZ_LINE) + #if (nscan() == 0) + call strcpy (Memc[olddef], def, SZ_LINE) + } + + # Update only if the new value is different from the old value. + if (strne (key, Memc[oldkey])) { + call hdmpname (name, key) + update = true + } + if (strne (def, Memc[olddef])) { + call hdmpdef (name, def) + update = true + } + + # Print the revised translation. + call ccdinst_p (im, name, key, def, imval) + call sfree (sp) +end + + +# CCDINST_G -- General procedure to prompt for value. + +procedure ccdinst_g (prompt, def, val) + +char prompt[ARB] # Prompt +char def[ARB] # Default value +char val[SZ_LINE] # Value + +int scan(), nscan() + +begin + call printf ("%s (%s): ") + call pargstr (prompt) + call pargstr (def) + call flush (STDOUT) + if (scan() != EOF) + call gargwrd (val, SZ_FNAME) + if (nscan() == 0) + call strcpy (def, val, SZ_LINE) +end + + +define USER_AREA Memc[($1+IMU-1)*SZ_STRUCT + 1] + +# CCDINST_IMH -- Print the user area of the image, if nonzero length +# and it contains only ascii values. This copied from the code for +# IMHEADER. It differs in including the OBJECT keyword, using a temporary +# file to page the header, and no leading blanks. + +procedure ccdinst_i (im, image) + +pointer im # image descriptor +char image[ARB] # image name + +pointer sp, tmp, lbuf, ip +int in, out, ncols, min_lenuserarea +int open(), stropen(), getline(), envgeti() + +begin + call smark (sp) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (lbuf, SZ_LINE, TY_CHAR) + + # Open user area in header. + min_lenuserarea = (LEN_IMDES + IM_LENHDRMEM(im) - IMU) * SZ_STRUCT - 1 + in = stropen (USER_AREA(im), min_lenuserarea, READ_ONLY) + ncols = envgeti ("ttyncols") + + # Open temporary output file. + call mktemp ("tmp$", Memc[tmp], SZ_FNAME) + iferr (out = open (Memc[tmp], NEW_FILE, TEXT_FILE)) { + call erract (EA_WARN) + call sfree (sp) + return + } + + # Copy standard header records. + call fprintf (out, "OBJECT = '%s'\n") + call pargstr (IM_TITLE(im)) + + # Copy header records to the output, stripping any trailing + # whitespace and clipping at the right margin. + + while (getline (in, Memc[lbuf]) != EOF) { + for (ip=lbuf; Memc[ip] != EOS && Memc[ip] != '\n'; ip=ip+1) + ; + while (ip > lbuf && Memc[ip-1] == ' ') + ip = ip - 1 + if (ip - lbuf > ncols) + ip = lbuf + ncols + Memc[ip] = '\n' + Memc[ip+1] = EOS + + call putline (out, Memc[lbuf]) + } + call putline (out, "\n") + + call close (in) + call close (out) + + call pagefile (Memc[tmp], image) + call delete (Memc[tmp]) + + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_ccdlist.x b/noao/imred/ccdred/src/t_ccdlist.x new file mode 100644 index 00000000..1b438b27 --- /dev/null +++ b/noao/imred/ccdred/src/t_ccdlist.x @@ -0,0 +1,325 @@ +include <imhdr.h> +include <error.h> +include "ccdtypes.h" + +define SZ_CCDLINE 80 # Size of line for output + + +# T_CCDLIST -- List CCD image information and processing status. +# +# Each input image of the specified image type is listed in either a one +# line short format, a name only format, or a longer format. The image +# name, size, pixel type, image type, subset ID, processing flags and +# title are printed on one line. For the long format image details of +# the processing operations are printed. + +procedure t_ccdlist () + +int list, ccdtype +bool names, lformat +pointer sp, image, im + +bool clgetb() +int imtopenp(), imtgetim() + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + + # Get the task parameters and open the translation file. + list = imtopenp ("images") + names = clgetb ("names") + lformat = clgetb ("long") + call clgstr ("instrument", Memc[image], SZ_FNAME) + if (Memc[image] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[image]) + + # List each iamge. + while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { + # Map the image and the instrument header translation. + # Check the image type. + call set_input (Memc[image], im, ccdtype) + if (im == NULL) + next + + # Select the output format. + if (names) { + call printf ("%s\n") + call pargstr (Memc[image]) + } else if (lformat) { + call shortlist (Memc[image], ccdtype, im) + call longlist (im, ccdtype) + } else + call shortlist (Memc[image], ccdtype, im) + call flush (STDOUT) + + call imunmap (im) + } + + # Finish up. + call hdmclose () + call imtclose (list) + call sfree (sp) +end + + +# SHORTLIST -- List the one line short format consisting of the image name, +# iamge size, pixel type, image type, subset ID, processing flags, and +# title. + +procedure shortlist (image, ccdtype, im) + +char image # Image name +int ccdtype # CCD image type +pointer im # IMIO pointer + +bool ccdflag() +pointer sp, str, subset + +begin + call smark (sp) + call salloc (str, SZ_CCDLINE, TY_CHAR) + call salloc (subset, SZ_CCDLINE, TY_CHAR) + + # Get the image type and subset ID. + call ccdtypes (im, Memc[str], SZ_CCDLINE) + call ccdsubset (im, Memc[subset], SZ_CCDLINE) + + # List the image name, size, pixel type, image type, and subset. + call printf ("%s[%d,%d][%s][%s][%d]") + call pargstr (image) + call pargi (IM_LEN(im,1)) + call pargi (IM_LEN(im,2)) + call pargtype1 (IM_PIXTYPE(im)) + call pargstr (Memc[str]) + call pargstr (Memc[subset]) + + # Format and list the processing flags. + Memc[str] = EOS + if (ccdflag (im, "fixpix")) + call strcat ("B", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "overscan")) + call strcat ("O", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "trim")) + call strcat ("T", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "zerocor")) + call strcat ("Z", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "darkcor")) + call strcat ("D", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "flatcor")) + call strcat ("F", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "illumcor")) + call strcat ("I", Memc[str], SZ_CCDLINE) + if (ccdflag (im, "fringcor")) + call strcat ("Q", Memc[str], SZ_CCDLINE) + if (Memc[str] != EOS) { + call printf ("[%s]") + call pargstr (Memc[str]) + } + + # List the title. + call printf (":%s\n") + call pargstr (IM_TITLE(im)) + + call sfree (sp) +end + + +# LONGLIST -- Add the long format listing. +# List some instrument parameters and information about each processing +# step indicated by the processing parameters. If the processing step has +# not been done yet indicate this and the parameters to be used. + +procedure longlist (im, ccdtype) + +pointer im # IMIO pointer +int ccdtype # CCD image type + +real rval, hdmgetr() +pointer sp, instr, outstr +bool clgetb(), ccdflag(), streq() +define done_ 99 + +begin + call smark (sp) + call salloc (instr, SZ_LINE, TY_CHAR) + call salloc (outstr, SZ_LINE, TY_CHAR) + + # List some image parameters. + Memc[outstr] = EOS + ifnoerr (rval = hdmgetr (im, "exptime")) { + call sprintf (Memc[instr], SZ_LINE, " exposure=%d") + call pargr (rval) + call strcat (Memc[instr], Memc[outstr], SZ_LINE) + } + ifnoerr (rval = hdmgetr (im, "darktime")) { + call sprintf (Memc[instr], SZ_LINE, " darktime=%d") + call pargr (rval) + call strcat (Memc[instr], Memc[outstr], SZ_LINE) + } + call printf (" %s\n") + call pargstr (Memc[outstr]) + + # List the processing strings. + if (ccdflag (im, "fixpix")) { + call hdmgstr (im, "fixpix", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("fixpix")) { + call clgstr ("fixfile", Memc[outstr], SZ_LINE) + if (streq (Memc[outstr], "image")) + call hdmgstr (im, "fixfile", Memc[outstr], SZ_LINE) + if (Memc[outstr] != EOS) { + call printf (" [TO BE DONE] Bad pixel file is %s\n") + call pargstr (Memc[outstr]) + } else + call printf ( + " [TO BE DONE] Bad pixel file needs to be specified\n") + } + + if (ccdflag (im, "overscan")) { + call hdmgstr (im, "overscan", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("overscan")) { + call clgstr ("biassec", Memc[outstr], SZ_LINE) + if (streq (Memc[outstr], "image")) + call hdmgstr (im, "biassec", Memc[outstr], SZ_LINE) + call printf (" [TO BE DONE] Overscan strip is %s\n") + call pargstr (Memc[outstr]) + } + + if (ccdflag (im, "trim")) { + call hdmgstr (im, "trim", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("trim")) { + call clgstr ("trimsec", Memc[outstr], SZ_LINE) + if (streq (Memc[outstr], "image")) + call hdmgstr (im, "trimsec", Memc[outstr], SZ_LINE) + call printf (" [TO BE DONE] Trim image section is %s\n") + call pargstr (Memc[outstr]) + } + + if (ccdtype == ZERO) { + if (ccdflag (im, "readcor")) { + call hdmgstr (im, "readcor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("readcor")) + call printf ( + " [TO BE DONE] Convert to readout format\n") + goto done_ + } + if (ccdflag (im, "zerocor")) { + call hdmgstr (im, "zerocor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("zerocor")) + call printf (" [TO BE DONE] Zero level correction\n") + + if (ccdtype == DARK) + goto done_ + if (ccdflag (im, "darkcor")) { + call hdmgstr (im, "darkcor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("darkcor")) + call printf (" [TO BE DONE] Dark count correction\n") + + if (ccdtype == FLAT) { + if (ccdflag (im, "scancor")) { + call hdmgstr (im, "scancor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("scancor")) + call printf ( + " [TO BE DONE] Convert to scan format\n") + if (ccdflag (im, "skyflat")) { + call hdmgstr (im, "skyflat", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } + if (ccdflag (im, "illumflt")) { + call hdmgstr (im, "illumflt", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } + goto done_ + } + if (ccdflag (im, "flatcor")) { + call hdmgstr (im, "flatcor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("flatcor")) + call printf (" [TO BE DONE] Flat field correction\n") + + if (ccdtype == ILLUM) { + if (ccdflag (im, "mkillum")) { + call hdmgstr (im, "mkillum", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else + call printf ( + " [TO BE DONE] Convert to illumination correction\n") + goto done_ + } + if (ccdflag (im, "illumcor")) { + call hdmgstr (im, "illumcor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("illumcor")) + call printf (" [TO BE DONE] Illumination correction\n") + + if (ccdtype == FRINGE) + goto done_ + if (ccdflag (im, "fringcor")) { + call hdmgstr (im, "fringecor", Memc[outstr], SZ_LINE) + call printf (" %s\n") + call pargstr (Memc[outstr]) + } else if (clgetb ("fringecor")) + call printf (" [TO BE DONE] Fringe correction\n") + +done_ + call sfree (sp) +end + + +# PARGTYPE1 -- Convert an integer type code into a string, and output the +# string with PARGSTR to FMTIO. Taken from IMHEADER. + +procedure pargtype1 (dtype) + +int dtype + +begin + switch (dtype) { + case TY_UBYTE: + call pargstr ("ubyte") + case TY_BOOL: + call pargstr ("bool") + case TY_CHAR: + call pargstr ("char") + case TY_SHORT: + call pargstr ("short") + case TY_USHORT: + call pargstr ("ushort") + case TY_INT: + call pargstr ("int") + case TY_LONG: + call pargstr ("long") + case TY_REAL: + call pargstr ("real") + case TY_DOUBLE: + call pargstr ("double") + case TY_COMPLEX: + call pargstr ("complex") + case TY_POINTER: + call pargstr ("pointer") + case TY_STRUCT: + call pargstr ("struct") + default: + call pargstr ("unknown datatype") + } +end diff --git a/noao/imred/ccdred/src/t_ccdmask.x b/noao/imred/ccdred/src/t_ccdmask.x new file mode 100644 index 00000000..d5d074cb --- /dev/null +++ b/noao/imred/ccdred/src/t_ccdmask.x @@ -0,0 +1,384 @@ +include <imhdr.h> + + +define MAXBUF 500000 # Maximum pixel buffer + +define PLSIG 30.9 # Low percentile +define PHSIG 69.1 # High percentile + + +# T_CCDMASK -- Create a bad pixel mask from CCD images. +# Deviant pixels relative to a local median and sigma are detected and +# written to a pixel mask file. There is a special algorithm for detecting +# long column oriented features typical of CCD defects. This task +# is intended for use on flat fields or, even better, the ratio of +# two flat fields at different exposure levels. + +procedure t_ccdmask () + +pointer image # Input image +pointer mask # Output mask +int ncmed, nlmed # Median box size +int ncsig, nlsig # Sigma box size +real lsig, hsig # Threshold sigmas +int ngood # Minmum good pixel sequence +short linterp # Mask value for line interpolation +short cinterp # Mask value for column interpolation +short eqinterp # Mask value for equal interpolation + +int i, j, c1, c2, c3, c4, nc, nl, ncstep, nc1 +pointer sp, in, out, inbuf, outbuf +real clgetr() +int clgeti(), nowhite(), strmatch() +pointer immap(), imgs2r(), imps2s(), imgl2s(), impl2s() +errchk immap, imgs2r, imps2r, imgl2s, impl2s, cm_mask + +begin + call smark (sp) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (mask, SZ_FNAME, TY_CHAR) + + # Get parameters. + call clgstr ("image", Memc[image], SZ_FNAME) + call clgstr ("mask", Memc[mask], SZ_FNAME) + ncmed = clgeti ("ncmed") + nlmed = clgeti ("nlmed") + ncsig = clgeti ("ncsig") + nlsig = clgeti ("nlsig") + lsig = clgetr ("lsigma") + hsig = clgetr ("hsigma") + ngood = clgeti ("ngood") + linterp = clgeti ("linterp") + cinterp = clgeti ("cinterp") + eqinterp = clgeti ("eqinterp") + + # Force a pixel list format. + i = nowhite (Memc[mask], Memc[mask], SZ_FNAME) + if (strmatch (Memc[mask], ".pl$") == 0) + call strcat (".pl", Memc[mask], SZ_FNAME) + + # Map the input and output images. + in = immap (Memc[image], READ_ONLY, 0) + out = immap (Memc[mask], NEW_COPY, in) + + # Go through the input in large blocks of columns. If the + # block is smaller than the whole image overlap the blocks + # so the median only has boundaries at the ends of the image. + # Set the mask values based on the distances to the nearest + # good pixels. + + nc = IM_LEN(in,1) + nl = IM_LEN(in,2) + ncstep = max (1, MAXBUF / nl - ncmed) + + outbuf = NULL + do i = 1, nc, ncstep { + c1 = i + c2 = min (nc, i + ncstep - 1) + c3 = max (1, c1 - ncmed / 2) + c4 = min (nc, c2 + ncmed / 2) + nc1 = c4 - c3 + 1 + inbuf = imgs2r (in, c3, c4, 1, nl) + if (outbuf == NULL) + call malloc (outbuf, nc1*nl, TY_SHORT) + else + call realloc (outbuf, nc1*nl, TY_SHORT) + call aclrs (Memc[outbuf], nc1*nl) + call cm_mask (Memr[inbuf], Mems[outbuf], nc1, nl, c1-c3+1, + c2-c3+1, ncmed, nlmed, ncsig, nlsig, lsig, hsig, ngood) + call cm_interp (Mems[outbuf], nc1, nl, c1-c3+1, c2-c3+1, nc, + linterp, cinterp, eqinterp) + do j = 1, nl + call amovs (Mems[outbuf+(j-1)*nc1+c1-c3], + Mems[imps2s(out,c1,c2,j,j)], c2-c1+1) + } + call mfree (outbuf, TY_SHORT) + + call imunmap (out) + call imunmap (in) + + # If the image was searched in blocks we need another pass to find + # the lengths of bad pixel regions along lines since they may + # span the block edges. Previously the mask values were set + # to the column lengths so in this pass we can just look at + # whole lines sequentially. + + if (nc1 != nc) { + out = immap (Memc[mask], READ_WRITE, 0) + do i = 1, nl { + inbuf = imgl2s (out, i) + outbuf = impl2s (out, i) + call cm_interp1 (Mems[inbuf], Mems[outbuf], nc, nl, + linterp, cinterp, eqinterp) + } + call imunmap (out) + } + + call sfree (sp) +end + + +# CM_MASK -- Compute the mask image. +# A local background is computed using moving box medians to avoid +# contaminating bad pixels. The local sigma is computed in blocks (it is not +# a moving box for efficiency) by using a percentile point of the sorted +# pixel values to estimate the width of the distribution uncontaminated by +# bad pixels). Once the background and sigma are known deviant pixels are +# found by using sigma threshold factors. Sums of pixels along columns are +# checked at various scales from single pixels to whole columns with the +# sigma level set appropriately. The provides sensitivity to weaker column +# features such as CCD traps. + +procedure cm_mask (data, bp, nc, nl, nc1, nc2, ncmed, nlmed, ncsig, nlsig, + lsig, hsig, ngood) + +real data[nc,nl] #I Pixel array +short bp[nc,nl] #U Bad pixel array (0=good, 1=bad) +int nc, nl #I Number of columns and lines +int nc1, nc2 #I Columns to compute +int ncmed, nlmed #I Median box size +int ncsig, nlsig #I Sigma box size +real lsig, hsig #I Threshold sigmas +int ngood #I Minimum good pixel sequence + +int i, j, k, l, m, nsum, plsig, phsig, jsig +real back, sigma, sum1, sum2, low, high, amedr() +pointer sp, bkg, sig, work, bp1, ptr + +begin + call smark (sp) + call salloc (bkg, nl, TY_REAL) + call salloc (sig, nl/nlsig, TY_REAL) + call salloc (work, max (ncsig*nlsig, ncmed*nlmed), TY_REAL) + call salloc (bp1, nl, TY_SHORT) + + bkg = bkg - 1 + sig = sig - 1 + + i = nlsig * ncsig + plsig = nint (PLSIG*i/100.-1) + phsig = nint (PHSIG*i/100.-1) + + do i = nc1, nc2 { + + # Compute median background. This is a moving median. + l = min (nc, i+ncmed/2) + l = max (1, l-ncmed+1) + do j = 1, nl { + k = min (nl, j+nlmed/2) + k = max (1, k-nlmed+1) + ptr = work + do m = k, k+nlmed-1 { + call amovr (data[l,m], Memr[ptr], ncmed) + ptr = ptr + ncmed + } + back = amedr (Memr[work], ncmed * nlmed) + Memr[bkg+j] = back + } + + # Compute sigmas from percentiles. This is done in blocks. + if (mod (i-nc1, ncsig) == 0 && i<nc-ncsig+1) { + do j = 1, nl-nlsig+1, nlsig { + ptr = work + do k = j, j+nlsig-1 { + call amovr (data[i,k], Memr[ptr], ncsig) + ptr = ptr + ncsig + } + call asrtr (Memr[work], Memr[work], ncsig*nlsig) + sigma = Memr[work+phsig] - Memr[work+plsig] + jsig = (j+nlsig-1) / nlsig + Memr[sig+jsig] = sigma**2 + } + } + + # Single pixel iterative rejection. + k = 0 + do j = 1, nl { + if (bp[i,j] == 1) + k = k + 1 + else { + jsig = min ((j+nlsig-1)/nlsig, nl/nlsig) + back = Memr[bkg+j] + sigma = sqrt (Memr[sig+jsig]) + low = back - lsig * sigma + high = back + hsig * sigma + if (data[i,j] < low || data[i,j] > high) { + bp[i,j] = 1 + k = k + 1 + } + } + } + if (k == nl) + next + + # Reject over column sums at various scales. + # Ignore previously rejected pixels. + + l = 2 + while (l <= nl) { + do j = 1, nl + Mems[bp1+j-1] = bp[i,j] + sum1 = 0 + sum2 = 0 + nsum = 0 + k = 1 + do j = k, l-1 { + if (bp[i,j] == 1) + next + jsig = min ((j+nlsig-1)/nlsig, nl/nlsig) + sum1 = sum1 + data[i,j] - Memr[bkg+j] + sum2 = sum2 + Memr[sig+jsig] + nsum = nsum + 1 + } + do j = l, nl { + if (bp[i,j] == 0) { + jsig = min ((j+nlsig-1)/nlsig, nl/nlsig) + sum1 = sum1 + data[i,j] - Memr[bkg+j] + sum2 = sum2 + Memr[sig+jsig] + nsum = nsum + 1 + } + if (nsum > 0) { + sigma = sqrt (sum2) + low = -lsig * sigma + high = hsig * sigma + if (sum1 < low || sum1 > high) + do m = k, j + bp[i,m] = 1 + } + if (Mems[bp1+k-1] == 0) { + jsig = min ((k+nlsig-1)/nlsig, nl/nlsig) + sum1 = sum1 - data[i,k] + Memr[bkg+k] + sum2 = sum2 - Memr[sig+jsig] + nsum = nsum - 1 + } + k = k + 1 + } + + if (l == nl) + break + else if (l < 10) + l = l + 1 + else + l = min (l * 2, nl) + } + + # Coalesce small good regions along columns. + if (ngood > 1) { + for (k=1; k<=nl && bp[i,k]!=0; k=k+1) + ; + while (k < nl) { + for (l=k+1; l<=nl && bp[i,l]==0; l=l+1) + ; + if (l-k < ngood) + do j = k, l-1 + bp[i,j] = 1 + for (k=l+1; k<=nl && bp[i,k]!=0; k=k+1) + ; + } + } + } + + call sfree (sp) +end + + +# CM_INTERP -- Compute the lengths of bad regions along columns and lines. +# If only part of the image is buffered set the pixel mask values +# to the column lengths so a later pass can compare these values against +# the full line lengths. If the whole image is buffered then both +# the column and line lengths can be determined and the the mask values +# set based on these lengths. + +procedure cm_interp (bp, nc, nl, nc1, nc2, ncimage, linterp, cinterp, eqinterp) + +short bp[nc,nl] #U Bad pixel array +int nc, nl #I Number of columns and lines +int nc1, nc2 #I Columns to compute +int ncimage #I Number of columns in image +short linterp #I Mask value for line interpolation +short cinterp #I Mask value for column interpolation +short eqinterp #I Mask value for equal interpolation + +int i, j, k, l, m, n + +begin + do i = nc1, nc2 { + + # Set values to column length. + for (k=1; k<=nl && bp[i,k]==0; k=k+1) + ; + while (k <= nl) { + for (l=k+1; l<=nl && bp[i,l]!=0; l=l+1) + ; + m = l - k + do j = k, l-1 + bp[i,j] = m + for (k=l+1; k<=nl && bp[i,k]==0; k=k+1) + ; + } + } + + # Set values to minimum axis length for interpolation. + if (nc == ncimage) { + do j = 1, nl { + for (k=1; k<=nc && bp[k,j]==0; k=k+1) + ; + while (k <= nc) { + for (l=k+1; l<=nc && bp[l,j]!=0; l=l+1) + ; + m = l - k + do i = k, l-1 { + n = bp[i,j] + if (n > m || n == nl) + bp[i,j] = linterp + else if (n < m) + bp[i,j] = cinterp + else + bp[i,j] = eqinterp + } + for (k=l+1; k<=nc && bp[k,j]==0; k=k+1) + ; + } + } + } +end + + +# CM_INTERP1 -- Set the mask values based on the column and line lengths +# of the bad pixel regions. If this routine is called the pixel mask +# is open READ/WRITE and the pixel mask values have been previously set +# to the column lengths. So here we just need to compute the line +# lengths across the entire image and reset the mask values to the +# appropriate interpolation mask code. + +procedure cm_interp1 (in, out, nc, nl, linterp, cinterp, eqinterp) + +short in[nc] #I Bad pixel array with column length codes +short out[nc] #O Bad pixel array with interp axis codes +int nc, nl #I Image dimensions +short linterp #I Mask value for line interpolation +short cinterp #I Mask value for column interpolation +short eqinterp #I Mask value for equal interpolation + +int i, j, l, m, n + +begin + for (j=1; j<=nc && in[j]==0; j=j+1) + out[j] = 0 + while (j < nc) { + for (l=j+1; l<=nc && in[l]!=0; l=l+1) + ; + m = l - j + do i = j, l-1 { + n = in[i] + if (n > m || n == nl) + out[i] = linterp + else if (n < m) + out[i] = cinterp + else + out[i] = eqinterp + } + for (j=l+1; j<=nc && in[j]==0; j=j+1) + out[j] = 0 + } +end diff --git a/noao/imred/ccdred/src/t_ccdproc.x b/noao/imred/ccdred/src/t_ccdproc.x new file mode 100644 index 00000000..31e9ae6e --- /dev/null +++ b/noao/imred/ccdred/src/t_ccdproc.x @@ -0,0 +1,176 @@ +include <imhdr.h> +include <error.h> +include "ccdred.h" +include "ccdtypes.h" + +define CACHEUNIT 1000000. # Units of max_cache parameter + +# T_CCDPROC -- Process CCD images +# +# This is the main procedure for processing CCD images. The images are +# corrected for bad pixels, overscan levels, zero levels, dark counts, +# flat field response, illumination errors, and fringe response. They +# may also be trimmed. The input is a list of images to be processed. +# Each image must match any image type requested. The checking of +# whether to apply each correction, getting the required parameters, and +# logging the operations is left to separate procedures, one for each +# correction. The actual processing is done by a specialized procedure +# designed to be very efficient. These procedures may also process +# calibration images if necessary. There are two data type paths; one +# for short pixel types and one for all other pixel types (usually +# real). + +procedure t_ccdproc () + +int list # List of CCD images to process +int outlist # LIst of output images +int ccdtype # CCD image type +int interactive # Fit overscan interactively? +int max_cache # Maximum image cache size + +bool clgetb() +real clgetr() +int imtopenp(), imtgetim(), imtlen() +pointer sp, input, output, str, in, out, ccd +errchk set_input, set_output, ccddelete, cal_open +errchk set_fixpix, set_zero, set_dark, set_flat, set_illum, set_fringe + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get input and output lists and check they make sense. + list = imtopenp ("images") + outlist = imtopenp ("output") + if (imtlen (outlist) > 0 && imtlen (outlist) != imtlen (list)) + call error (1, "Input and output lists do not match") + + # Get instrument translation file. Open the translation + # file. Initialize the interactive flag and the calibration images. + + call clgstr ("instrument", Memc[input], SZ_FNAME) + if (Memc[input] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[input]) + call set_interactive ("", interactive) + call cal_open (list) + if (imtlen (list) < 3) + max_cache = 0. + else + max_cache = CACHEUNIT * clgetr ("max_cache") + call ccd_open (max_cache) + + # Process each image. + while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { + if (clgetb ("noproc")) { + call printf ("%s:\n") + call pargstr (Memc[input]) + } + call set_input (Memc[input], in, ccdtype) + if (in == NULL) + next + + # Set output image. + if (imtlen (outlist) == 0) + call mktemp ("tmp", Memc[output], SZ_FNAME) + else if (imtgetim (outlist, Memc[output], SZ_FNAME) == EOF) + call error (1, "Premature end of output list") + call set_output (in, out, Memc[output]) + + # Set processing parameters applicable to all images. + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + + # Set processing parameters for the standard CCD image types. + switch (ccdtype) { + case ZERO: + case DARK: + call set_zero (ccd) + case FLAT: + call set_zero (ccd) + call set_dark (ccd) + CORS(ccd, FINDMEAN) = YES + CORS(ccd, MINREP) = YES + case ILLUM: + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + case OBJECT, COMP: + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + iferr { + call set_illum (ccd) + call set_fringe (ccd) + } then + call erract (EA_WARN) + default: + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + iferr { + call set_illum (ccd) + call set_fringe (ccd) + } then + call erract (EA_WARN) + CORS(ccd, FINDMEAN) = YES + } + + # Do the processing if the COR flag is set. + + if (COR(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + call imunmap (in) + call imunmap (out) + if (imtlen (outlist) == 0) { + # Replace the input image by the corrected image. + iferr (call ccddelete (Memc[input])) { + call imdelete (Memc[output]) + call error (1, + "Can't delete or make backup of original image") + } + call imrename (Memc[output], Memc[input]) + } + } else { + # Delete the output image. + call imunmap (in) + iferr (call imunmap (out)) + ; + iferr (call imdelete (Memc[output])) + ; + } + call free_proc (ccd) + + # Do special processing on certain image types. + if (imtlen (outlist) == 0) { + switch (ccdtype) { + case ZERO: + call readcor (Memc[input]) + case FLAT: + call ccdmean (Memc[input]) + } + } else { + switch (ccdtype) { + case ZERO: + call readcor (Memc[output]) + case FLAT: + call ccdmean (Memc[output]) + } + } + } + + # Finish up. + call hdmclose () + call imtclose (list) + call imtclose (outlist) + call cal_close () + call ccd_close () + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_combine.x b/noao/imred/ccdred/src/t_combine.x new file mode 100644 index 00000000..66c14089 --- /dev/null +++ b/noao/imred/ccdred/src/t_combine.x @@ -0,0 +1,653 @@ +include <imhdr.h> +include <error.h> +include <syserr.h> +include <mach.h> +include "ccdred.h" +include "icombine.h" + + +# T_COMBINE -- Combine CCD images. +# This task is a copy of IMAGES.IMCOMBINE except that it recognizes the +# CCD types and can group images by AMP and SUBSET. It also uses header +# keyword translation for the exposure times. + +procedure t_combine () + +pointer images # Images +pointer extns # Image extensions for each subset +pointer subsets # Subsets +pointer nimages # Number of images in each subset +int nsubsets # Number of subsets +pointer outroot # Output root image name +pointer plroot # Output pixel list root name +pointer sigroot # Output root sigma image name +pointer logfile # Log filename +bool delete # Delete input images? + +int i +pointer sp, output, plfile, sigma + +bool clgetb() +int clgeti(), clgwrd() +real clgetr() + +include "icombine.com" + +begin + call smark (sp) + call salloc (outroot, SZ_FNAME, TY_CHAR) + call salloc (plroot, SZ_FNAME, TY_CHAR) + call salloc (sigroot, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (plfile, SZ_FNAME, TY_CHAR) + call salloc (sigma, SZ_FNAME, TY_CHAR) + call salloc (gain, SZ_FNAME, TY_CHAR) + call salloc (snoise, SZ_FNAME, TY_CHAR) + call salloc (rdnoise, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + + # Open the header translation which is needed to determine the + # amps, subsets and ccdtypes. Get the input images. + # There must be a least one image in order to continue. + + call clgstr ("instrument", Memc[output], SZ_FNAME) + if (Memc[output] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[output]) + call cmb_images (images, extns, subsets, nimages, nsubsets) + if (nsubsets == 0) + call error (0, "No images to combine") + + # Get task parameters. Some additional parameters are obtained later. + call clgstr ("output", Memc[outroot], SZ_FNAME) + call clgstr ("plfile", Memc[plroot], SZ_FNAME) + call clgstr ("sigma", Memc[sigroot], SZ_FNAME) + call clgstr ("logfile", Memc[logfile], SZ_FNAME) + call xt_stripwhite (Memc[outroot]) + call xt_stripwhite (Memc[sigroot]) + call xt_stripwhite (Memc[logfile]) + + project = clgetb ("project") + combine = clgwrd ("combine", Memc[output], SZ_FNAME, COMBINE) + reject = clgwrd ("reject", Memc[output], SZ_FNAME, REJECT) + blank = clgetr ("blank") + 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") + grow = clgeti ("grow") + mclip = clgetb ("mclip") + sigscale = clgetr ("sigscale") + delete = clgetb ("delete") + + # Check parameters, map INDEFs, and set threshold flag + if (IS_INDEFR (blank)) + blank = 0. + if (IS_INDEFR (lsigma)) + lsigma = MAX_REAL + if (IS_INDEFR (hsigma)) + hsigma = MAX_REAL + if (IS_INDEFI (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 + } + + # This is here for backward compatibility. + if (clgetb ("clobber")) + call error (1, "Clobber option is no longer supported") + + # Combine each input subset. + do i = 1, nsubsets { + # Set the output, pl, and sigma image names with subset extension. + + call strcpy (Memc[outroot], Memc[output], SZ_FNAME) + call sprintf (Memc[output], SZ_FNAME, "%s%s") + call pargstr (Memc[outroot]) + call pargstr (Memc[Memi[extns+i-1]]) + + call strcpy (Memc[plroot], Memc[plfile], SZ_FNAME) + if (Memc[plfile] != EOS) { + call sprintf (Memc[plfile], SZ_FNAME, "%s%s") + call pargstr (Memc[plroot]) + # Use this if we can append pl files. + #call pargstr (Memc[Memi[extns+i-1]]) + call pargstr (Memc[Memi[subsets+i-1]]) + } + + call strcpy (Memc[sigroot], Memc[sigma], SZ_FNAME) + if (Memc[sigma] != EOS) { + call sprintf (Memc[sigma], SZ_FNAME, "%s%s") + call pargstr (Memc[sigroot]) + call pargstr (Memc[Memi[extns+i-1]]) + } + + # Combine all images from the (subset) list. + iferr (call icombine (Memc[Memi[images+i-1]], Memi[nimages+i-1], + Memc[output], Memc[plfile], Memc[sigma], + Memc[logfile], NO, delete)) { + call erract (EA_WARN) + } + call mfree (Memi[images+i-1], TY_CHAR) + call mfree (Memi[extns+i-1], TY_CHAR) + call mfree (Memi[subsets+i-1], TY_CHAR) + } + + # Finish up. + call mfree (images, TY_POINTER) + call mfree (extns, TY_POINTER) + call mfree (subsets, TY_POINTER) + call mfree (nimages, TY_INT) + call hdmclose () + call sfree (sp) +end + + +# CMB_IMAGES -- Get images from a list of images. +# The images are filtered by ccdtype and sorted by amplifier and subset. +# The allocated lists must be freed by the caller. + +procedure cmb_images (images, extns, subsets, nimages, nsubsets) + +pointer images # Pointer to lists of subsets (allocated) +pointer extns # Image extensions for each subset (allocated) +pointer subsets # Subset names (allocated) +pointer nimages # Number of images in subset (allocated) +int nsubsets # Number of subsets + +int list # List of input images +bool doamps # Divide input into subsets by amplifier? +bool dosubsets # Divide input into subsets by subset parameter? +bool extend # Add extensions to output image names? + +int i, nimage, ccdtype +pointer sp, type, image, extn, subset, str, ptr, im +#int imtopenp(), imtlen(), imtgetim(), ccdtypecl(), ccdtypes() +int imtopenp(), imtlen(), imtgetim() +pointer immap() +bool clgetb(), streq() + +begin + # Get the input image list and check that there is at least one image. + nsubsets = 0 + list = imtopenp ("input") + nimage = imtlen (list) + if (nimage == 0) { + call imtclose (list) + return + } + + # Determine whether to divide images into subsets and append extensions. + #doamps = clgetb ("amps") + doamps = false + dosubsets = clgetb ("subsets") + #extend = clgetb ("extensions") + extend = true + + call smark (sp) + call salloc (type, SZ_FNAME, TY_CHAR) + call salloc (image, SZ_FNAME, TY_CHAR) + call salloc (extn, SZ_FNAME, TY_CHAR) + call salloc (subset, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_FNAME, TY_CHAR) + + # Go through the input list and eliminate images not satisfying the + # CCD image type. Separate into subsets if desired. Create image + # and subset lists. + + #ccdtype = ccdtypecl ("ccdtype", Memc[type], SZ_FNAME) + ccdtype = 0 + call clgstr ("ccdtype", Memc[type], SZ_FNAME) + call xt_stripwhite (Memc[type]) + + while (imtgetim (list, Memc[image], SZ_FNAME)!=EOF) { + iferr (im = immap (Memc[image], READ_ONLY, 0)) { + call erract (EA_WARN) + next + } + #ccdtype = ccdtypes (im, Memc[str], SZ_FNAME) + call ccdtypes (im, Memc[str], SZ_FNAME) + if (Memc[type] != EOS && !streq (Memc[str], Memc[type])) + next + + Memc[extn] = EOS + Memc[subset] = EOS + if (doamps) { + #call ccdamp (im, Memc[str], SZ_FNAME) + Memc[str] = EOS + if (extend) + call strcat (Memc[str], Memc[extn], SZ_FNAME) + call strcat (Memc[str], Memc[subset], SZ_FNAME) + } + if (dosubsets) { + call ccdsubset (im, Memc[str], SZ_FNAME) + call strcat (Memc[str], Memc[extn], SZ_FNAME) + call strcat (Memc[str], Memc[subset], SZ_FNAME) + } + for (i=1; i <= nsubsets; i=i+1) + if (streq (Memc[subset], Memc[Memi[subsets+i-1]])) + break + + if (i > nsubsets) { + if (nsubsets == 0) { + call malloc (images, nimage, TY_POINTER) + call malloc (extns, nimage, TY_POINTER) + call malloc (subsets, nimage, TY_POINTER) + call malloc (nimages, nimage, TY_INT) + } else if (mod (nsubsets, nimage) == 0) { + call realloc (images, nsubsets+nimage, TY_POINTER) + call realloc (extns, nsubsets+nimage, TY_POINTER) + call realloc (subsets, nsubsets+nimage, TY_POINTER) + call realloc (nimages, nsubsets+nimage, TY_INT) + } + nsubsets = i + call malloc (ptr, SZ_FNAME, TY_CHAR) + call strcpy (Memc[image], Memc[ptr], SZ_FNAME-1) + Memi[images+i-1] = ptr + call malloc (ptr, SZ_FNAME, TY_CHAR) + call strcpy (Memc[extn], Memc[ptr], SZ_FNAME) + Memi[extns+i-1] = ptr + call malloc (ptr, SZ_FNAME, TY_CHAR) + call strcpy (Memc[subset], Memc[ptr], SZ_FNAME) + Memi[subsets+i-1] = ptr + Memi[nimages+i-1] = 1 + } else { + ptr = Memi[images+i-1] + nimage = Memi[nimages+i-1] + 1 + call realloc (ptr, nimage * SZ_FNAME, TY_CHAR) + Memi[images+i-1] = ptr + Memi[nimages+i-1] = nimage + ptr = ptr + (nimage - 1) * SZ_FNAME + call strcpy (Memc[image], Memc[ptr], SZ_FNAME-1) + } + + call imunmap (im) + } + call realloc (images, nsubsets, TY_POINTER) + call realloc (extns, nsubsets, TY_POINTER) + call realloc (subsets, nsubsets, TY_POINTER) + call realloc (nimages, nsubsets, TY_INT) + call imtclose (list) + call sfree (sp) +end + + +# ICOMBINE -- Combine the CCD images in a list. +# 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 (images, nims, output, plfile, sigma, logfile, stack, + delete) + +char images[SZ_FNAME-1, nims] # Input images +int nims # Number of images in list +char output[ARB] # Output image +char plfile[ARB] # Pixel list file +char sigma[ARB] # Output sigma image +char logfile[ARB] # Log filename +int stack # Stack input images? +bool delete # Delete input images? + +char errstr[SZ_LINE] +int i, j, nimages, intype, bufsize, maxsize, memory, oldsize, stack1, err +pointer sp, sp1, in, out[3], offsets, temp, key, tmp + +int getdatatype() +real clgetr() +char clgetc() +int clgeti(), begmem(), errget(), open(), ty_max(), sizeof() +pointer immap(), ic_plfile() +errchk ic_imstack, immap, ic_plfile, ic_setout, ccddelete + +include "icombine.com" + +define retry_ 98 +define done_ 99 + +begin + call smark (sp) + + # Set number of images to combine. + if (project) { + if (nims > 1) { + call sfree (sp) + call error (1, "Cannot project combine a list of images") + } + tmp = immap (images[1,1], 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 imunmap (out[1]) + } else + nimages = nims + + # Convert the nkeep parameter if needed. + # 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. + + nkeep = clgeti ("nkeep") + if (nkeep < 0) + nkeep = max (0, nimages + nkeep) + + if (reject == PCLIP) { + pclip = clgetr ("pclip") + if (pclip == 0.) + call error (1, "Pclip parameter may not be zero") + if (IS_INDEFR (pclip)) + pclip = -0.5 + + 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) { + flow = clgetr ("nlow") + fhigh = clgetr ("nhigh") + if (IS_INDEFR (flow)) + flow = 0 + if (IS_INDEFR (fhigh)) + fhigh = 0 + + 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 eprintf ("Bad minmax rejection parameters\n") + call sfree (sp) + return + } + } + + # Map the input images. + bufsize = 0 + stack1 = stack +retry_ + iferr { + out[1] = NULL + out[2] = NULL + out[3] = NULL + icm = NULL + logfd = NULL + + call smark (sp1) + if (stack1 == YES) { + call salloc (temp, SZ_FNAME, TY_CHAR) + call mktemp ("tmp", Memc[temp], SZ_FNAME) + call ic_imstack (images, nimages, Memc[temp]) + project = true + } + + # Map the input image(s). + if (project) { + if (stack1 == YES) { + tmp = immap (Memc[temp], READ_ONLY, 0); out[1] = tmp + } else { + tmp = immap (images[1,1], READ_ONLY, 0); out[1] = tmp + } + nimages = IM_LEN(out[1],IM_NDIM(out[1])) + call calloc (in, nimages, TY_POINTER) + call amovki (out[1], Memi[in], nimages) + } else { + call calloc (in, nimages, TY_POINTER) + do i = 1, nimages { + tmp = immap (images[1,i], READ_ONLY, 0); Memi[in+i-1] = tmp + } + } + + # Map the output image and set dimensions and offsets. + tmp = immap (output, NEW_COPY, Memi[in]); out[1] = tmp + if (stack1 == YES) { + call salloc (key, SZ_FNAME, TY_CHAR) + do i = 1, nimages { + call sprintf (Memc[key], SZ_FNAME, "stck%04d") + call pargi (i) + call imdelf (out[1], Memc[key]) + } + } + call salloc (offsets, nimages*IM_NDIM(out[1]), TY_INT) + call ic_setout (Memi[in], out, Memi[offsets], nimages) + + # 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 pixel list file if given. + if (plfile[1] != EOS) { + tmp = ic_plfile (plfile, NEW_COPY, out[1]); out[2] = tmp + } else + out[2] = 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 + + # This is done here to work around problem adding a keyword to + # an NEW_COPY header and then using that header in a NEW_COPY. + + # Open masks. + call ic_mopen (Memi[in], out, nimages) + + # 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. + + bufsize = 1 + do i = 1, IM_NDIM(out[1]) + bufsize = bufsize * IM_LEN(out[1],i) + bufsize = bufsize * sizeof (intype) + bufsize = min (bufsize, DEFBUFSIZE) + memory = begmem ((nimages + 1) * bufsize, oldsize, maxsize) + memory = min (memory, int (FUDGE * maxsize)) + bufsize = memory / (nimages + 1) + } + + # 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 (intype) { + case TY_SHORT: + call icombines (Memi[in], out, Memi[offsets], nimages, + bufsize) + default: + call icombiner (Memi[in], out, Memi[offsets], nimages, + bufsize) + } + } then { + err = errget (errstr, SZ_LINE) + if (icm != NULL) + call ic_mclose (nimages) + if (!project) { + do j = 2, nimages + if (Memi[in+j-1] != NULL) + call imunmap (Memi[in+j-1]) + } + if (out[2] != NULL) { + call imunmap (out[2]) + call imdelete (plfile) + } + if (out[3] != NULL) { + call imunmap (out[3]) + call imdelete (sigma) + } + if (out[1] != NULL) { + call imunmap (out[1]) + call imdelete (output) + } + if (Memi[in] != NULL) + call imunmap (Memi[in]) + if (logfd != NULL) + call close (logfd) + + switch (err) { + case SYS_MFULL: + bufsize = bufsize / 2 + call sfree (sp1) + goto retry_ + case SYS_FTOOMANYFILES, SYS_IKIOPIX: + if (!project) { + stack1 = YES + call sfree (sp1) + goto retry_ + } + if (stack1 == YES) + call imdelete (Memc[temp]) + call fixmem (oldsize) + call sfree (sp1) + call error (err, errstr) + default: + if (stack1 == YES) + call imdelete (Memc[temp]) + call fixmem (oldsize) + call sfree (sp1) + call error (err, errstr) + } + } + + # Unmap all the images, close the log file, and restore memory. + # The input images must be unmapped first to insure that there + # is a FD for the output images since the headers are opened to + # update them. However, the order of the NEW_COPY pointers must + # be preserved; i.e. the output depends on the first input image, + # and the extra output images depend on the output image. + + if (!project) { + do i = 2, nimages { + if (Memi[in+i-1] != NULL) { + call imunmap (Memi[in+i-1]) + if (delete) + call ccddelete (images[1,i]) + } + } + } + if (out[2] != NULL) + call imunmap (out[2]) + if (out[3] != NULL) + call imunmap (out[3]) + if (out[1] != NULL) + call imunmap (out[1]) + if (Memi[in] != NULL) + call imunmap (Memi[in]) + if (stack1 == YES) + call imdelete (Memc[temp]) + if (delete) + call ccddelete (images[1,1]) + if (logfd != NULL) + call close (logfd) + if (icm != NULL) + call ic_mclose (nimages) + + call fixmem (oldsize) + call sfree (sp) +end + + +# 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 + + +# IC_PLFILE -- Map pixel list file +# This routine strips any image extensions and then adds .pl. + +pointer procedure ic_plfile (plfile, mode, refim) + +char plfile[ARB] # Pixel list file name +int mode # Image mode +pointer refim # Reference image +pointer pl # IMIO pointer (returned) + +int i, strlen() +bool streq +pointer sp, str, immap() + +begin + call smark (sp) + call salloc (str, SZ_FNAME, TY_CHAR) + + call imgimage (plfile, Memc[str], SZ_FNAME) + + # Strip any existing extensions + i = strlen(Memc[str]) + switch (Memc[str+i-1]) { + case 'h': + if (i > 3 && Memc[str+i-4] == '.') + Memc[str+i-4] = EOS + case 'l': + if (i > 2 && streq (Memc[str+i-3], ".pl")) + Memc[str+i-3] = EOS + } + + call strcat (".pl", Memc[str], SZ_FNAME) + pl = immap (Memc[str], NEW_COPY, refim) + call sfree (sp) + return (pl) +end diff --git a/noao/imred/ccdred/src/t_mkfringe.x b/noao/imred/ccdred/src/t_mkfringe.x new file mode 100644 index 00000000..d3e2e82d --- /dev/null +++ b/noao/imred/ccdred/src/t_mkfringe.x @@ -0,0 +1,191 @@ +include <imhdr.h> +include "ccdred.h" + + +# T_MKFRINGECOR -- CL task to make fringe correction image. The large scale +# background of the input images is subtracted from the input image to obtain +# the output fringe correction image. The image is first processed if needed. + +procedure t_mkfringecor() + +int listin # List of input CCD images +int listout # List of output CCD images +int ccdtype # CCD image type +int interactive # Fit overscan interactively? + +bool clgetb(), streq() +int imtopenp(), imtgetim() +pointer sp, input, output, tmp, str, in, out, ccd +errchk set_input, set_output, ccddelete + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the lists and instrument translation file. Open the translation + # file. Initialize the interactive flag and the calibration images. + + listin = imtopenp ("input") + listout = imtopenp ("mkfringecor.output") + call clgstr ("instrument", Memc[input], SZ_FNAME) + if (Memc[input] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[input]) + call set_interactive ("", interactive) + call cal_open (NULL) + call ccd_open (0) + + # Process each image. + while (imtgetim (listin, Memc[input], SZ_FNAME) != EOF) { + if (clgetb ("noproc")) { + call printf ("%s: mkfringecor\n") + call pargstr (Memc[input]) + } + + # Set input and output images. Use temporary image if needed. + call set_input (Memc[input], in, ccdtype) + if (in == NULL) + next + + if (imtgetim (listout, Memc[output], SZ_FNAME) == EOF) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (Memc[output] == EOS) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (streq (Memc[input], Memc[output])) + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + else + call strcpy (Memc[output], Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + + # Process image as a flat field image. + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + call set_illum (ccd) + + # Do the processing. + if (CORS(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + # Finish up + call imunmap (in) + call imunmap (out) + if (streq (Memc[input], Memc[output])) { + call ccddelete (Memc[input]) + call imrename (Memc[tmp], Memc[input]) + } else + call strcpy (Memc[output], Memc[input], SZ_FNAME) + } else { + # Delete the temporary output image. Make a copy if needed. + call imunmap (in) + call imunmap (out) + call imdelete (Memc[tmp]) + } + call free_proc (ccd) + + # Do special processing. + call mkfringecor (Memc[input], Memc[output]) + if (!streq (Memc[input], Memc[output])) + call ccdcopy (Memc[input], Memc[output]) + } + + # Finish up. + call hdmclose () + call imtclose (listin) + call imtclose (listout) + call cal_close () + call ccd_close () + call sfree (sp) +end + + +# MKFRINGECOR -- Given an input image which has been processed make the output +# fringe correction image. + +procedure mkfringecor (input, output) + +char input[SZ_FNAME] # Input image +char output[SZ_FNAME] # Output image + +int i, nc, nl +pointer sp, str, illum, tmp, in, im, out, out1 +bool clgetb(), ccdflag(), streq() +pointer immap(), imgl2r(), impl2r() +errchk immap, ccddelete + +begin + # Check if this operation has been done. + in = immap (input, READ_ONLY, 0) + if (ccdflag (in, "mkfringe")) { + call imunmap (in) + return + } + + # Print operation if not processing. + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Make fringe correction\n") + call pargstr (input) + call imunmap (in) + return + } + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (illum, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + + # Make the illumination image. + call imunmap (in) + call strcpy (input, Memc[tmp], SZ_FNAME) + call mktemp ("tmp", Memc[illum], SZ_FNAME) + call mkillumination (Memc[tmp], Memc[illum], NO, NO) + + in = immap (input, READ_ONLY, 0) + im = immap (Memc[illum], READ_ONLY, 0) + + # Create the temporary output. + if (streq (input, output)) { + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + out1 = in + } else { + call set_output (in, out, output) + out1 = out + } + + # Subtract the illumination from input image. + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + do i = 1, nl + call asubr (Memr[imgl2r(in,i)], Memr[imgl2r(im,i)], + Memr[impl2r(out,i)], nc) + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, "Fringe correction created") + call timelog (Memc[str], SZ_LINE) + call ccdlog (out1, Memc[str]) + call hdmpstr (out, "mkfringe", Memc[str]) + call hdmpstr (out, "imagetyp", "fringe") + + # Finish up + call imunmap (in) + call imunmap (im) + call imunmap (out) + call imdelete (Memc[illum]) + if (streq (input, output)) { + call ccddelete (input) + call imrename (Memc[tmp], input) + } else + call strcpy (output, input, SZ_FNAME) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_mkillumcor.x b/noao/imred/ccdred/src/t_mkillumcor.x new file mode 100644 index 00000000..e9113f01 --- /dev/null +++ b/noao/imred/ccdred/src/t_mkillumcor.x @@ -0,0 +1,108 @@ +include "ccdred.h" + +# T_MKILLUMCOR -- Make flat field illumination correction images. +# +# The input flat field images are processed and smoothed to obtain +# illumination correction images. These illumination correction images +# are used to correct already processed images for illumination effects +# introduced by the flat field. + +procedure t_mkillumcor() + +int listin # List of input CCD images +int listout # List of output CCD images +int ccdtype # CCD image type +int interactive # Fit overscan interactively? + +bool clgetb(), streq() +int imtopenp(), imtgetim() +pointer sp, input, output, tmp, str, in, out, ccd +errchk set_input, set_output, ccddelete + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the lists and instrument translation file. Open the translation + # file. Initialize the interactive flag and the calibration images. + + listin = imtopenp ("input") + listout = imtopenp ("mkillumcor.output") + call clgstr ("instrument", Memc[input], SZ_FNAME) + if (Memc[input] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[input]) + call set_interactive ("", interactive) + call cal_open (NULL) + call ccd_open (0) + + # Process each image. + while (imtgetim (listin, Memc[input], SZ_FNAME) != EOF) { + if (clgetb ("noproc")) { + call printf ("%s: mkillumcor\n") + call pargstr (Memc[input]) + } + + # Set input and output images. + call set_input (Memc[input], in, ccdtype) + if (in == NULL) + next + + if (imtgetim (listout, Memc[output], SZ_FNAME) == EOF) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (Memc[output] == EOS) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (streq (Memc[input], Memc[output])) + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + else + call strcpy (Memc[output], Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + + # Process image as an illumination image. + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + call set_zero (ccd) + call set_dark (ccd) + CORS(ccd, FINDMEAN) = YES + + # Do the processing if the COR flag is set. + if (COR(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + # Replace the input image by the corrected image. + call imunmap (in) + call imunmap (out) + if (streq (Memc[input], Memc[output])) { + call ccddelete (Memc[input]) + call imrename (Memc[tmp], Memc[input]) + } else + call strcpy (Memc[output], Memc[input], SZ_FNAME) + } else { + # Make a copy if necessary. + call imunmap (in) + call imunmap (out) + call imdelete (Memc[tmp]) + } + call free_proc (ccd) + + # Do special processing. + call mkillumination (Memc[input], Memc[output], YES, YES) + if (!streq (Memc[input], Memc[output])) + call ccdcopy (Memc[input], Memc[output]) + } + + # Finish up. + call hdmclose () + call imtclose (listin) + call imtclose (listout) + call cal_close () + call ccd_close () + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_mkillumft.x b/noao/imred/ccdred/src/t_mkillumft.x new file mode 100644 index 00000000..ecb66a8e --- /dev/null +++ b/noao/imred/ccdred/src/t_mkillumft.x @@ -0,0 +1,229 @@ +include <imhdr.h> +include "ccdred.h" + + +# T_MKILLUMFLAT -- Make illumination corrected flat field images. +# +# The input flat field images are processed and smoothed to obtain +# illumination pattern. The illumination pattern is then divided out +# of the input image to make the output illumination corrected flat field +# image. + +procedure t_mkillumflat() + +int listin # List of input CCD images +int listout # List of output CCD images +int ccdtype # CCD image type +int interactive # Fit overscan interactively? + +bool clgetb(), streq() +int imtopenp(), imtgetim() +pointer sp, input, output, tmp, str, in, out, ccd +errchk set_input, set_output, ccddelete + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the lists and instrument translation file. Open the translation + # file. Initialize the interactive flag and the calibration images. + + listin = imtopenp ("input") + listout = imtopenp ("mkillumflat.output") + call clgstr ("instrument", Memc[input], SZ_FNAME) + call hdmopen (Memc[input]) + call set_interactive ("", interactive) + call cal_open (NULL) + call ccd_open (0) + + # Process each image. + while (imtgetim (listin, Memc[input], SZ_FNAME) != EOF) { + if (clgetb ("noproc")) { + call printf ("%s: mkillumflat\n") + call pargstr (Memc[input]) + } + + # Set input and output images. Use temporary image if needed. + call set_input (Memc[input], in, ccdtype) + if (in == NULL) + next + + if (imtgetim (listout, Memc[output], SZ_FNAME) == EOF) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (Memc[output] == EOS) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (streq (Memc[input], Memc[output])) + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + else + call strcpy (Memc[output], Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + + # Process image as a flat field image. + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + call set_zero (ccd) + call set_dark (ccd) + + # Do the processing. + if (CORS(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + # Finish up + call imunmap (in) + call imunmap (out) + if (streq (Memc[input], Memc[output])) { + call ccddelete (Memc[input]) + call imrename (Memc[tmp], Memc[input]) + } else + call strcpy (Memc[output], Memc[input], SZ_FNAME) + } else { + # Delete the temporary output image. Make a copy if needed. + call imunmap (in) + call imunmap (out) + call imdelete (Memc[tmp]) + } + call free_proc (ccd) + + # Do special processing. + call mkillumflat (Memc[input], Memc[output]) + if (!streq (Memc[input], Memc[output])) + call ccdcopy (Memc[input], Memc[output]) + } + + # Finish up. + call hdmclose () + call imtclose (listin) + call imtclose (listout) + call cal_close () + call ccd_close () + call sfree (sp) +end + + +# MKILLUMFLAT -- Take the processed input image and make the illumination +# corrected flat field output image. The illumination pattern is created +# as a temporary image and then the applied to the input flat field +# image to make the final output flat field image. If the input and +# output names are the same the operation is done in place. + +procedure mkillumflat (input, output) + +char input[SZ_FNAME] # Input image +char output[SZ_FNAME] # Output image + +int i, nc, nl +real scale +long time +pointer sp, str, illum, tmp, in, im, out, out1, data + +bool clgetb(), ccdflag(), streq() +int hdmgeti() +real hdmgetr(), clgetr(), divzero() +pointer immap(), imgl2r(), impl2r() +errchk immap, ccddelete +extern divzero() + +real rdivzero # Result for divion by zero +int ndivzero # Number of zero divisions +common /cdivzero/ rdivzero, ndivzero + +begin + # Check if this operation has been done. + in = immap (input, READ_ONLY, 0) + if (ccdflag (in, "illumflt")) { + call imunmap (in) + return + } + + # Print operation if not processing. + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Remove illumination\n") + call pargstr (input) + call imunmap (in) + return + } + + # Get and set task parameters for division by zero. + rdivzero = clgetr ("divbyzero") + ndivzero = 0 + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (illum, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + + # Make the illumination image. + call imunmap (in) + call strcpy (input, Memc[tmp], SZ_FNAME) + call mktemp ("tmp", Memc[illum], SZ_FNAME) + call mkillumination (Memc[tmp], Memc[illum], NO, NO) + + in = immap (input, READ_ONLY, 0) + im = immap (Memc[illum], READ_ONLY, 0) + iferr (scale = hdmgetr (im, "ccdmean")) + scale = 1. + iferr (time = hdmgeti (im, "ccdmeant")) + time = IM_MTIME(im) + if (time < IM_MTIME(im)) + scale = 1. + + # Create the temporary output. + if (streq (input, output)) { + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + out1 = in + } else { + call set_output (in, out, output) + out1 = out + } + + # Divide the illumination and flat field images with scaling. + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + do i = 1, nl { + data = impl2r (out, i) + call advzr (Memr[imgl2r(in,i)], Memr[imgl2r(im,i)], + Memr[data], nc, divzero) + if (scale != 1.) + call amulkr (Memr[data], scale, Memr[data], nc) + } + + # Log the operation. + if (ndivzero > 0) { + call sprintf (Memc[str], SZ_LINE, + "Warning: %d divisions by zero replaced by %g") + call pargi (ndivzero) + call pargr (rdivzero) + call ccdlog (out1, Memc[str]) + } + call sprintf (Memc[str], SZ_LINE, "Removed illumination from flat") + call sprintf (Memc[str], SZ_LINE, + "Illumination flat created from %s") + call pargstr (input) + call timelog (Memc[str], SZ_LINE) + call ccdlog (out1, Memc[str]) + call hdmpstr (out, "illumflt", Memc[str]) + call hdmpstr (out, "imagetyp", "flat") + + # Finish up + call imunmap (in) + call imunmap (im) + call imunmap (out) + call imdelete (Memc[illum]) + + # The input name is changed to the output name for further processing. + if (streq (input, output)) { + call ccddelete (input) + call imrename (Memc[tmp], input) + } else + call strcpy (output, input, SZ_FNAME) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_mkskycor.x b/noao/imred/ccdred/src/t_mkskycor.x new file mode 100644 index 00000000..fa3f3cd4 --- /dev/null +++ b/noao/imred/ccdred/src/t_mkskycor.x @@ -0,0 +1,694 @@ +include <imhdr.h> +include <imset.h> +include <mach.h> +include "ccdred.h" + +define MINSIGMA 1. # Minimum sigma +define NITERATE 10 # Maximum number of clipping iterations + +# T_MKSKYCOR -- Make sky illumination correction images. +# +# The input images processed and smoothed to obtain an illumination correction +# image. This task is a version of T_CCDPROC which treats the images as +# illumination images regardless of there CCD image type. + +procedure t_mkskycor() + +int listin # List of input CCD images +int listout # List of output CCD images +int ccdtype # CCD image type +int interactive # Fit overscan interactively? + +bool flatcor, ccdflag(), clgetb(), streq() +int imtopenp(), imtgetim() +pointer sp, input, output, tmp, str, in, out, ccd +errchk set_input, set_output, ccddelete + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the lists and instrument translation file. Open the translation + # file. Initialize the interactive flag and the calibration images. + + listin = imtopenp ("input") + listout = imtopenp ("mkskycor.output") + call clgstr ("instrument", Memc[input], SZ_FNAME) + if (Memc[input] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[input]) + call set_interactive ("", interactive) + call cal_open (NULL) + call ccd_open (0) + + # Process each image. + while (imtgetim (listin, Memc[input], SZ_FNAME) != EOF) { + if (clgetb ("noproc")) { + call printf ("%s: mkskycor\n") + call pargstr (Memc[input]) + } + + # Set input and output images. + call set_input (Memc[input], in, ccdtype) + if (in == NULL) + next + + if (imtgetim (listout, Memc[output], SZ_FNAME) == EOF) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (Memc[output] == EOS) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (streq (Memc[input], Memc[output])) + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + else + call strcpy (Memc[output], Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + + # Process image as an illumination image. + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + + # Do the processing if the COR flag is set. + if (COR(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + # Replace the input image by the corrected image. + flatcor = ccdflag (out, "flatcor") + call imunmap (in) + call imunmap (out) + if (streq (Memc[input], Memc[output])) { + call ccddelete (Memc[input]) + call imrename (Memc[tmp], Memc[input]) + } else + call strcpy (Memc[output], Memc[input], SZ_FNAME) + } else { + # Make a copy if necessary. + flatcor = ccdflag (out, "flatcor") + call imunmap (in) + call imunmap (out) + call imdelete (Memc[tmp]) + } + call free_proc (ccd) + + # Do special processing. + if (!flatcor) { + call eprintf ( + "%s: WARNING - Image should be flat fielded first\n") + call pargstr (Memc[input]) + } + call mkillumination (Memc[input], Memc[output], NO, YES) + if (!streq (Memc[input], Memc[output])) + call ccdcopy (Memc[input], Memc[output]) + } + + # Finish up. + call hdmclose () + call imtclose (listin) + call imtclose (listout) + call cal_close () + call ccd_close () + call sfree (sp) +end + + +# MKILLUMINATION -- Make illumination images. +# +# The images are boxcar smoothed to obtain the large scale illumination. +# Objects in the images are excluded from the average by sigma clipping. + +procedure mkillumination (input, output, inverse, log) + +char input[SZ_FNAME] # Input image +char output[SZ_FNAME] # Output image +int inverse # Return inverse of illumination +int log # Add log info? + +real xbminr # Minimum size of X smoothing box +real ybminr # Minimum size of Y smoothing box +real xbmaxr # Maximum size of X smoothing box +real ybmaxr # Maximum size of Y smoothing box +bool clip # Sigma clip +real lowsigma # Low sigma clip +real highsigma # High sigma clip + +int xbmin, ybmin, xbmax, ybmax +pointer sp, str, tmp, in, out, out1 + +bool clgetb(), ccdflag(), streq() +real clgetr() +pointer immap() +errchk immap, ccddelete + +real rdivzero # Result for divion by zero +int ndivzero # Number of zero divisions +common /cdivzero/ rdivzero, ndivzero + +begin + # Check if this operation has been done. Unfortunately this requires + # mapping the image. + + in = immap (input, READ_ONLY, 0) + if (ccdflag (in, "mkillum")) { + call imunmap (in) + return + } + + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Convert %s to illumination correction\n") + call pargstr (input) + call imunmap (in) + return + } + + # Get task parameters + xbminr = clgetr ("xboxmin") + ybminr = clgetr ("yboxmin") + xbmaxr = clgetr ("xboxmax") + ybmaxr = clgetr ("yboxmax") + clip = clgetb ("clip") + if (clip) { + lowsigma = max (MINSIGMA, clgetr ("lowsigma")) + highsigma = max (MINSIGMA, clgetr ("highsigma")) + } + if (inverse == YES) + rdivzero = clgetr ("divbyzero") + ndivzero = 0 + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + + # Create output. + if (streq (input, output)) { + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + out1 = in + } else { + call set_output (in, out, output) + out1 = out + } + + if (xbminr < 1.) + xbminr = xbminr * IM_LEN(in,1) + if (ybminr < 1.) + ybminr = ybminr * IM_LEN(in,2) + if (xbmaxr < 1.) + xbmaxr = xbmaxr * IM_LEN(in,1) + if (ybmaxr < 1.) + ybmaxr = ybmaxr * IM_LEN(in,2) + + xbmin = max (1, min (IM_LEN(in,1), nint (min (xbminr, xbmaxr)))) + xbmax = max (1, min (IM_LEN(in,1), nint (max (xbminr, xbmaxr)))) + ybmin = max (1, min (IM_LEN(in,2), nint (min (ybminr, ybmaxr)))) + ybmax = max (1, min (IM_LEN(in,2), nint (max (ybminr, ybmaxr)))) + + if (clip) + call illumination (in, out, xbmin, ybmin, xbmax, ybmax, + lowsigma, highsigma, inverse) + else + call qillumination (in, out, xbmin, ybmin, xbmax, ybmax, inverse) + + # Log the operation. + if (log == YES) { + if (ndivzero > 0) { + call sprintf (Memc[str], SZ_LINE, + "Warning: %d divisions by zero replaced by %g") + call pargi (ndivzero) + call pargr (rdivzero) + call ccdlog (out1, Memc[str]) + } + call sprintf (Memc[str], SZ_LINE, + "Illumination correction created from %s") + call pargstr (input) + call timelog (Memc[str], SZ_LINE) + call ccdlog (out1, Memc[str]) + } + call hdmpstr (out, "mkillum", Memc[str]) + call hdmpstr (out, "imagetyp", "illum") + + # Finish up + call imunmap (in) + call imunmap (out) + if (streq (input, output)) { + call ccddelete (input) + call imrename (Memc[tmp], input) + } else + call strcpy (output, input, SZ_FNAME) + call sfree (sp) +end + + +# ILLUMINATION -- Make illumination correction image with clipping. + +procedure illumination (in, out, xbmin, ybmin, xbmax, ybmax, low, high, inverse) + +pointer in # Pointer to the input image +pointer out # Pointer to the output image +int xbmin, ybmin # Minimum dimensions of the boxcar +int xbmax, ybmax # Maximum dimensions of the boxcar +real low, high # Clipping sigma thresholds +int inverse # Return inverse of illumination? + +real scale, ccdmean +int i, ncols, nlines, linein, lineout, ybox2, nrej +pointer sp, ptr, ptrs, data, sum, avg, output + +long clktime() +int boxclean() +real asumr(), divzero() +pointer imgl2r(), impl2r() +extern divzero() + +begin + # Set up an array of linepointers and accumulators + ncols = IM_LEN(out,1) + nlines = IM_LEN(out,2) + call smark (sp) + call salloc (ptrs, ybmax, TY_POINTER) + call salloc (sum, ncols, TY_REAL) + call salloc (avg, ncols, TY_REAL) + if (inverse == YES) + call salloc (output, ncols, TY_REAL) + else + output = avg + + # Set input buffers. + if (ybmax < nlines) + call imseti (in, IM_NBUFS, ybmax) + + # Get the first average over the minimum y box. + call aclrr (Memr[sum], ncols) + linein = 0 + while (linein < ybmin) { + linein = linein + 1 + data = imgl2r (in, linein) + call aaddr (Memr[data], Memr[sum], Memr[sum], ncols) + ptr = ptrs + mod (linein, ybmax) + Memi[ptr] = data + } + ybox2 = ybmin + scale = ybmin + call agboxcar (Memr[sum], Memr[avg], ncols, xbmin, xbmax, scale) + + # Iteratively clean the initial lines. + ptr = ptrs + if (ybox2 != ybmax) + ptr = ptr + 1 + do i = 1, NITERATE { + nrej = 0 + do lineout = 1, linein { + data = Memi[ptr+lineout-1] + nrej = nrej + boxclean (Memr[data], Memr[avg], Memr[sum], + ncols, low, high) + } + if (nrej > 0) + call agboxcar (Memr[sum], Memr[avg], ncols, xbmin, xbmax, + scale) + else + break + } + + # Output the minimum smoothing y box. + if (inverse == YES) + call arczr (1., Memr[avg], Memr[output], ncols, divzero) + ybox2 = (ybmin + 1) / 2 + lineout = 0 + while (lineout < ybox2) { + lineout = lineout + 1 + call amovr (Memr[output], Memr[impl2r(out, lineout)], ncols) + } + ccdmean = ybox2 * asumr (Memr[output], ncols) + + # Increase the y box size by factors of 2 until the maximum size. + while (linein < ybmax) { + linein = linein + 1 + data = imgl2r (in, linein) + call aaddr (Memr[sum], Memr[data], Memr[sum], ncols) + ptr = ptrs + mod (linein, ybmax) + Memi[ptr] = data + scale = scale + 1 + + nrej = boxclean (Memr[data], Memr[avg], Memr[sum], ncols, + low, high) + call agboxcar (Memr[sum], Memr[avg], ncols, xbmin, xbmax, scale) + + linein = linein + 1 + data = imgl2r (in, linein) + call aaddr (Memr[sum], Memr[data], Memr[sum], ncols) + ptr = ptrs + mod (linein, ybmax) + Memi[ptr] = data + + nrej = boxclean (Memr[data], Memr[avg], Memr[sum], ncols, low, high) + scale = scale + 1 + call agboxcar (Memr[sum], Memr[avg], ncols, xbmin, xbmax, scale) + + lineout = lineout + 1 + data = impl2r (out, lineout) + if (inverse == YES) + call arczr (1., Memr[avg], Memr[data], ncols, divzero) + else + call amovr (Memr[avg], Memr[data], ncols) + ccdmean = ccdmean + asumr (Memr[data], ncols) + } + + # For each line subtract the last line from the sum, add the + # next line to the sum, and output a line. + + while (linein < nlines) { + linein = linein + 1 + ptr = ptrs + mod (linein, ybmax) + data = Memi[ptr] + call asubr (Memr[sum], Memr[data], Memr[sum], ncols) + data = imgl2r (in, linein) + call aaddr (Memr[sum], Memr[data], Memr[sum], ncols) + Memi[ptr] = data + + nrej = boxclean (Memr[data], Memr[avg], Memr[sum], ncols, low, high) + + lineout = lineout + 1 + data = impl2r (out, lineout) + call agboxcar (Memr[sum], Memr[avg], ncols, xbmin, xbmax, scale) + + if (inverse == YES) + call arczr (1., Memr[avg], Memr[data], ncols, divzero) + else + call amovr (Memr[avg], Memr[data], ncols) + ccdmean = ccdmean + asumr (Memr[data], ncols) + } + + # Decrease the y box in factors of 2 until minimum y box. + while (lineout < nlines - ybox2) { + linein = linein + 1 + ptr = ptrs + mod (linein, ybmax) + data = Memi[ptr] + call asubr (Memr[sum], Memr[data], Memr[sum], ncols) + linein = linein + 1 + ptr = ptrs + mod (linein, ybmax) + data = Memi[ptr] + call asubr (Memr[sum], Memr[data], Memr[sum], ncols) + scale = scale - 2 + + lineout = lineout + 1 + data = impl2r (out, lineout) + call agboxcar (Memr[sum], Memr[data], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[data], Memr[data], ncols, divzero) + ccdmean = ccdmean + asumr (Memr[data], ncols) + } + + # Output the last lines of the minimum y box size. + call agboxcar (Memr[sum], Memr[avg], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[avg], Memr[output], ncols, divzero) + ybox2 = nlines - lineout + while (lineout < nlines) { + lineout = lineout + 1 + data = impl2r (out, lineout) + call amovr (Memr[output], Memr[data], ncols) + } + ccdmean = ccdmean + ybox2 * asumr (Memr[output], ncols) + + # Write scale factor out. + ccdmean = ccdmean / (ncols * nlines) + call hdmputr (out, "ccdmean", ccdmean) + call hdmputi (out, "ccdmeant", int (clktime (long (0)))) + + # Free buffers + call sfree (sp) +end + + +# QILLUMCOR -- Quick (no clipping) illumination correction image. + +procedure qillumination (in, out, xbmin, ybmin, xbmax, ybmax, inverse) + +pointer in # pointer to the input image +pointer out # pointer to the output image +int xbmin, ybmin # Minimum dimensions of the boxcar +int xbmax, ybmax # Maximum dimensions of the boxcar +int inverse # return inverse of illumination + +real scale, ccdmean +int ncols, nlines, linein, lineout, ybox1 +pointer sp, ptr, ptrs, data, sum, output + +long clktime() +real asumr(), divzero() +pointer imgl2r(), impl2r() +extern divzero() + +begin + # Set up an array of linepointers and accumulators + ncols = IM_LEN(out,1) + nlines = IM_LEN(out,2) + + call smark (sp) + call salloc (ptrs, ybmax, TY_POINTER) + call salloc (sum, ncols, TY_REAL) + call salloc (output, ncols, TY_REAL) + + # Set input buffers. + if (ybmax < nlines) + call imseti (in, IM_NBUFS, ybmax) + + # Accumulate the minimum y box. + call aclrr (Memr[sum], ncols) + linein = 0 + while (linein < ybmin) { + linein = linein + 1 + data = imgl2r (in, linein) + call aaddr (Memr[data], Memr[sum], Memr[sum], ncols) + ptr = ptrs + mod (linein, ybmax) + Memi[ptr] = data + } + + # Output the minimum y box. + ybox1 = (ybmin + 1) / 2 + scale = ybmin + call agboxcar (Memr[sum], Memr[output], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[output], Memr[output], ncols, divzero) + lineout = 0 + while (lineout < ybox1) { + lineout = lineout + 1 + data = impl2r (out, lineout) + call amovr (Memr[output], Memr[data], ncols) + } + ccdmean = ybox1 * asumr (Memr[output], ncols) + + # Increase the y box size by steps of 2 until the maximum size. + while (linein < ybmax) { + linein = linein + 1 + data = imgl2r (in, linein) + call aaddr (Memr[sum], Memr[data], Memr[sum], ncols) + ptr = ptrs + mod (linein, ybmax) + Memi[ptr] = data + linein = linein + 1 + data = imgl2r (in, linein) + call aaddr (Memr[sum], Memr[data], Memr[sum], ncols) + ptr = ptrs + mod (linein, ybmax) + Memi[ptr] = data + + scale = scale + 2 + lineout = lineout + 1 + data = impl2r (out, lineout) + call agboxcar (Memr[sum], Memr[data], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[data], Memr[data], ncols, divzero) + ccdmean = ccdmean + asumr (Memr[data], ncols) + } + + # For each line subtract the last line from the sum, add the + # next line to the sum, and output a line. + + while (linein < nlines) { + linein = linein + 1 + ptr = ptrs + mod (linein, ybmax) + data = Memi[ptr] + call asubr (Memr[sum], Memr[data], Memr[sum], ncols) + data = imgl2r (in, linein) + call aaddr (Memr[sum], Memr[data], Memr[sum], ncols) + Memi[ptr] = data + + lineout = lineout + 1 + data = impl2r (out, lineout) + call agboxcar (Memr[sum], Memr[data], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[data], Memr[data], ncols, divzero) + ccdmean = ccdmean + asumr (Memr[data], ncols) + } + + # Decrease the y box in steps of 2 until minimum y box. + while (lineout < nlines - ybox1) { + linein = linein + 1 + ptr = ptrs + mod (linein, ybmax) + data = Memi[ptr] + call asubr (Memr[sum], Memr[data], Memr[sum], ncols) + linein = linein + 1 + ptr = ptrs + mod (linein, ybmax) + data = Memi[ptr] + call asubr (Memr[sum], Memr[data], Memr[sum], ncols) + + lineout = lineout + 1 + scale = scale - 2 + data = impl2r (out, lineout) + call agboxcar (Memr[sum], Memr[data], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[data], Memr[data], ncols, divzero) + ccdmean = ccdmean + asumr (Memr[data], ncols) + } + + # Output the last lines of the minimum y box size. + call agboxcar (Memr[sum], Memr[output], ncols, xbmin, xbmax, scale) + if (inverse == YES) + call arczr (1., Memr[output], Memr[output], ncols, divzero) + ybox1 = nlines - lineout + while (lineout < nlines) { + lineout = lineout + 1 + data = impl2r (out, lineout) + call amovr (Memr[output], Memr[data], ncols) + } + ccdmean = ccdmean + ybox1 * asumr (Memr[output], ncols) + + # Write scale factor out. + ccdmean = ccdmean / (ncols * nlines) + call hdmputr (out, "ccdmean", ccdmean) + call hdmputi (out, "ccdmeant", int (clktime (long (0)))) + + # Free buffers + call sfree (sp) +end + + +# AGBOXCAR -- Vector growing boxcar smooth. +# This implements the growing box algorithm which differs from the +# normal boxcar smoothing which uses a fixed size box. + +procedure agboxcar (in, out, ncols, xbmin, xbmax, ybox) + +real in[ncols] # Sum of ybox lines +real out[ncols] # Boxcar smoothed output +int ncols # Number of columns +int xbmin, xbmax # Boxcar size in x +real ybox # Boxcar size in y + +int colin, colout, lastcol, npix, xbmin2 +real sum, output + +begin + xbmin2 = (xbmin + 1) / 2 + colin = 0 + sum = 0. + while (colin < xbmin) { + colin = colin + 1 + sum = sum + in[colin] + } + + npix = xbmin * ybox + output = sum / npix + colout = 0 + while (colout < xbmin2) { + colout = colout + 1 + out[colout] = output + } + + while (colin < xbmax) { + colin = colin + 1 + sum = sum + in[colin] + colin = colin + 1 + sum = sum + in[colin] + npix = npix + 2 * ybox + colout = colout + 1 + out[colout] = sum / npix + } + + lastcol = 0 + while (colin < ncols) { + colin = colin + 1 + lastcol = lastcol + 1 + sum = sum + in[colin] - in[lastcol] + colout = colout + 1 + out[colout] = sum / npix + } + + while (colout < ncols - xbmin2) { + lastcol = lastcol + 1 + sum = sum - in[lastcol] + lastcol = lastcol + 1 + sum = sum - in[lastcol] + npix = npix - 2 * ybox + colout = colout + 1 + out[colout] = sum / npix + } + + output = sum / npix + while (colout < ncols) { + colout = colout + 1 + out[colout] = output + } +end + + +# BOXCLEAN -- Reject data values from the sum for the next boxcar average +# which exceed the minimum and maximum residual values from the current +# boxcar average. This excludes data from the moving average before it +# enters the average. + +int procedure boxclean (data, boxavg, sum, ncols, low, high) + +real data[ncols] # Data line +real boxavg[ncols] # Box average line +real sum[ncols] # Moving sum +int ncols # Number of columns +real low # Low clipping factor +real high # High clipping factor + +int i, nrej +real rms, resid, minresid, maxresid + +begin + rms = 0. + do i = 1, ncols + rms = rms + (data[i] - boxavg[i]) ** 2 + rms = sqrt (rms / ncols) + minresid = -low * rms + maxresid = high * rms + + nrej = 0 + do i = 1, ncols { + resid = data[i] - boxavg[i] + if ((resid < minresid) || (resid > maxresid)) { + data[i] = boxavg[i] + sum[i] = sum[i] - resid + nrej = nrej + 1 + } + } + + return (nrej) +end + + +# DIVZERO -- Error action for division by zero. + +real procedure divzero (x) + +real x # Value to be inversed + +real rdivzero # Result for divion by zero +int ndivzero # Number of zero divisions +common /cdivzero/ rdivzero, ndivzero + +begin + ndivzero = ndivzero + 1 + return (rdivzero) +end diff --git a/noao/imred/ccdred/src/t_mkskyflat.x b/noao/imred/ccdred/src/t_mkskyflat.x new file mode 100644 index 00000000..02696905 --- /dev/null +++ b/noao/imred/ccdred/src/t_mkskyflat.x @@ -0,0 +1,215 @@ +include <imhdr.h> +include "ccdred.h" +include "ccdtypes.h" + + +# T_MKSKYFLAT -- Apply a sky observation to a flat field to remove the +# residual illumination pattern. + +procedure t_mkskyflat() + +int listin # List of input CCD images +int listout # List of output CCD images +int ccdtype # CCD image type +int interactive # Fit overscan interactively? + +bool flatcor, ccdflag(), clgetb(), streq() +int imtopenp(), imtgetim() +pointer sp, input, output, tmp, str, in, out, ccd +errchk set_input, set_output, ccddelete + +begin + call smark (sp) + call salloc (input, SZ_FNAME, TY_CHAR) + call salloc (output, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Get the lists and instrument translation file. Open the translation + # file. Initialize the interactive flag and the calibration images. + + listin = imtopenp ("input") + listout = imtopenp ("mkskyflat.output") + call clgstr ("instrument", Memc[input], SZ_FNAME) + if (Memc[input] == EOS) + call error (1, "No 'instrument' translation file specified.") + call hdmopen (Memc[input]) + call set_interactive ("", interactive) + + # Force flat fields even if flatcor=no + flatcor = clgetb ("flatcor") + call clputb ("flatcor", true) + call cal_open (NULL) + call ccd_open (0) + call clputb ("flatcor", flatcor) + + # Process each image. + while (imtgetim (listin, Memc[input], SZ_FNAME) != EOF) { + if (clgetb ("noproc")) { + call printf ("%s: mkskyflat\n") + call pargstr (Memc[input]) + } + + # Set input and output images. Use temporary image if needed. + call set_input (Memc[input], in, ccdtype) + if (in == NULL) + next + + if (imtgetim (listout, Memc[output], SZ_FNAME) == EOF) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (Memc[output] == EOS) + call strcpy (Memc[input], Memc[output], SZ_FNAME) + if (streq (Memc[input], Memc[output])) + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + else + call strcpy (Memc[output], Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + + # Process image as an illumination image. + call set_proc (in, out, ccd) + call set_sections (ccd) + call set_trim (ccd) + call set_fixpix (ccd) + call set_overscan (ccd) + call set_zero (ccd) + call set_dark (ccd) + call set_flat (ccd) + + # Do the processing. + if (CORS(ccd) == YES) { + call doproc (ccd) + call set_header (ccd) + + # Finish up + flatcor = ccdflag (out, "flatcor") + call imunmap (in) + call imunmap (out) + if (streq (Memc[input], Memc[output])) { + call ccddelete (Memc[input]) + call imrename (Memc[tmp], Memc[input]) + } else + call strcpy (Memc[output], Memc[input], SZ_FNAME) + } else { + # Delete the temporary output image. Make a copy if needed. + flatcor = ccdflag (out, "flatcor") + call imunmap (in) + call imunmap (out) + call imdelete (Memc[tmp]) + } + call free_proc (ccd) + + # Do special processing. + if (!flatcor) { + call eprintf ( + "%s: WARNING - Image should be flat fielded first\n") + call pargstr (Memc[input]) + } + call mkillumination (Memc[input], Memc[output], NO, YES) + call mkskyflat (Memc[input], Memc[output]) + if (!streq (Memc[input], Memc[output])) + call ccdcopy (Memc[input], Memc[output]) + } + + # Finish up. + call hdmclose () + call imtclose (listin) + call imtclose (listout) + call cal_close () + call ccd_close () + call sfree (sp) +end + + +# MKSKYFLAT -- Make a sky flat by dividing the input illumination image by +# the flat field. + +procedure mkskyflat (input, output) + +char input[SZ_FNAME] # Input image +char output[SZ_FNAME] # Output image + +int i, nc, nl +long time +real scale +pointer sp, str, flat, tmp, in, im, out, out1, data + +int hdmgeti() +bool clgetb(), ccdflag(), streq() +real hdmgetr() +pointer immap(), imgl2r(), impl2r() +errchk immap, ccddelete + +begin + # Check if this operation has been done. + in = immap (input, READ_ONLY, 0) + if (ccdflag (in, "skyflat")) { + call imunmap (in) + return + } + + # Print operation if not processing. + if (clgetb ("noproc")) { + call eprintf ( + " [TO BE DONE] Convert %s to sky flat\n") + call pargstr (input) + call imunmap (in) + return + } + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (flat, SZ_FNAME, TY_CHAR) + call salloc (tmp, SZ_FNAME, TY_CHAR) + + # Get the flat field. + call cal_image (in, FLAT, 1, Memc[flat], SZ_FNAME) + im = immap (Memc[flat], READ_ONLY, 0) + iferr (scale = hdmgetr (im, "ccdmean")) + scale = 1. + iferr (time = hdmgeti (im, "ccdmeant")) + time = IM_MTIME(im) + if (time < IM_MTIME(im)) + scale = 1. + + # Create the temporary output. + if (streq (input, output)) { + call mktemp ("tmp", Memc[tmp], SZ_FNAME) + call set_output (in, out, Memc[tmp]) + out1 = in + } else { + call set_output (in, out, output) + out1 = out + } + + # Multiply the illumination and flat field images with scaling. + nc = IM_LEN(out,1) + nl = IM_LEN(out,2) + do i = 1, nl { + data = impl2r (out, i) + call amulr (Memr[imgl2r(in,i)], Memr[imgl2r(im,i)], + Memr[data], nc) + if (scale != 1.) + call adivkr (Memr[data], scale, Memr[data], nc) + } + + # Log the operation. + call sprintf (Memc[str], SZ_LINE, + "Sky flat created from %s and %s") + call pargstr (input) + call pargstr (Memc[flat]) + call timelog (Memc[str], SZ_LINE) + call ccdlog (out1, Memc[str]) + call hdmpstr (out, "skyflat", Memc[str]) + call hdmpstr (out, "imagetyp", "flat") + + # Finish up + call imunmap (in) + call imunmap (im) + call imunmap (out) + if (streq (input, output)) { + call ccddelete (input) + call imrename (Memc[tmp], input) + } else + call strcpy (output, input, SZ_FNAME) + call sfree (sp) +end diff --git a/noao/imred/ccdred/src/t_skyreplace.x b/noao/imred/ccdred/src/t_skyreplace.x new file mode 100644 index 00000000..9bd2e9d0 --- /dev/null +++ b/noao/imred/ccdred/src/t_skyreplace.x @@ -0,0 +1,301 @@ +include <imhdr.h> + + +# T_SKYREPLACE -- Replace objects by sky. This development code as is not +# used in the package. It is here to be worked on further when an image +# display interface is added. + +procedure t_skyreplace () + +char image[SZ_FNAME] # Image to be modified + +char graph[SZ_LINE], display[SZ_LINE], cmd[SZ_LINE] +pointer im, immap() +int clgeti(), wcs, key, clgcur(), nrep, skyreplace() +real wx, wy, xc, yc, r, s + +begin + call clgstr ("image", image, SZ_FNAME) + call sprintf (graph, SZ_LINE, "contour %s") + call pargstr (image) + call sprintf (display, SZ_LINE, "display %s %d") + call pargstr (image) + call pargi (clgeti ("frame")) + + im = immap (image, READ_WRITE, 0) + while (clgcur ("cursor",wx, wy, wcs, key, cmd, SZ_LINE) != EOF) { + switch (key) { + case 'a': + r = sqrt ((wx - xc) ** 2 + (wy - yc) ** 2) + s = 2 * r + case 'b': + nrep = skyreplace (im, xc, yc, r, s) + case 'c': + xc = wx + yc = wy + case 'd': + call imunmap (im) + call clcmdw (display) + im = immap (image, READ_WRITE, 0) + case 'g': + call imunmap (im) + call clcmdw (graph) + im = immap (image, READ_WRITE, 0) + case 'q': + break + default: + call printf ("\007") + } + } + + call imunmap (im) +end + + +define NSKY 100 # Minimum number of sky points + +int procedure skyreplace (im, xc, yc, r, s) + +pointer im # IMIO pointer +real xc, yc # Object center +real r # Object aperture radius +real s # Sky aperture radius + +real avg, sigma, urand(), mode, find_mode() +long seed +int xlen, ylen, nx, nx1, nx2, ny, ny1, ny2, ntotal, nobj, nallsky, nsky[4] +int i, j, x1, x2, x3, x4, y1, y2, y3, y4, y +pointer sp, allsky, sky[4], ptr1, ptr2 +pointer datain, dataout, imgs2r(), imps2r() + +begin + xlen = IM_LEN(im,1) + ylen = IM_LEN(im,2) + x1 = max (1, int (xc - s)) + x4 = min (xlen, int (xc + s + 0.5)) + y1 = max (1, int (yc - s)) + y4 = min (ylen, int (yc + s + 0.5)) + nx = x4 - x1 + 1 + ny = y4 - y1 + 1 + ntotal = nx * ny + + x2 = max (1, int (xc - r)) + x3 = min (xlen, int (xc + r + 0.5)) + y2 = max (1, int (yc - r)) + y3 = min (xlen, int (yc + r + 0.5)) + nx1 = (x3 - x2 + 1) + ny1 = (y3 - y2 + 1) + nobj = nx1 * ny1 + nallsky = ntotal - nobj + + if ((nallsky < NSKY) || (nobj < 1)) + return (0) + + call smark (sp) + call salloc (allsky, nallsky, TY_REAL) + datain = imgs2r (im, x1, x4, y1, y4) + dataout = imps2r (im, x2, x3, y2, y3) + ptr2 = allsky + + # First quadrant + x2 = max (1, int (xc - r)) + x3 = min (xlen, int (xc + 0.5)) + y2 = max (1, int (yc - r)) + y3 = min (xlen, int (yc + 0.5)) + nx1 = x3 - x1 + 1 + nx2 = x3 - x2 + ny1 = y2 - y1 + ny2 = y3 - y2 + 1 + nsky[1] = nx1 * ny1 + nx2 * ny2 + sky[1] = ptr2 + + if (nsky[1] > 0) { + ptr1 = datain + for (y=y1; y<y2; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx1) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx1 + } + for (; y<=y3; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx2) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx2 + } + } + + # Second quadrant + x2 = max (1, int (xc + 1.5)) + x3 = min (xlen, int (xc + r + 0.5)) + y2 = max (1, int (yc - r)) + y3 = min (xlen, int (yc + 0.5)) + nx1 = x4 - x2 + 1 + nx2 = x4 - x3 + ny1 = y2 - y1 + ny2 = y3 - y2 + 1 + nsky[2] = nx1 * ny1 + nx2 * ny2 + sky[2] = ptr2 + + if (nsky[2] > 0) { + ptr1 = datain + x2 - x1 + for (y=y1; y<y2; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx1) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx1 + } + ptr1 = ptr1 + x3 - x2 + 1 + for (; y<=y3; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx2) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx2 + } + } + + # Third quadrant + x2 = max (1, int (xc - r)) + x3 = min (xlen, int (xc + 0.5)) + y2 = max (1, int (yc + 1.5)) + y3 = min (xlen, int (yc + r + 0.5)) + nx1 = x3 - x2 + nx2 = x3 - x1 + 1 + ny1 = y3 - y2 + 1 + ny2 = y4 - y3 + nsky[3] = nx1 * ny1 + nx2 * ny2 + sky[3] = ptr2 + + if (nsky[3] > 0) { + ptr1 = datain + (y2 - y1) * nx + for (y=y2; y<=y3; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx1) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx1 + } + for (; y<=y4; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx2) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx2 + } + } + + # Fourth quadrant + x2 = max (1, int (xc + 1.5)) + x3 = min (xlen, int (xc + r + 0.5)) + y2 = max (1, int (yc + 1.5)) + y3 = min (xlen, int (yc + r + 0.5)) + nx1 = x4 - x3 + nx2 = x4 - x2 + 1 + ny1 = y3 - y2 + 1 + ny2 = y4 - y3 + nsky[4] = ny1 * nx1 + ny2 * nx2 + sky[4] = ptr2 + + if (nsky[4] > 0) { + ptr1 = datain + (y2 - y1) * nx + x3 - x1 + 1 + for (y=y2; y<=y3; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx1) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx1 + } + ptr1 = ptr1 - (x3 - x2 + 1) + for (; y<=y4; y=y+1) { + call amovr (Memr[ptr1], Memr[ptr2], nx2) + ptr1 = ptr1 + nx + ptr2 = ptr2 + nx2 + } + } + + # This part is for doing a gradient correction. It is not implemented. +# if ((nsky[1]>NSKY)&&(nsky[2]>NSKY)&&(nsky[3]>NSKY)&&(nsky[4]>NSKY)) { +# call asrtr (Memr[sky[1]], Memr[sky[1]], nsky[1]) +# call asrtr (Memr[sky[2]], Memr[sky[2]], nsky[2]) +# call asrtr (Memr[sky[3]], Memr[sky[3]], nsky[3]) +# call asrtr (Memr[sky[4]], Memr[sky[4]], nsky[4]) + + # Add a gradient correction here. + +# seed = dataout +# do i = dataout, dataout+nobj-1 { +# j = 4 * urand (seed) + 1 +# k = 0.95 * nsky[j] * urand (seed) +# Memr[i] = Memr[sky[j]+k] +# } +# } else { + call asrtr (Memr[allsky], Memr[allsky], nallsky) + + # Find the mean and sigma excluding the outer 20% + x1 = 0.1 * nallsky + x2 = 0.9 * nallsky + call aavgr (Memr[allsky+x1-1], x2-x1+1, avg, sigma) + mode = find_mode (Memr[allsky], nallsky, nallsky / 20) + call printf ("Mean = %g, Median = %g, Mode = %g\n") + call pargr (avg) + call pargr (Memr[allsky+nallsky/2-1]) + call pargr (mode) + for (x1=0; (x1<nallsky)&&(Memr[allsky+x1]<avg-3*sigma); x1=x1+1) + ; + for (x2=nallsky-1; (x2>0)&&(Memr[allsky+x2]>avg+3*sigma); x2=x2-1) + ; + nx = x2 - x1 - 1 + + seed = dataout + do i = dataout, dataout+nobj-1 { + j = nx * urand (seed) + x1 + Memr[i] = Memr[allsky+j] + } +# } + + call sfree (sp) + return (nobj) +end + +real procedure find_mode (data, npts, n) + +real data[npts] # Data +int npts # Number of data points +int n # Bin size + +int x, xlast, xmin +real sumx, sumy, sumxx, sumxy, a, amin +pointer sp, slope + +begin + call smark (sp) + call salloc (slope, npts - n, TY_REAL) + + sumx = 0. + sumy = 0. + sumxx = 0. + sumxy = 0. + + x = 0 + xlast = 0 + while (x < n) { + x = x + 1 + sumx = sumx + x + sumy = sumy + data[x] + sumxx = sumxx + x ** 2 + sumxy = sumxy + x * data[x] + } + amin = (n * sumxy - sumx * sumy) / (n * sumxx - sumx ** 2) + xmin = (x + xlast) / 2 + Memr[slope] = amin + + while (x < npts - n) { + x = x + 1 + xlast = xlast + 1 + sumx = sumx + x - xlast + sumy = sumy + data[x] - data[xlast] + sumxx = sumxx + x * x - xlast * xlast + sumxy = sumxy + x * data[x] - xlast * data[xlast] + + a = (n * sumxy - sumx * sumy) / (n * sumxx - sumx ** 2) + if (a < amin) { + amin = a + xmin = (x + xlast) / 2 + } + Memr[slope+xlast] = a + } + + call gplotv (Memr[slope+11], npts-2*n-22, 1., real (npts-2*n-22), "") + call sfree (sp) + return (data[xmin]) +end diff --git a/noao/imred/ccdred/src/timelog.x b/noao/imred/ccdred/src/timelog.x new file mode 100644 index 00000000..7a8d969f --- /dev/null +++ b/noao/imred/ccdred/src/timelog.x @@ -0,0 +1,29 @@ +include <time.h> + + +# TIMELOG -- Prepend a time stamp to the given string. +# +# For the purpose of a history logging prepend a short time stamp to the +# given string. Note that the input string is modified. + +procedure timelog (str, max_char) + +char str[max_char] # String to be time stamped +int max_char # Maximum characters in string + +pointer sp, time, temp +long clktime() + +begin + call smark (sp) + call salloc (time, SZ_DATE, TY_CHAR) + call salloc (temp, max_char, TY_CHAR) + + call cnvdate (clktime(0), Memc[time], SZ_DATE) + call sprintf (Memc[temp], max_char, "%s %s") + call pargstr (Memc[time]) + call pargstr (str) + call strcpy (Memc[temp], str, max_char) + + call sfree (sp) +end |