pax_global_header00006660000000000000000000000064133216631430014514gustar00rootroot0000000000000052 comment=294a8ff98555fda6990ebb6d23fdb65ef79cf6f7 mscred-5.05-2018.07.09/000077500000000000000000000000001332166314300137665ustar00rootroot00000000000000mscred-5.05-2018.07.09/COPYRIGHT000066400000000000000000000031241332166314300152610ustar00rootroot00000000000000Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. The IRAF software is publicly available, but is NOT in the public domain. The difference is that copyrights granting rights for unrestricted use and redistribution have been placed on all of the software to identify its authors. You are allowed and encouraged to take this software and use it as you wish, subject to the restrictions outlined below. Permission to use, copy, modify, and distribute this software and its documentation is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation, and that references to the Association of Universities for Research in Astronomy Inc. (AURA), the National Optical Astronomy Observatories (NOAO), or the Image Reduction and Analysis Facility (IRAF) not be used in advertising or publicity pertaining to distribution of the software without specific, written prior permission from NOAO. NOAO makes no representations about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. NOAO DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL NOAO BE LIABLE FOR ANY SPECIAL, INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. mscred-5.05-2018.07.09/README000066400000000000000000000156231332166314300146550ustar00rootroot00000000000000 MSCRED: CCD MOSAIC REDUCTION PACKAGE Release Notes and Installation Instructions SUMMARY The MSCRED external package is used to reduce CCD mosaic data in which the data is in the mosaic MEF data format. RELEASE INFORMATION The following summary only highlights the major changes. There will also be minor changes and bug fixes. V5.05: August 9, 2012 Fixed a problem in mscfinder.msctpeak which complained about not being able to open a temporary file. V5.04: August 17, 2011 Relinked against IRAF 2.15.1a to pick up core library changes. V5.04: February 18, 2011 Fixed a bug with a missing argument to a procedure which caused a crash with combine in the macintel architecture. V5.03: February 3, 2011 Fixed 64-bit bug in xtalkcor. V5.02: January 20, 2011 Fixed bug in ccdproc. V5.01: January 10, 2011 Fixed bug in mscdisplay. V5.0: December 16, 2010 INSTALLATION INSTRUCTIONS Installation of this external package consists of obtaining the files, unpacking them, optionally compiling the executables if not included in the distribution, and defining the environment to load and run the package. Note that starting with IRAF V2.15 there are installation utilities which automate this process. So these installation instructions here are for primarily for earlier versions of IRAF or those wishing to use the older method. The package may be installed for a site or as a personal installation. If you need help with these installation instructions post a request at the iraf.net website. The first step is determining your host IRAF architecture. If you are not sure but have a running IRAF installation then, after starting the command language, type cl> show arch .redhat This is the value you need to know without the leading '.'; i.e. the IRAF architecture is "redhat" in the example. The distributions files may be found in various places. If you got this document from an ftp directory the files should also be in that directory with names of the form "mscred-.tar.gz. These are gzip compressed tar files. The files for each architecture include the binaries except for "src" which is only the source. Unlike earlier distributions (prior to Dec 2010) the tar files are created so that they are unpacked in the external package directory of your choosing and the "mscred" subdirectory will be created. % cd # e.g. /iraf/extern or /extern % tar xzf % ls -d mscred mscred If you want to have multiple binaries, such as for a server, the simplest thing is to untar each architecture version. This will redundantly install the same source files which is harmless. If you already have an older mscred directory you should first remove it. If you want to have multiple versions you can rename it as an older version, make a directory for the new version, for instance "mscredV5.0", and unpack in that directory. % cd # e.g. /iraf/extern % mv mscred # if this is a directory % mkdir # e.g. mscredV5.0 % cd % tar xzf % cd .. % rm mscred # if this is a previous link % ln -s /mscred . Instead of using a link, as shown above, you can also specify paths and directories as you wish in the $iraf/unix/hlib/extern.pkg file, your loginuser.cl file, or interactively as follows. To define the package you need to an IRAF logical path to the mscred directory and a "task" declaration. As noted above, this is often done in the $iraf/unix/hlib/extern.pkg file but it can also be done in your irafuser.csh file or even interactively. The statements you need are something like: reset mscred = /local/mscred/ task mscred.pkg = mscred$mscred.cl Be sure to end the directory path with '/'. For the help files you must include mscred$lib/helpdb.mip in the "helpdb" path. A template of this is found in the extern.pkg file or something like printf ("reset helpdb=%s,mscred$lib/helpdb.mip\nkeep\n", envget("helpdb")) | cl flpr in your login.cl or loginuser.cl file. Make sure there is "keep" statement at the end of the file. MSCDB For NOAO Mosaic Imager data a separate instrument database distribution should also be installed. The distribution file is "mscdb-univeral.tar.gz. This is unpacked in some directory such as the directory containing the mscred package. Then in extern.pkg, loginuser.cl, or login.cl add set mscdb = / # ending with '/' This is usually done in the same way and place that you define the mscred package. COMPILING If you will be compiling the package, as opposed to installing a binary distribution, then you need to define various environment variables. The following is for Unix/csh which is the main supported environment. % setenv iraf /iraf/iraf/ # Path to IRAF root (example) % source $iraf/unix/hlib/irafuser.csh # Define rest of environment % setenv IRAFARCH redhat # IRAF architecture % setenv mscred / # Path to package where you need to supply the appropriate path to the IRAF installation root in the first step and the IRAF architecture identifier for your machine in the last step. If you are updating to a newer version and you earlier built the libraries and executables it is necessary to delete these. Otherwise, depending on the dates of files in the new version and the locally built libraries, it may cause the new version to be ignored. To do this the package is configured "generic" which puts all the binary files in one binary directory, the files are deleted and then you continue in the same way as a completely new installation. cl> mkpkg generic cl> delete bin./* # Substitute redhat, etc. Configure the package for the particular architecture to be built. cl> mkpkg # Substitute redhat, etc. This will change the bin link from bin.generic to bin.. The binary directory will be created if not present. If an error occurs in setting the architecture then you may need to add an entry to the file "mkpkg". Just follow the examples in the file. To create the executables and move them to the binary directory cl> mkpkg -p mscred # build executables cl> mkpkg generic # optionally restore generic setting Check for errors. If the executables are not moved to the binary directory then the $mscred path package was not done correctly (such as not having a trailing '/'. The last step restores the package to a generic configuration. This is not necessary if you will only have one architecture for the package. This should complete the installation. You can now load the package and begin testing and use. mscred-5.05-2018.07.09/bin000077700000000000000000000000001332166314300165622bin.genericustar00rootroot00000000000000mscred-5.05-2018.07.09/doc/000077500000000000000000000000001332166314300145335ustar00rootroot00000000000000mscred-5.05-2018.07.09/doc/ccdlist.hlp000066400000000000000000000131601332166314300166660ustar00rootroot00000000000000.help ccdlist Jul01 mscred .ih NAME ccdlist -- List CCD processing information .ih USAGE ccdlist images .ih PARAMETERS .ls images List of mosaic exposures to be listed. A subset of the these may be selected using the CCD image type parameter. .le .ls ccdtype = "" CCD type to be listed. If no type is specified then all the types are listed. If a CCD type is specified then only images of that type are listed. See \fBccdtypes\fR for a list of the package image types. .le .ls extname = "" Comma delimited list of patterns matching the extension names to be listed. The null string, "", selects all extension names. Otherwise a pattern must match the full name. For example the pattern "[1-8]" matches "5" but not "im5". One form of pattern is an exact match so that a parameter value of "im1,im12" matches both "im1" and "im12", but not "im11". Typically the parameter would be "" to select all extensions or just the name of the first extension since all extensions should have the same filter, type, title, and processing status. .le .ls names = no List the image names only? Used with the CCD image type parameter to make a list of the images of the specified type. .le .ls long = no Long format listing? The images are listed in a long format containing some image parameters and the processing history. .le .ls ccdproc (pset) CCD processing parameter set. .le .ih DESCRIPTION Information from the specified input mosaic exposures is listed on the standard output. A specific CCD type may be selected from the input exposures by the parameter \fIccdtype\fR. There are three list formats; the default one line per image format, an image name only format, and a multi-line long format. The default one line format consists of the image name, image size, image pixel type, CCD image type, amplifier ID (if defined), subset ID (if defined), processing flags, and title. This format contains the same information as that produced by \fBimheader\fR as well as CCD specific information. The processing flags identifying the processing operations performed on the image are given by the following single letter codes. .nf X - Crosstalk correction B - Bad pixel replacement O - Overscan bias subtraction T - Trimming Z - Zero level subtraction D - Dark count subtraction F - Flat field calibration .fi The long format has the same first line as the default format plus additional instrument information such as the exposure time and the full processing history. In addition to listing the completed processing, the operations not yet done (as specified by the \fBccdproc\fR parameters) are also listed. The image name only format is intended to be used to generate lists of images of the same CCD image type. These lists may be used as "@" file lists in IRAF tasks. .ih EXAMPLES 1. To list the default format for extension im1 of all images: .nf cl> ccdlist *.fits extname=im1 ccd001.fits[im1][544,512][short][unknown][1][V]:FOCUS L98-193 ccd007.fits[im1][544,512][short][object][1][V]:N2968 V 600s ccd015.fits[im1][544,512][short][object][1][B]:N3098 B 500s ccd024.fits[im1][544,512][short][object][1][R]:N4036 R 600s ccd045.fits[im1][544,512][short][flat][1][V]:dflat 6v+blue 5s ccd066.fits[im1][544,512][short][flat][1][B]:dflat 6v+blue 5s ccd103.fits[im1][544,512][short][flat][1][R]:dflat 6v+blue 5s ccd104.fits[im1][544,512][short][zero][1][]:bias ccd105.fits[im1][544,512][short][dark][1][]:dark 3600s .fi 2. To list all extensions of one mosaic exposure which has been processed: .nf cl> ccdlist obj092 obj092[im1][128,256][real][object][1][R][XBOTZF]:NGC1569 obj092[im2][128,256][real][object][2][R][XBOTZF]:NGC1569 obj092[im3][128,256][real][object][3][R][XBOTZF]:NGC1569 obj092[im4][128,256][real][object][4][R][XBOTZF]:NGC1569 obj092[im5][127,256][real][object][5][R][XBOTZF]:NGC1569 obj092[im6][127,256][real][object][6][R][XBOTZF]:NGC1569 obj092[im7][127,256][real][object][7][R][XBOTZF]:NGC1569 obj092[im8][127,256][real][object][8][R][XBOTZF]:NGC1569 .fi These exposures have not been processed. 3. To restrict the listing to just the object images: .nf cl> ccdlist *.fits extname=im1 ccdtype=object ccd007.fits[im1][544,512][short][object][1][V]:N2968 V 600s ccd015.fits[im1][544,512][short][object][1][B]:N3098 B 500s ccd024.fits[im1][544,512][short][object][1][R]:N4036 R 600s .fi 4. The long list for image "ccd007" is obtained by: .nf cl> ccdlist ccd007 extname=im1 l+ ccd007[im1][544,512][short][object][1][V]:N2968 R 600s exptime = 200. darktime = 200. [TO BE DONE] Overscan strip is [520:540,*] [TO BE DONE] Trim image section is [3:510,3:510] [TO BE DONE] Flat field correction .fi 5. After processing the images have the short listing: .nf cl> ccdlist *.fits extname=im1 ccdtype=object ccd007.fits[im1][508,508][real][object][1][V][OTF]:N2968 V 600s ccd015.fits[im1][508,508][real][object][1][B][OTF]:N3098 B 500s ccd024.fits[im1][544,512][short][object][1][R][OTF]:N4036 R 600s .fi The processing indicated is overscan subtraction, trimming, and flat fielding. 6. The long listing for "ccd007" after processing is: .nf cl> ccdlist ccd007 extname=im1 l+ ccd007[im1][508,508][real][object][1][V][OTF]:N2968 R 600s exptime = 200. darktime = 200. Jun 2 18:18 Overscan section is [520:540,*] with mean=481.8784 Jun 2 18:18 Trim data section is [3:510,3:510] Jun 2 18:19 Flat field image is FlatV with scale=138.2713 .fi .ih REVISIONS .ls CCDLIST - MSCRED Modified to work with multiextension mosaic exposures. .le .ls CCDLIST V2.11 Added amplifier field in listing. .le .ih SEE ALSO ccdtypes ccdgroups .endhelp mscred-5.05-2018.07.09/doc/ccdproc.hlp000066400000000000000000001222301332166314300166550ustar00rootroot00000000000000.help ccdproc Jan01 mscred .ih NAME ccdproc -- Process mosaic/multiple amplifier CCD data .ih USAGE ccdproc images .ih PARAMETERS .ls images List of mosaic or multiple amplifier CCD data to process. The data is typically in multiextension files though simple single images are allowed. If the input includes processed data requiring no further processing it will be silently skipped. Calibration data may be included in the input list and it will be selected and processed as needed provided the data has a keyword identifying the type of data. However, more commonly the calibration data is specified separately with the calibration data parameters. .le .ls output = "" List of output processed data. If no list is given then the processing will replace the input images with the processed images, possibly after making a backup of the input if the package "bkuproot" parameter is defined. If a list is given it must match the input list. \fINote that dependent calibration data requiring processing will be processed in-place (with optional backup).\fR .le .ls bpmasks = "" List of output bad pixel files or directories to contain bad pixel masks created for each input. If the input is a single image then the output is a bad pixel file while if the input is a multiextension file then the output is a directory to contain a bad pixel mask file for each extension. If no list is specified then no output masks will be produced. The output mask will be a combination of pixels specified in the "\fIfixfile\fR" parameter and identified as saturated or bleed trail pixels. .le .ls ccdtype = "" CCD type to select from the input list. If no type is given then all input will be selected. The recognized types are described in \fBccdtypes\fR. .le .ls noproc = no Only list processing steps to be performed for each input file? .le .ce PROCESSING SWITCHES .ls xtalkcor = no Apply a crosstalk correction? The crosstalk file is specified by the "xtalkfile" parameter. .le .ls fixpix = yes Fix bad CCD pixels by linear interpolation from neighboring lines and columns? If a file is specified by the "\fIfixfile\fR" parameter then the identified pixels will be interpolated upon input either along lines or columns depending on the mask value and dimensions of the regions. If saturated or bleed trail pixels are defined in this task, these will be interpolated on output (i.e. after all other processing) along lines. .le .ls overscan = yes Apply overscan or prescan bias correction? If yes then the overscan section must be specified with the "biassec" parameter. .le .ls trim = yes Trim the image of the overscan region and bad edge lines and columns? If yes then the data section must be specified with the "trimsec" parameter. .le .ls zerocor = yes Apply zero level correction? If yes a zero level image must be specified with the "zero" parameter. .le .ls darkcor = yes Apply dark count correction? If yes a dark count image must be specified with the "dark" parameter. .le .ls flatcor = yes Apply flat field correction? If yes flat field images must be specified with the "flat" parameter. .le .ls sflatcor = no Apply sky flat field correction? If yes sky flat field images must be specified with the "sflat" parameter. .le .ls merge = yes Merge amplifiers from the same CCD? If yes then the amplifier extensions with the same CCD name will be merged into a single extension with the header and extension name of the first amplifier extension in the file. If only a single extension results from the merging then a simple image file is produced. If the input has only one amplifier per CCD then nothing is done. The merging also creates new bad pixel masks if an output bad pixel mask is specified and if the merged masks differ from the current bad pixel masks. .le .ce PROCESSING PARAMETERS The parameters, "xtalkfile", "fixfile", "saturation", "bleed", "biassec", "trimsec", "zero", "dark", "flat", and "sflat" may reference keywords containing the desired value by preceding the keyword name with '!'. This allows each image or image extension in each input to have different values. Note that keyword name specified may be translated through the instrument file to another keyword or to a default value. .ls xtalkfile = "" Crosstalk file for the crosstalk correction. Only one crosstalk file may be specified and it applies to all the input data being processed. A keyword reference may be used to specify the file by preceding the keyword name with '!'. .le .ls fixfile = "" Bad pixel mask, image, or file. specified in the image header or instrument translation file. A bad pixel mask is a compact format (".pl" extension) with zero values indicating good pixels and non-zero values indicating bad pixels. A bad pixel image is a regular image in which zero values are good pixels and non-zero values are bad pixels. A bad pixel file specifies bad pixels or rectangular bad pixel regions as described later. The direction of interpolation is determined by the mask value with a value of two interpolating across columns, a value of three interpolating across lines, and any other non-zero value interpolating along the narrowest dimension. A keyword reference may be used to specify the mask by preceding the keyword name with '!'. The special value "BPM" may also be used reference the standard BPM keyword for a bad pixel mask. .le .ls saturation = "INDEF" Pixels with values equal to or greater than this value in the input data are identified as saturated by the mask value 4. The saturation value is specified by two words. The first word is a number giving the saturation pixel value. The value INDEF is equivalent to positive infinity and will identify no pixels as saturated. The second word is the units which may be "ADUs" or "electrons". If the units are "electrons" then the conversion from ADUs to electrons (in electrons per ADU) will be obtained from the "gain" keyword (which may be translated to some other keyword in the instrument file. The units may abbreviated or be omitted, which then defaults to "ADUs". If the first word is not a number (with or without a preceding '!') then the word is considered to be a keyword reference. The value of the keyword is interpreted in the same way as a number with optional units. Note that numeric keywords cannot not have a units specification so they will always be understood as being in ADUs. Since there is only one parameter value a keyword is the way to provide different saturation values for the extensions and list of input data. .le .ls sgrow = 0 Number of neighboring pixels along rows and columns from a saturated pixel which are also identified as saturated pixels. .le .ls bleed = "INDEF" Threshold for identifying bleed trail pixels. This may be specified in the same way as the saturation value including use of "ADUs" and "electrons" and reference to a header keyword. In addition the value may be set in relation to the saturation value or the mean of the data with one of the following specifications .nf saturation-X, saturation/X, mean+X, mean*X .fi where X is a number and the values are in ADU. For example the value "mean+5000" would define candidate bleed trail pixels as those which are 5000 counts above the mean. Note that for a pixel to actually be identified as a bleed pixel there must be a consecutive number of pixels (parameter \fIbtrail\fR) along a column which are above this threshold. .le .ls btrail = 20 Number of consecutive pixels with values above the bleed pixel threshold along a column to qualify as a bleed trail. The threshold is specified by the \fIbleed\fR parameter. .le .ls bgrow = 0 Number of neighboring pixels along rows and columns from a bleed trail pixel which are also identified as bleed trail pixels. .le Radius .ls biassec = "" Overscan bias image section. Only the part of the bias section along the lines is used. The column length of the bias region fit is defined by the trim section. If one wants to limit the region of the overscan used in the fit to be less than that of the trim section then the sample region parameter, \fIsample\fR, should be used. It is an error if no section or the whole image is specified. A keyword reference may be used to specify the file by preceding the keyword name with '!'. The older form of the special word "image" to reference the keyword BIASSEC is also allowed. .le .ls trimsec = "" Image section defining the trimmed output. A keyword reference may be used to specify the file by preceding the keyword name with '!'. The older form of the special word "image" to reference the keyword TRIMSEC is also allowed. .le .ls fixfile = "" Bad pixel mask, image, or file. specified in the image header or instrument translation file. A bad pixel mask is a compact format (".pl" extension) with zero values indicating good pixels and non-zero values indicating bad pixels. A bad pixel image is a regular image in which zero values are good pixels and non-zero values are bad pixels. A bad pixel file specifies bad pixels or rectangular bad pixel regions as described later. The direction of interpolation is determined by the mask value with a value of two interpolating across columns, a value of three interpolating across lines, and any other non-zero value interpolating along the narrowest dimension. A keyword reference may be used to specify the mask by preceding the keyword name with '!'. The special value "BPM" may also be used reference the standard BPM keyword for a bad pixel mask. .le .ls zero = "" List of zero level calibration files. The first image or image extension matching the amplifier of the input image to be calibrated is used. The CCD type and subset are not checked for these images. If no calibration image is found as specified by this parameter then the input list is checked for files of the appropriate CCD type. The zero level calibration images may be one or two dimensional. If the calibration file has not been processed it is processed as approprate for this type of calibration using the same parameters as for the input data being processed. A keyword reference may be used to specify the file by preceding the keyword name with '!'. .le .ls dark = "" List of dark count calibration files. The first image or image extension matching the amplifier of the input image to be calibrated is used. The CCD type and subset are not checked for these images. If no calibration image is found as specified by this parameter then the input list is checked for files of the appropriate CCD type. If the calibration file has not been processed it is processed as approprate for this type of calibration using the same parameters as for the input data being processed. A keyword reference may be used to specify the file by preceding the keyword name with '!'. .le .ls flat = "" List of flat field calibration files. The first image or image extension matching the amplifier and subset of the input image to be calibrated is used. The CCD type and subset are not checked for these images. If no calibration image is found as specified by this parameter then the input list is checked for files of the appropriate CCD type. If the calibration file has not been processed it is processed as approprate for this type of calibration using the same parameters as for the input data being processed. The flat field images may be one or two dimensional. A keyword reference may be used to specify the file by preceding the keyword name with '!'. .le .ls sflat = "" List of sky flat field calibration files. The first image or image extension matching the amplifier and subset of the input image to be calibrated is used. The CCD type and subset are not checked for these images. If no calibration image is found as specified by this parameter then the input list is checked for files of the appropriate CCD type. If the calibration file has not been processed it is processed as approprate for this type of calibration using the same parameters as for the input data being processed. The sky flat field images may be one or two dimensional. A keyword reference may be used to specify the file by preceding the keyword name with '!'. .le .ls minreplace = 1. When processing flat fields, pixel values below this value (after all other processing such as overscan, zero, and dark corrections) are replaced by this value. This allows flat fields processed by \fBccdproc\fR to be certain to avoid divide by zero problems when applied to object images. .le .ce OVERSCAN BIAS FITTING PARAMETERS There are two types of overscan (or prescan) bias determinations. One determines a independent bias value for each line. The other averages the overscan columns to make an overscan vector, fits a smooth bias function to the vector, and then evaluates the bias function to get the bias at each line. The line-by-line bias determination only uses the \fIfunction\fR parameter. The bias function determination uses the \fBicfit\fR procedure with the following parameters. .ls interactive = no Fit the overscan bias vector interactively? If yes and the bias function type is one of the \fBicfit\fR types then the average overscan bias vector is fit interactively using the \fBicfit\fR package. If no then the fitting parameters are used in a non-interactive fit. .le .ls function = "legendre" Line-by-line determination of the bias is specified by: .nf mean - the mean of the biassec columns at each line median - the median of the biassec columns at each line minmax - the mean at each line with the min and max excluded .fi The bias vector may be fit by one of the functions: .nf legendre - legendre polynomial chebyshev - chebyshev polynomial spline1 - linear spline spline3 - cubic spline .fi .le .ls order = 1 Number of polynomial terms or spline pieces in the overscan fit. To simply use the average bias use a polynomial function of order 1. .le .ls sample = "*" Sample points to use in the overscan bias fit. The string "*" specifies all points otherwise an \fBicfit\fR range string is used. .le .ls naverage = 1 Number of points to average or median to form fitting points. Positive numbers specify averages and negative numbers specify medians. .le .ls niterate = 1 Number of rejection interations to remove deviant points from the overscan fit. If 0 then no points are rejected. .le .ls low_reject = 3., high_reject = 3. Low and high sigma rejection factors for rejecting deviant points from the overscan fit. .le .ls grow = 0. One dimensional growing radius for rejection of neighbors to deviant points. .le .ce PACKAGE PARAMETERS .ls pixeltype = "real real" Output pixel datatype and calculation datatype. When images are processed or created, the output pixel datatype is the highest precision of the input pixel datatype and the specified output datatype. The allowed datatypes and order of precision are "short", "ushort", "int", "long", "real", or "double". The calculation datatype may either be short or real. Real is the default if no calculation type is specified. .le .ls verbose = no Print log information to the standard output? .le .ls logfile = "logfile" Logfile to append log information. If no filename is specified then no logfile is kept. .le .ls plotfile = "" Metacode plotfile for appending plots of the overscan bias fits. If no filename is specified then no metacode plotfile is kept. .le .ls backup = "once" (none|once|all) Backup the input data when the input file is replaced by the processed data? If the value is "none" then no backup of the input data is made. If the value is "once" then only the first backup of the input is made. If the value is "all" than if the input is repeatedly replaced by additional processing then additional backups will be made. .le .ls bkuproot = "Raw/" When a backup of the input data is made the string given by this parameter is used as a prefix to the original input data filename. If the root is a directory name (ends with '$' or '/') the directory will be created if needed and the input data moved to the directory. When the backup type is "all" and a second version of the input is backed up a digit is prepended to the input filename. .le .ls instrument = "" CCD instrument file. See help for \fBinstrument\fR. .le .ls ampfile = "amps" The "amp" keyword (which may be translated in the instrument file) produces a string identifying the amplifier for each image. A mapping between the full string and a short version (based on the first word) is stored in this file. .le .ls ssfile = "subsets" The "subset" keyword (which may be translated in the instrument file) produces a string identifying a subset for each image. A mapping between the full string and a short version (based on the first word) is stored in this file. .le .ls im_bufsize = 0.065536 When a line of an image is read a larger block of data is actually read. This parameter defines the block size in megabytes. For large images this I/O buffering often makes the processing more efficient. Note however that setting this to the size of the image does not necessarily make the processing faster. Once the block size reaches an optimal size for the disk I/O system it does not improve performance further and might actually degrade performance if too much memory is tied up. .le .ls graphics = "stdgraph" Graphics output device for interactive graphics. .le .ls cursor = "" Graphics cursor input. If null the standard terminal graphics cursor is used. .le .ls version Package version string. .le .ih DESCRIPTION \fBCcdproc\fR applies various calibrations and corrections to CCD data in multiextension (mosaic or multiamplifier) or single image formats. The calibrations and corrections are for amplifier crosstalk, detector defects, electronic bias, zero level bias, dark counts, and pixel responses. The task also identifies saturated pixels and bleed trails, trims unwanted edge lines and columns, merges multiple amplfiers from the same CCD into single images, and changes the pixel datatype. The task is designed to be efficient and easy to use. All one has to do is set the parameters and begin processing the data. The task takes care of most of the record keeping and automatically does the prerequisite processing of calibration images. Beneath this simplicity there is much going on. In this section a brief description of the usage is given. The following sections present detailed discussions on the different operations performed and the order and logic of the processing steps. One begins by setting the task parameters. There are many parameters but they may be easily reviewed and modified using "\fBeparam\fR". The CCD data to be processed is specified with the "input" parameter list as a combination of filenames, filename templates, and @files. Previously processed data are silently ignored and calibration files are recognized provided the CCD image types are identified in the image headers (see \fBinstruments\fR and \fBccdtypes\fR). Therefore it is permissible to use simple image templates such as "*.fits". However, it is recommended that calibration data by specified explicitly with the appropriated parameters. The "\fIccdtype\fR" parameter may be used to select only certain types of CCD data to process. If the data does not contain a CCD type identification keyword then the parameter can be set to the null string "". In this case it is the user's responsibility to select the correct processing steps for the type of data, and the calibration data cannot be determined automatically from the input list. The names for processed data are specified by the "\fIoutput\fR" parameter list of names which are matched in order against the input list. However, if no output list is given the processed data replaces the input data with an option to make a backup of the original input file (see the package "\fIbkuproot\fR" parameter). The output file will be in the same format as the input file except that if a multiextension input consists of multiple amplifiers from a single CCD and the amplifiers are merged, a single simple image will be produced. Other (optional) output includes pixel masks and processing log information. Output pixel masks are specified by the "\fIbpmasks\fR" parameter. The masks merge any input pixel mask data with identification of saturated or non-linear pixels and bleed trails. The processing information consists of a logfile and/or terminal output for text and a plotfile for plots of the overscan bias fitting. These are select with the package "\fIlogfile\fR", "\fIverbose\fR", and "\fIplotfile\fR" parameters. The processing operations are selected by boolean (yes/no) parameters. When the input data includes CCD type identifications the processing options may be set for object data and only the appropriate subset of operations will be performed on the calibration data. Any combination of operations may be specified. While it is possible to do operations in separate steps some sets of operations are done in a single pass through the data and will be more efficiently performed if done at the same time. The processing steps selected have related parameters which must be specified. These are things like image sections defining the electronic bias overscan and trim regions, parameters for identifying saturated pixels and bleed trails, and calibration files. There are a number of parameters used for fitting the overscan or prescan electronic bias data. These are parameters used by the standard IRAF curve fitting package \fBicfit\fR. Calibration data are specified by task parameters and/or in the input list. The task paramters are lists so more than one calibration file may be specified. Zero and dark count calibrations generally only need one file but flat field calibrations need one for each subset which is typically the filter. When more than one calibration file is specified then the first one encountered that matches the input is used and a warning is issued for the extra files. Calibration files specified by task parameters take precedence over calibration files in the input list. In addition to the task parameters there are package parameters which affect \fBccdproc\fR. These include the instrument, amplifier, and subset files, the verbose, text and plot output log settings, the output and calculation pixel datatype, the amount of memory to use for image I/O buffering, and the backup option. The instrument file is used to define the keywords to be used, translations of CCD type strings to a standard set, and defaults for missing keywords. The amplifier and subset files translate arbitrary keyword values for the amplifier and subset to short one word identifiers. Users may edit these files to change the mapping. The image I/O buffering may be increased to improve I/O efficiency. Note that this is just how much is read in one I/O request and is not a means to cache an image in memory. The backup option allows input files to be saved with a new name or in a directory when the processed data replaces the input. One may backup once, every time, or not at all. When a backup is requested the prefix string is added to the input name or the input is moved to the backup directory. The datatype parameter determines the type of the output pixel and the calculation mode. Typically raw CCD data is in short integers and processed data is saved as real (32-bit floating point) values. When an input file is processed the task first determines the processing parameters and calibration files. If a requested operation has been done it is skipped and if all requested operations have been completed then no processing takes place. When it determines that a calibration file is required it checks for the file from the task parameter and then for a calibration file of the proper type in the input list. Having selected a calibration file it checks if it has been processed. If it has not been processed, based on the current settings of the processing options appropriate for that type of calibration, it is processed automatically. Once the processing parameters and calibration files have been determined the input file is processed. The output processed data will include keywords identifying the processing steps and calibration files used. .sh xtalkcor: Amplifier Crosstalk Correction When multiple amplifiers are readout, such as occurs when using multiple amplifiers in a single CCD or multiple CCDs in a mosaic, there is the possibilty of crosstalk in the controller electronics. The crosstalk causes pixel values produced by one amplifier to be affected by the signal in another amplifier. There are many ways this crosstalk may affect the data. \fBCcdproc\fR includes a way to correct pixels based on a simple crosstalk model. In this model the signal for a pixel in one amplifier, which we call the "source", adds or subtracts a small amount to the pixel value read at the same time in another amplifier, called the "victim". A correction is obtained by multiplying the pixel value of the source image by a crosstalk coefficient and adding or subtracting it from the matching pixel in the victim image. Note that it is possible that a source may also be a victim and that a victim may be affected by multiple sources. In our simple model each pair of source and victim are treated independently and the source pixel values used to correct a victim are treated as unaffected by other amplifiers. The crosstalk coefficients are given by a crosstalk calibration file. This may be specified explicitly through reference to a keyword. The correction is performed by the task \fBxtalkcor\fR which is called from \fBccdproc\fR. Information about the format of the crosstalk calibration file and details of the algorithm are found in the description for that task. The crosstalk coefficients may provided by the observatory as a standard calibration file or they may be estimated from the data using the task \fBxtcoeff\fR. The crosstalk correction is performed before any other operation. The simple model of the crosstalk is that the raw data from the amplifier readout is used. Therefore the correction should generally be applied only to the raw data. .sh Saturated Pixels Saturated pixels are identified as those pixels with values above a fixed threshold in the input image before they are modified by any other calibration. Any pixels identified as bad in a pixel file given by the "\Ifixfile\fR" parameter are excluded. Neighboring pixels, those within a distance of "\fIsgrow\fR" pixels along lines or columns, of the threshold selected saturation pixels are also identified as saturated. To identify saturated pixels a saturation threshold is specified by the "\fIsaturation\fR" parameter. The saturation value may be given in units of digital counts as recorded in the image data or as electrons related to the digital counts through a gain keyword in the header. The parameter description explains how to specify the saturation threshold. The term "saturated" can really be used to apply to any pixels which are non-linear and not correctable. Thus the saturation threshold need not be the actual saturation of the CCD but some lower value where the pixels become uncorrectably non-linear. The identified pixels are recorded in the output bad pixel mask specified by the "\fIbpmasks\fR" parameter with a mask value of 4. If the "\fIfixpix\fR" processing option is selected the saturated pixels are replaced by linear interpolation along lines. If a pixel identified as bad in an input mask or file touches a saturated pixel it is also interpolated. This is done to avoid funny effects where the bad pixel is first interpolated using data which has not yet been identified as a bleed trail or saturated pixel and which is not subsequently replaced by more reasonable data values. Note that if no output pixel mask or pixel replacement are specified then the saturated pixels will have no effect. Therefore, the identification of such pixels is not done by the task even if the other parameters are set to identify saturated pixels. This operation does not apply to data identified as zero, dark, or flat. .sh Bleed Trails Bleed trails are identifed as regions with some minimum number of consecutive pixels along a columns having values above a fixed threshold. The pixel values are before they are modified by any other calibration. Neighboring pixels, those within a distance of "\fIbgrow\fR" pixels along lines or columns, of the threshold selected bleed trail pixels are also identified as part of the bleed trail. Any pixels identified as bad in a pixel file given by the "\Ifixfile\fR" parameter are excluded. To identify bleed trails a threshold is specified by the "\fIbleed\fR" parameter. The value may be given in units of digital counts as recorded in the image data or as electrons related to the digital counts through a gain keyword in the header. The parameter description explains how to specify the bleed threshold. In addition to an explicit value specified by the parameter or in the header the threshold may be specified in relation to the saturation threshold or to the mean value in the data. Note that it is not individual pixels above a threshold but a consecutive number of pixels. This means the threshold can be fairly low provided the minimum bleed trail length, specified by the "\fIbtrail\fR" parameter, is greater than would occur in objects. For this reason specifying the threshold as some number times the mean or above the mean is very useful. A recommendation is to use "mean+5000" when the data in counts are from 15 or 16 bit A/D converters. The identified pixels are recorded in the output bad pixel mask specified by the "\fIbpmasks\fR" parameter with a mask value of 5. If the "\fIfixpix\fR" processing option is selected the bleed trails are replaced by linear interpolation along lines. If pixel identified as bad in an input mask or file touches the bleed trail it is also interpolated. This is done to avoid funny effects where the bad pixel is first interpolated using data which has not yet been identified as a bleed trail or saturated pixel and which is not subsequently replaced by more reasonable data values. Note that if no output pixel mask or pixel replacement are specified then the bleed trails will have no effect. Therefore, the identification of such pixels is not done by the task even if the other parameters are set to identify saturated pixels. This operation does not apply to data identified as zero, dark, or flat. .sh Output Pixel Masks An output pixel mask is created when a name is specified with the "\fIbpmasks\fR" parameter and the mask does not exist. If the processing does not involved any modification to the input data then only the mask will be produced. The mask is a combination of the input mask specified by the "\fIfixfile\fR" parameter and pixels identified as saturated and bleed trails. Note that the "\fIfixfile\fR" parameter is used even if "\fIfixpix\fR" is not set. An input bad pixel mask is not required and if none is specified then the output will be just the pixels identified as bleed trails or saturated. If the saturated pixels and bleed trails are not identified and no input mask is specified then the output will simply be an empty mask. The specified output mask is currently used as a directory name. It is created if it is not found. The individual bad pixel masks, in pixel list format, are created in this directory. In a future version the multiple pixel masks will be stored as extensions in the multiextension file specified by the output mask name. .sh fixpix: Replacing Bad Pixels by Interpolation Regions of bad lines and columns may be replaced by linear interpolation from neighboring lines and columns when the parameter \fIfixpix\fR is set. This algorithm is the same as used in the task \fBfixpix\fR. The bad pixels may be specified by a pixel mask, an image, or a text file. For a mask or image, values of zero indicate good pixels and other values indicate bad pixels to be replaced. A text file consists of lines with four fields, the starting and ending columns and the starting and ending lines. Any number of regions may be specified. Comment lines beginning with the character '#' may be included. The description applies directly to the input image (before trimming) so different files are needed for previously trimmed or subsection readouts. The data in this file is internally turned into the same description as a bad pixel mask with values of two for regions which are narrower or equal across the columns and a value of three for regions narrower across lines. The direction of interpolation is determined from the values in the mask, image, or the converted text file. A value of two interpolates across columns, a value of three interpolates across lines, and any other value interpolates across the narrowest dimension of bad pixels and using column interpolation if the two dimensions are equal. The bad pixel description may be specified explicitly or by reference to a keyword with the name. The special value "BPM" or "image" references the keyword BPM. .sh overscan: Removing Electronic Bias Using Overscan/Prescan Data If an overscan or prescan correction is specified (\fIoverscan\fR parameter) then the image section (\fIbiassec\fR parameter) defines the overscan region. There are two types of overscan (or prescan) determinations. One determines a independent overscan value for each line and is only available for a \fIreadaxis\fR of 1. The other averages the overscan along the readout direction to make an overscan vector, fits a smoothing function to the vector, and then evaluate and then evaluates the smooth function at each readout line or column. The line-by-line determination provides an mean, median, or mean with the minimum and maximum values excluded. The median is lowest value of the middle two when the number of overscan columns is even rather than the mean. The smoothed overscan vector determination uses the \fBicfit\fR options including interactive fitting. The fitting function is generally either a constant (polynomial of 1 term) or a high order function which fits the large scale shape of the overscan vector. Bad pixel rejection is also available to eliminate cosmic ray events. The function fitting may be done interactively using the standard \fBicfit\fR iteractive graphical curve fitting tool. Regardless of whether the fit is done interactively, the overscan vector and the fit may be recorded for later review in a metacode plot file named by the parameter \fIccdred.plotfile\fR. The mean value of the bias function is also recorded in the image header and log file. .sh trim: Trimming Unwanted Data When the parameter \fItrim\fR is set the input image will be trimmed to the image section given by the parameter \fItrimsec\fR. This trim should, of course, be the same as that used for the calibration images. .sh zerocor: Applying a Zero Bias Calibration After the readout bias is subtracted, as defined by the overscan or prescan region, there may still be a zero level bias. This level may be two dimensional or one dimensional (the same for every readout line). A zero level calibration is obtained by taking zero length exposures; generally many are taken and combined. To apply this zero level calibration the parameter \fIzerocor\fR is set. In addition if the zero level bias is only readout dependent then the parameter \fIreadcor\fR is set to reduce two dimensional zero level images to one dimensional images. The zero level images may be specified by the parameter \fIzero\fR or given in the input image list (provided the CCD image type is defined). When the zero level image is needed to correct an input image it is checked to see if it has been processed and, if not, it is processed automatically. Processing of zero level images consists of bad pixel replacement, overscan correction, trimming, and averaging to one dimension if the readout correction is specified. .sh darkcor: Applying a Dark Count Calibration Dark counts are subtracted by scaling a dark count calibration image to the same exposure time as the input image and subtracting. The exposure time used is the dark time which may be different than the actual integration or exposure time. A dark count calibration image is obtained by taking a very long exposure with the shutter closed; i.e. an exposure with no light reaching the detector. The dark count correction is selected with the parameter \fIdarkcor\fR and the dark count calibration image is specified either with the parameter \fIdark\fR or as one of the input images. The dark count image is automatically processed as needed. Processing of dark count images consists of bad pixel replacement, overscan and zero level correction, and trimming. .sh flatcor: Applying a Flat Field Calibration The relative detector pixel response is calibrated by dividing by a scaled flat field calibration image. A flat field image is obtained by exposure to a spatially uniform source of light such as an lamp or twilight sky. Flat field images may be corrected for the spectral signature in spectroscopic images (see \fBresponse\fR and \fBapnormalize\fR), or for illumination effects (see \fBmkillumflat\fR or \fBmkskyflat\fR). For more on flat fields and illumination corrections see \fBflatfields\fR. The flat field response is dependent on the wavelength of light so if different filters or spectroscopic wavelength coverage are used a flat field calibration for each one is required. The different flat fields are automatically selected by a subset parameter (see \fBsubsets\fR). Flat field calibration is selected with the parameter \fBflatcor\fR and the flat field images are specified with the parameter \fBflat\fR or as part of the input image list. The appropriate subset is automatically selected for each input image processed. The flat field image is automatically processed as needed. Processing consists of bad pixel replacement, overscan subtraction, zero level subtraction, dark count subtraction, and trimming. Also if a scan mode is used and the parameter \fIscancor\fR is specified then a scan mode correction is applied (see below). The processing also computes the mean of the flat field image which is used later to scale the flat field before division into the input image. For scan mode flat fields the ramp part is included in computing the mean which will affect the level of images processed with this flat field. Note that there is no check for division by zero in the interest of efficiency. If division by zero does occur a fatal error will occur. The flat field can be fixed by replacing small values using a task such as \fBimreplace\fR or during processing using the \fIminreplace\fR parameter. Note that the \fIminreplace\fR parameter only applies to flat fields processed by \fBccdproc\fR. .sh sflatcor: Applying a Sky Flat Field Calibration A sky flat field calibration is just a second flat field derived from data which has been flat fielded by the first flat field. Typically a sky flat field is created from sky data. This is either exposures of the twilight sky or combinations of dark sky observations where objects are eliminated by stacking disregistered exposures. The operation is similar to the primary flat field in that a scaling is determined from the CCDMEAN information in the image or by computing a mean value. The calibration data is scaled and divided into the input data. .sh merge: Merging Amplifiers from the Same CCD When an input file consists of multiple amplifiers from the same CCD they may be merged together into a single image or extension. If the input file has only one CCD then the output is a simple single image otherwise it is a multiextension file with fewer extensions. The image header of the merged output is from the first amplifier encountered for each CCD. For multiextension output the merged extension name will be the extension name of the first amplifier. If an output mask is specified then the input masks will also be merged. In cases where the masks for the input data are already in merged form, where the masks for all the extensions to be merged are the same mask, the task will not create a new mask. .ih EXAMPLES The user's \fBguide\fR presents a tutorial in the use of this task. 1. In general all that needs to be done is to set the task parameters and enter cl> ccdproc *.imh & This will run in the background and process all images which have not been processed previously. .ih TIME REQUIREMENTS .nf o SUN-3, 15 MHz 68020 with 68881 floating point hardware (no FPA) o 8 Mb RAM, 2 Fuji Eagle disks. o Input images = 544 x 512 short o Output image = 500 x 500 real o Operations are overscan subtraction (O), trimming to 500x500 (T), zero level subtraction (Z), dark count scaling and subtraction (D), and flat field scaling and subtraction (F). o UNIX statistics (user, system, and clock time, and misc. memory and i/o statistics): [OTF] One calibration image and 9 object images: No caching: 110.6u 25.5s 3:18 68% 28+ 40K 3093+1645io 9pf+0w Caching: 111.2u 23.0s 2:59 74% 28+105K 2043+1618io 9pf+0w [OTZF] Two calibration images and 9 object images: No caching: 119.2u 29.0s 3:45 65% 28+ 50K 4310+1660io 9pf+0w Caching: 119.3u 23.0s 3:07 75% 28+124K 2179+1601io 9pf+0w [OTZDF] Three calibration images and 9 object images: No caching: 149.4u 31.6s 4:41 64% 28+ 59K 5501+1680io 19pf+0w Caching: 151.5u 29.0s 4:14 70% 27+227K 2346+1637io 148pf+0w [OTZF] 2 calibration images and 20 images processed: No caching: 272.7u 63.8u 8:47 63% 28+ 50K 9598+3713io 12pf+0w Caching: 271.2u 50.9s 7:00 76% 28+173K 4487+3613io 51pf+0w .fi .ih REVISIONS .ls CCDPROC: MSCRED - V4.5: March 19, 2001 This help page describes the options for the above version of MSCRED. .le .ih SEE ALSO .nf mscguide, xtalkcor .fi .endhelp mscred-5.05-2018.07.09/doc/ffpupilcor.hlp000066400000000000000000000057741332166314300174260ustar00rootroot00000000000000.help ffpupilcor Apr98 mscred .ih NAME ffpupilcor -- correct a broad band flat field for the pupil ghost .ih SYNOPSIS The pupil ghost image in a broad band flat field mosaic exposure is removed using a narrow band flat field as a calibration exposure. .ih USAGE ffpupilcor input output template .ih PARAMETERS .ls input Input broad band flat field mosaic exposure to be corrected. .le .ls output Output corrected flat field mosaic exposure. .le .ls template Template narrow band flat field calibration mosaic exposure. .le .ls extname = "[2367]" Selection pattern for the extensions to correct. All other extensions will be left unchanged in the output. .le .ls statsec = "mscdb$noao/mosaic1/ffpupilcor.dat" File of image sections to use for determining the normalizations outside the pupil ghost image. There must be one section for each extension in the exposure in the order of the extensions in the file. .le .ls blkavg = 8 Block averaging factor for doing the display and interative removal. This can be used to make the interative display and removal faster and also to enhance the visibility of the pupil ghost image. .le .ls radius = INDEF Radius of circular region to be corrected specified in pixels. If INDEF then the entire image is corrected. .le .ls xcenter = 0., ycenter =0. Center of correction circle relative to the tangent point of the coordinate system. The tangent point should be close to the optical axis of the system. This is only used if limiting the correction to a circular regions defined by the \fIradius\fR parameter. .le .ls mscexam = no Run \fBmscexamine\fR during each iteration of the interactive correction. One must type 'q' to exit the examination and go on to the next step. .le .ls scale = 1. This is a query parameter that will be prompted for by the program. .le .ih DESCRIPTION \fBFfpupilcor\fR is an interactive iterative task to remove a pupil ghost image from a broad band flat field using a narrow band flat field as a template for the ghost image. Regions, given by the \fIstatsec\fR parameter, are used to measure the background outside the pupil image in the template exposure for each image extension to be corrected. The extension is normalized by the background and then one is subtracted to leave an image of the pupil ghost from the template. This residual image is scaled by a user supplied scale factor. One is then added and the result divided into the target flat field exposure. The original flat field exposure and the corrected exposure are displayed. The user may then interact with the display using \fBmscexamine\fR and try a new scale factor. When the scale factor which best removes the pupil image is found exit by specifying zero (0) for the scale factor. The final correction is then applied to create the output corrected flat field exposure. If a scale of -1 is given then the task does not create a final output but just cleans up temporary files. .ih EXAMPLES .ih REVISIONS .ls FFPUPILCOR - MSCRED V1.2 First release. .le .ih BUGS AND LIMITATIONS .ih SEE ALSO mscexamine .endhelp mscred-5.05-2018.07.09/doc/installation.hlp000066400000000000000000000154301332166314300177440ustar00rootroot00000000000000.help installation Dec10 mscred .ce \fBMSCRED: CCD MOSAIC REDUCTION PACKAGE\fR .ce Release Notes and Installation Instructions .sh SUMMARY The MSCRED external package is used to reduce CCD mosaic data in which the data is in the mosaic MEF data format. .sh RELEASE INFORMATION The following summary only highlights the major changes. There will also be minor changes and bug fixes. .ls V5.05: August 9, 2012 Fixed a problem in mscfinder.msctpeak which complained about not being able to open a temporary file. .le .ls V5.04: August 17, 2011 Relinked against IRAF 2.15.1a to pick up core library changes. .le .ls V5.04: February 18, 2011 Fixed a bug with a missing argument to a procedure which caused a crash in combine with the macintel architecture. .le .ls V5.03: February 3, 2011 Fixed 64-bit bug in xtalkcor. .le .ls V5.02: January 20, 2011 Fixed bug in ccdproc. .le .ls V5.01: January 10, 2011 Fixed bug in mscdisplay. .le .ls V5.0: December 16, 2010 .le .sh INSTALLATION INSTRUCTIONS Installation of this external package consists of obtaining the files, unpacking them, optionally compiling the executables if not included in the distribution, and defining the environment to load and run the package. Note that starting with IRAF V2.15 there are installation utilities which automate this process. So these installation instructions here are for primarily for earlier versions of IRAF or those wishing to use the older method. The package may be installed for a site or as a personal installation. If you need help with these installation instructions post a request at the iraf.net website. The first step is determining your host IRAF architecture. If you are not sure but have a running IRAF installation then, after starting the command language, type .nf cl> show arch .redhat .fi This is the value you need to know without the leading '.'; i.e. the IRAF architecture is "redhat" in the example. The distributions files may be found in various places. If you got this document from an ftp directory the files should also be in that directory with names of the form "mscred-.tar.gz. These are gzip compressed tar files. The files for each architecture include the binaries except for "src" which is only the source. Unlike earlier distributions (prior to Dec 2010) the tar files are created so that they are unpacked in the external package directory of your choosing and the "mscred" subdirectory will be created. .nf % cd # e.g. /iraf/extern or /extern % tar xzf % ls -d mscred mscred .fi If you want to have multiple binaries, such as for a server, the simplest thing is to untar each architecture version. This will redundantly install the same source files which is harmless. If you already have an older mscred directory you should first remove it. If you want to have multiple versions you can rename it as an older version, make a directory for the new version, for instance "mscredV5.0", and unpack in that directory. .nf % cd # e.g. /iraf/extern % mv mscred # if this is a directory % mkdir # e.g. mscredV5.0 % cd % tar xzf % cd .. % rm mscred # if this is a previous link % ln -s /mscred . .fi Instead of using a link, as shown above, you can also specify paths and directories as you wish in the $iraf/unix/hlib/extern.pkg file, your loginuser.cl file, or interactively as follows. To define the package you need to an IRAF logical path to the mscred directory and a "task" declaration. As noted above, this is often done in the $iraf/unix/hlib/extern.pkg file but it can also be done in your irafuser.csh file or even interactively. The statements you need are something like: .nf reset mscred = /local/mscred/ task mscred.pkg = mscred$mscred.cl .fi Be sure to end the directory path with '/'. For the help files you must include .nf mscred$lib/helpdb.mip .fi in the "helpdb" path. A template of this is found in the extern.pkg file or something like .nf printf ("reset helpdb=%s,mscred$lib/helpdb.mip\nkeep\n", envget("helpdb")) | cl flpr .fi in your login.cl or loginuser.cl file. Make sure there is "keep" statement at the end of the file. .sh MSCDB For NOAO Mosaic Imager data a separate instrument database distribution should also be installed. The distribution file is "mscdb-univeral.tar.gz. This is unpacked in some directory such as the directory containing the mscred package. Then in extern.pkg, loginuser.cl, or login.cl add .nf set mscdb = / # ending with '/' .fi This is usually done in the same way and place that you define the mscred package. .sh COMPILING If you will be compiling the package, as opposed to installing a binary distribution, then you need to define various environment variables. The following is for Unix/csh which is the main supported environment. .nf % setenv iraf /iraf/iraf/ # Path to IRAF root (example) % source $iraf/unix/hlib/irafuser.csh # Define rest of environment % setenv IRAFARCH redhat # IRAF architecture % setenv mscred / # Path to package .fi where you need to supply the appropriate path to the IRAF installation root in the first step and the IRAF architecture identifier for your machine in the last step. If you are updating to a newer version and you earlier built the libraries and executables it is necessary to delete these. Otherwise, depending on the dates of files in the new version and the locally built libraries, it may cause the new version to be ignored. To do this the package is configured "generic" which puts all the binary files in one binary directory, the files are deleted and then you continue in the same way as a completely new installation. .nf cl> mkpkg generic cl> delete bin./* # Substitute redhat, etc. .fi Configure the package for the particular architecture to be built. .nf cl> mkpkg # Substitute redhat, etc. .fi This will change the bin link from bin.generic to bin.. The binary directory will be created if not present. If an error occurs in setting the architecture then you may need to add an entry to the file "mkpkg". Just follow the examples in the file. To create the executables and move them to the binary directory .nf cl> mkpkg -p mscred # build executables cl> mkpkg generic # optionally restore generic setting .fi Check for errors. If the executables are not moved to the binary directory then the $mscred path package was not done correctly (such as not having a trailing '/'. The last step restores the package to a generic configuration. This is not necessary if you will only have one architecture for the package. This should complete the installation. You can now load the package and begin testing and use. .endhelp mscred-5.05-2018.07.09/doc/mkmsc.hlp000066400000000000000000000251651332166314300163630ustar00rootroot00000000000000.help mkmsc Dec01 mscred .ih NAME mkmsc -- make multiextension mosaic format .ih SYNOPSIS MKMSC creates a multiextension format, suitable for use with the MSCRED package, from images with multiple amplifier readouts recorded as sections of a single image. These "flat" formats occur for both mosaics of CCDs and multiamplifier readouts from a single CCD. Examples of this format are the NOAO QUAD format, the ESO FORS format, and the Keck mosaic format. The regions and keywords are defined in a simple description file. .ih USAGE mkmsc input output .ih PARAMETERS .ls input List of images to be converted. .le .ls output List of multiextension mosaic files to be created. If no list is specified the output names will be the same as the input names otherwise the output list much match the input list in number. If an output name is the same as the input name, the output multiextension file will replace the input image upon successful conversion. If the output file exists it is skipped with a warning. .le .ls description = "" Description file to use. See the DESCRIPTION section for the format. .le .ls verbose = yes Print processing information? .le .ih DESCRIPTION MKMSC creates a multiextension format, suitable for use with the MSCRED package, from images with multiple amplifier readouts recorded as sections of a single image. These "flat" formats occur for both mosaics of CCDs and multiamplifier readouts from a single CCD. Examples of this format are the NOAO QUAD format, the ESO FORS format, and the Keck mosaic format. The regions and keywords are defined in a simple description file. The first column is an extension keyword and the second is the keyword value or reference to the value of a keyword in the input images. The structure is shown below. .nf keyword(extname) [!keyword|value] .fi The "keyword" is either one of the standard keywords described later or any keyword to be added to the output extension. The keyword is case insensitive. The "extname" is the exentsion name to which it applies. The set of unique extension names defines the set of possible output extensions. The second column is either a reference to a keyword in the input images, beginning with '!' and followed by the keyword, or a value. If the value contains whitespace it must be quoted. The regions of the input image to be mapped to extensions are given by the image section keywords DATASEC, BIASSEC, and TRIMSEC. DATASEC is required otherwise no extension will be created. The sections refer to regions of the input image. In the output extension the data section will be in the first columns and the bias section will follow regardless of where the bias section is in the input. The trim section is used for display and processing to select the region of the data section that is to be used. The keywords CCDSEC and DETSEC are sections which must match the data section in unbinned pixel size. These keywords are always in unbinned pixels in MSCRED. The CCD section is used to match calibration pixels and the detector section is used to define how the regions will be displayed and how multiple amplifiers are related. For multiple amplifiers from a single CCD the detector section is optional. When there are multiple amplifiers from the same CCD the keyword CCDNAME should be defined with the same value. Merging of multiple amplifiers into a single CCD image in MSCRED occurs when extensions have the same CCDNAME. The keyword AMPNAME may also be defined to identify the amplifier. In a mosaic the amplifier name can be the same for the same amplifier in each CCD. MSCRED uses an amplifier identifier keyword to match extensions. This keyword must be unique for each extension. If no amplifier ID is specified the extension name will be used. However, since the extension name can be changed as needed it is a good idea to have a separate keyword. In MSCRED the default keyword when there is no instrument keyword translation is AMPID. Often times the keyword IMAGEID is used. All other keywords are simply added to the output extension. Note that each extension will start with a copy of the keywords in the input image, so added keywords should be used either for keywords that differ between each extension or to change a keyword from the value in the input image. .ih EXAMPLES CTIO ARCON QUAD FORMAT The follwing description file may be used with the CTIO quad format, both with 2 or 4 amplifiers. .nf ms> page mscred$lib/mkmsc/quad.dat imageid(im1) 1 ampid(im1) 11 datasec(im1) !DSEC11 biassec(im1) !BSEC11 trimsec(im1) !TSEC11 ccdsec(im1) !CSEC11 detsec(im1) !CSEC11 ccdname(im1) !DETECTOR ampname(im1) Amp11 rdnoise(im1) !GTRON11 gain(im1) !GTGAIN11 imageid(im2) 2 ampid(im2) 12 datasec(im2) !DSEC12 biassec(im2) !BSEC12 trimsec(im2) !TSEC12 ccdsec(im2) !CSEC12 detsec(im2) !CSEC12 ccdname(im2) !DETECTOR ampname(im2) Amp12 rdnoise(im2) !GTRON12 gain(im2) !GTGAIN12 imageid(im3) 3 ampid(im3) 21 datasec(im3) !DSEC21 biassec(im3) !BSEC21 trimsec(im3) !TSEC21 ccdsec(im3) !CSEC21 detsec(im3) !CSEC21 ccdname(im3) !DETECTOR ampname(im3) Amp21 rdnoise(im3) !GTRON21 gain(im3) !GTGAIN21 imageid(im4) 4 ampid(im4) 22 datasec(im4) !DSEC22 biassec(im4) !BSEC22 trimsec(im4) !TSEC22 ccdsec(im4) !CSEC22 detsec(im4) !CSEC22 ccdname(im4) !DETECTOR ampname(im4) Amp22 rdnoise(im4) !GTRON22 gain(im4) !GTGAIN22 ms> mkmsc quad0008 mef0008 desc=mscred$lib/mkmsc/quad.dat verbose+ Reading description file mscred$lib/mkmsc/quad.dat Create mef0008[im1][833,769]: OIIICont 14s quad0008[1:779,1,769] -> mef0008[im1][1:779,1:769] quad0008[790:843,1,769] -> mef0008[im1][780:833,1:769] Create mef0008[im2][833,769]: OIIICont 14s quad0008[908:1686,1,769] -> mef0008[im2][1:779,1:769] quad0008[844:897,1,769] -> mef0008[im2][780:833,1:769] Create mef0008[im3][833,769]: OIIICont 14s quad0008[1:779,770,1538] -> mef0008[im3][1:779,1:769] quad0008[790:843,770,1538] -> mef0008[im3][780:833,1:769] Create mef0008[im4][833,769]: OIIICont 14s quad0008[908:1686,770,1538] -> mef0008[im4][1:779,1:769] quad0008[844:897,770,1538] -> mef0008[im4][780:833,1:769] .fi Note that this description file works with dual readout because only the keywords DSEC which are present will result in extensions being created. ESO VLT FORS1 FORMAT The ESO VLT FORS1 data uses a format which is very similar to that of the CTIO format. The following description file may be used based on an example derived from the archive file FORS.2001-04-19T04:18:55.409.fits. .nf ms> type mscred$lib/mkmsc/fors.dat imageid(im1) 1 ampid(im1) A datasec(im1) !DSECA biassec(im1) !BSECA trimsec(im1) !TSECA ccdsec(im1) !CSECA detsec(im1) !CSECA ccdname(im1) FORS ampname(im1) AmpA imageid(im2) 2 ampid(im2) B datasec(im2) !DSECB biassec(im2) !BSECB trimsec(im2) !TSECB ccdsec(im2) !CSECB detsec(im2) !CSECB ccdname(im2) FORS ampname(im2) AmpB imageid(im3) 3 ampid(im3) C datasec(im3) !DSECC biassec(im3) !BSECC trimsec(im3) !TSECC ccdsec(im3) !CSECC detsec(im3) !CSECC ccdname(im3) FORS ampname(im3) AmpC imageid(im4) 4 ampid(im4) D datasec(im4) !DSECD biassec(im4) !BSECD trimsec(im4) !TSECD ccdsec(im4) !CSECD detsec(im4) !CSECD ccdname(im4) FORS ampname(im4) AmpD ms> mkmsc f109.7 "" desc=mscred$lib/mkmsc/fors.dat Reading description file mscred$lib/mkmsc/fors.dat Create f109.7[im1][1040,1024]: PG1323-086 f109.7[17:1040,1,1024] -> f109.7[im1][1:1024,1:1024] f109.7[1:16,1,1024] -> f109.7[im1][1025:1040,1:1024] Create f109.7[im2][1040,1024]: PG1323-086 f109.7[1041:2064,1,1024] -> f109.7[im2][1:1024,1:1024] f109.7[2065:2080,1,1024] -> f109.7[im2][1025:1040,1:1024] Create f109.7[im3][1040,1024]: PG1323-086 f109.7[17:1040,1025,2048] -> f109.7[im3][1:1024,1:1024] f109.7[1:16,1025,2048] -> f109.7[im3][1025:1040,1:1024] Create f109.7[im4][1040,1024]: PG1323-086 f109.7[1041:2064,1025,2048] -> f109.7[im4][1:1024,1:1024] f109.7[2065:2080,1025,2048] -> f109.7[im4][1025:1040,1:1024] .fi This example shows in-place conversion. KECK MOSAIC DEVELOPMENT FORMAT The following was derived from a sample development flat format for a two CCD mosaic. It differs from the above two examples in that the overscan and prescan regions are not contiguous with the data regions. All the prescan regions are placed before the data regions and all the overscan regions (used for the bias regions) are placed after all the data regions. .nf ms> type mscred$lib/mkmsc/keck.dat ampid(im1) 1 datasec(im1) [205:1228,1:4096] biassec(im1) [4301:4380,1:4096] ccdsec(im1) [1:1024,1:4096] detsec(im1) [1:1024,1:4096] ccdname(im1) "CCD 1" ampname(im1) "AMP 1" ampid(im2) 2 datasec(im2) [1229:2252,1:4096] biassec(im2) [4381:4460,1:4096] ccdsec(im2) [1025:2048,1:4096] detsec(im2) [1025:2048,1:4096] ccdname(im2) "CCD 1" ampname(im2) "AMP 2" ampid(im3) 3 datasec(im3) [2253:3276,1:4096] biassec(im3) [4461:4540,1:4096] ccdsec(im3) [1:1024,1:4096] detsec(im3) [2049:3072,1:4096] ccdname(im3) "CCD 2" ampname(im3) "AMP 1" ampid(im4) 4 datasec(im4) [3277:4300,1:4096] biassec(im4) [4541:4620,1:4096] ccdsec(im4) [1024:2048,1:4096] detsec(im4) [3073:4096,1:4096] ccdname(im4) "CCD 2" ampname(im4) "AMP 2" ms> mkmsc obj0574 "" desc=mscred$lib/mkmsc/keck.dat verbose+ Reading description file mscred$lib/mkmsc/keck.dat Create obj0574[im1][1104,4096]: obj0574[205:1228,1,4096] -> obj0574[im1][1:1024,1:4096] obj0574[4301:4380,1,4096] -> obj0574[im1][1025:1104,1:4096] Create obj0574[im2][1104,4096]: obj0574[1229:2252,1,4096] -> obj0574[im2][1:1024,1:4096] obj0574[4381:4460,1,4096] -> obj0574[im2][1025:1104,1:4096] Create obj0574[im3][1104,4096]: obj0574[2253:3276,1,4096] -> obj0574[im3][1:1024,1:4096] obj0574[4461:4540,1,4096] -> obj0574[im3][1025:1104,1:4096] Create obj0574[im4][1104,4096]: obj0574[3277:4300,1,4096] -> obj0574[im4][1:1024,1:4096] obj0574[4541:4620,1,4096] -> obj0574[im4][1025:1104,1:4096] .fi .ih REVISIONS .ls MKMSC - V4.6: December 7, 2001 This task is new in this release. .le .ih SEE ALSO .endhelp mscred-5.05-2018.07.09/doc/mscarith.hlp000066400000000000000000000012601332166314300170510ustar00rootroot00000000000000.help mscarith Oct97 mscred .ih NAME mscarith -- image arithmetic on Mosaic files .ih SYNOPSIS This tasks performs image arithmetic, using \fBimarith\fR, by expanding each mosaic file into image extensions and creating an output mosaic file from all the results of operating on the extensions. .ih USAGE mscarith operand1 op operand2 result .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih RESTRICTIONS Image sections are not allowed in the mosaic filenames. When two operand images are used the image extensions are not matched by extension name but only by order in the file. .ih REVISIONS .ls MSCARITH - V2.11 external package First release. .le .ih SEE ALSO msccmd, imarith .endhelp mscred-5.05-2018.07.09/doc/mscblkavg.hlp000066400000000000000000000016131332166314300172120ustar00rootroot00000000000000.help mscblkavg Nov98 mscred .ih NAME mscblkavg -- block average mosaic exposures with header keyword updating .ih SYNOPSIS This task block averages mosaic exposures by specified block factors. It updates the RDNOISE, GAIN, CCDSUM, DATASEC, BIASSEC, TRIMSEC, and CCDSEC parameters. The output pixel type is the same as the input pixel type. For this reason block averaging of raw unsigned short data may lead to undersampling the noise. The output name maybe the same as the input name to replace the input by the block average output. .ih USAGE mscblkavg input output nc nl .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES 1. Block average a set exposures. .nf cl> mscblkavg obj*fits bav//obj*fits 2 2 .fi 2. Block average in place a set of exposures. .nf cl> mscblkavg obj*fits obj*fits 2 2 .fi .ih REVISIONS .ls MSCBLKAVG First release in MSCRED V2.0. .le .ih SEE ALSO msccmd, blkavg .endhelp mscred-5.05-2018.07.09/doc/msccmatch.hlp000066400000000000000000000153321332166314300172060ustar00rootroot00000000000000.help msccmatch Dec97 mscred .ih NAME msccmatch -- match coordinates and adjust WCS .ih SYNOPSIS A list of reference celestial coordinates, either from an astrometry catalog or measured from a reference image, for stars in the field is matched against objects in the mosaic data. A linear relation between the observed positions and the reference coordinates is fit. The relation may include a zero point shift, scale change, and axis rotation for both coordinate axes. The removes pointing errors, rotation errors, and atmospheric refraction effects. The fit is used to update the image world coordinate system to register the WCS to the input coordinate system. .ih USAGE msccmatch input coords .ih PARAMETERS .ls input List of input mosaic exposures to be calibrated. .le .ls coords Coordinate filename or command to execute to produce a coordinate file. The file contains the right ascension and declination in the first two columns. Any other columns are ignored. When an explicit file is specified it used for all input exposures. A command to execute is specified by beginning the parameter string with "!". The special arguments $I will be replaced by the input mosaic exposure and $C by the filename for the coordinate file to be used. A typical command is .nf !mscgetcatalog $I $C .fi Note that any hidden parameters either need to be set first or be given explicitly as part of the command. .le .ls outcoords = "" Optional list of updated coordinate files to output. The list is matched with the input list of mosaic exposures. If the list is shorter than the input list then no output files are created for the remaining exposures. The output coordinate file consists of those lines in the input coordinates which were used; i.e. were found to be in the field, were not rejected due to bad pixels, and which where centered without error. .le .ls usebpm = yes Use bad pixel masks given by the BPM header keywords to reject sources that contain bad pixels? .le The following parameters are for a coarse correlation search with large offsets but small rotation. .ls nsearch = 50 Maximum number of positions to use in search. If this is zero then the coarse search is skipped and the coordinates are assumed to be close enough to centroid directly on the objects. If the coarse search is selected then this number should not be too large, otherwise the execution time will become long. .le .ls search = 0. Translation search radius in arcsec. If this is zero then the coarse serach is skipped and the coordinates are assumed to be close enough to centroid directly. This defines how far from the initial coordinates to search using the \fInsearch\fR objects. It should be just large enough to include the expected error in the initial coordinates. .le .ls rsearch = 0. Rotation search radius in degrees. This defines a range of rotations about the current tangent point that might be needed to find the correlation match. The correlation algorithm only works with small rotations or order a degree. .le The follwoing parameters are for the fine centroiding and coordinate solution based on the centroiding. .ls nfit = 4 The minimum number of sources which must be found and centroided for an acceptable coordinate fit. If the value is negative then this is the maximum number of objects which failed to be found for an acceptable solution. .le .ls rms = 2. The maximum RMS in arcsec for an acceptable solution. .le .ls maxshift = 5 Maximum centering shift in arcsec when centroiding. Sources that produce centroids (from the \fBcenter\fR task) that differ from the initial position by more than this amount are considered to have failed to be centroided. .le .ls fitgeometry = "general" (shift|xyscale|rotate|rscale|rxyscale|general) Fitting geometry for the coordinate adjustment. This should normally be "general" to all allow for all effects of atmospheric refraction. The other options are only used when looking for specific effects. .le .ls reject = 3. Iterative rejection sigma for fitting the position residuals as a function of arcsec from the field tangent point. .le .ls update = yes Update the coordinate system in the mosaic exposures? If the value is no then the input data is not modified. This option might be used just to check the coordinate system. If the the value is yes and the fit satisfies the parameters defining an acceptable solution the coordinate system will be updated if \fIinteractive\fR=no, otherwise there is a query whether to accept the solution and update the input data. .le .ls interactive = yes Is this task to be run interactively? If yes then the fitting can be examined and adjusted interactively if the \fIfit\fR parameter is yes and the final solution will be printed followed by a query to accept the solution provided the \fIupdate\fR parameter is yes. .le .ls fit = yes Do the coordinate fitting interactively? This required the \fIinteractive\fR parameter to be yes. If the fitting is done interactively the \fBgeomap\fR task used to do the fitting will be executed interactively. The graphical fitting is exited using the 'q' key. See the help for \fBgeomap\fR for more on the interactive fitting. .le .ls verbose = yes Verbose output? This determines whether various terminal output is produced. .le .ls listcoords = yes List centroiding results for all sources in verbose mode? .le .ls graphics = "stdgraph" Graphics device for the interactive fitting. .le .ls cursor = "" Graphics cursor input for the interactive fitting. The default null string value selects the graphics window cursor. .le .ls accept = yes This is a query parameter when \fIupdate\fR and \fIinteractive\fR are yes. You are queried after printing the statistics of the coordinate fit whether to accept the solution and update the coordinate system of the mosaic exposure. .le .ih DESCRIPTION A list of reference celestial coordinates, either from an astrometry catalog or measured from a reference image, for stars in the field is matched against objects in the mosaic data. A linear relation between the observed positions and the reference coordinates is fit. The relation may include a zero point shift, scale change, and axis rotation for both coordinate axes. The removes pointing errors, rotation errors, and atmospheric refraction effects. The fit is used to update the image world coordinate system to register the WCS to the input coordinate system. A full description of this task remains to be written. .ih EXAMPLES .ih REVISIONS .ls MSCCMATCH - V4.0: August 22, 2000 This version includes the ability to get the list of catalogs directly from a web-based catalog server and to find large offsets (provided any rotation is small) using a correlation algorithm. .le .ls MSCCMATCH - V2.11 external package First release. .le .ih SEE ALSO msczero, mscgetcatalog, geomap, center .endhelp mscred-5.05-2018.07.09/doc/msccmd.hlp000066400000000000000000000031501332166314300165050ustar00rootroot00000000000000.help msccmd Oct97 mscred .ih NAME msccmd -- execute general command with image extension expansion .ih SYNOPSIS This tasks executes a command where any input and output image list arguments specified by $input, $in2, and $output are replaced by an expanded list of image extensions. If there are no command line arguments the task runs as an interpreter with prompts until the command 'q' or 'quit' is entered. .ih USAGE msccmd [command input output] .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES 1. Do image statistics. .nf cl> msccmd "imstat $input" obj*fits .fi Since this is a common operation see \fBmscstat\fR instead. 2. Do image arithmetic. .nf cl> msccmd "imarith $input + $in2 $output" List of input files: obj001 Second list of input files: obj002 List of output files: sum .fi Since this is a common operation see \fBmscarith\fR instead. 3. Do HSELECT on the command line with no prompts. .nf cl> msccmd "hselect $input $I,filter yes" obj001,obj002 [output] .fi 4. Use in interpretive mode. .nf cl> msccmd msccmd> Command: imhead $input l- [output] msccmd> Command: hselect $input $I,filter msccmd> Input files: obj001,obj002 [output] msccmd> Command: hedit $input filter B verify- msccmd> Input files (obj001,obj002): msccmd> Command: print "This command has not input or output files." This command has not input or output files. msccmd> Command: q cl> .fi .ih RESTRICTION Image sections are not allowed in the mosaic filenames. .ih REVISIONS .ls MSCSTAT - V2.11 external package First release. .le .ih SEE ALSO mscarith, mscstat .endhelp mscred-5.05-2018.07.09/doc/mscctran.hlp000066400000000000000000000011351332166314300170520ustar00rootroot00000000000000.help mscctran Aug97 mscred .ih NAME mscctran -- Celestial coordinate transformaion using plate solution .ih SYNOPSIS Transform between pixel (logical) and celestial (world) coordinates based on an input image. The transformation may use just the linear coordinate transformation in the image header or a plate solution from a database file with the file and entry specified in the image header keyword WCSSOL. .ih USAGE mscctran input output image forward .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCCTRAN - V2.11 external package First release. .le .ih SEE ALSO wcsctran .endhelp mscred-5.05-2018.07.09/doc/mscdisplay.hlp000066400000000000000000000006771332166314300174220ustar00rootroot00000000000000.help mscdisplay Aug97 mscred .ih NAME mscdisplay -- display Mosaic exposures as a single frames .ih SYNOPSIS Display multiextension Mosaic exposures in single display frames. The extensions are filled into a region of the display as defined by the DETSEC keyword. .ih USAGE mscdisplay image frame .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCDISPLAY - V2.11 external package First release. .le .ih SEE ALSO display .endhelp mscred-5.05-2018.07.09/doc/mscdither.hlp000066400000000000000000000011401332166314300172160ustar00rootroot00000000000000.help mscdither Aug97 mscred .ih NAME mscdither -- pipeline to make final image from dithered Mosaic exposures .ih SYNOPSIS The pipeline is a convenience script combining \fBmscregister\fR, \fBmscimage\fR, and \fBmscstack\fR. The stacking uses a simple median combining with no rejections other than the median and a threshold to exclude the gaps. More complex combining should use the individual tasks. .ih USAGE mscdither input output .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCDITHER - V2.11 external package First release. .le .ih SEE ALSO mscregister mscimage mscstack .endhelp mscred-5.05-2018.07.09/doc/mscexamine.hlp000066400000000000000000000010431332166314300173670ustar00rootroot00000000000000.help mscexamine Aug97 mscred .ih NAME mscexamine -- examine Mosaic exposures displayed as single frames .ih SYNOPSIS A multiextension Mosaic image is displayed, if needed, and then the image cursor is used to select operations and a data regions. The operations are performed on the full Mosaic image. Operations include data examination and PSF fitting. .ih USAGE mscexamine input frame .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCEXAMINE - V2.11 external package First release. .le .ih SEE ALSO imexamine msczero .endhelp mscred-5.05-2018.07.09/doc/mscfinder.hlp000066400000000000000000000010241332166314300172070ustar00rootroot00000000000000.help mscfinder Aug97 mscred .ih NAME mscfinder -- package to do astrometry on Mosaic data .ih SYNOPSIS This package is currently intended for use only by instrument support personnel to determine plate solutions for Mosaic data. It is based on an interim tool derived from the \fBfinder\fR package that takes input from a simple coordinate file and Mosaic images. .ih USAGE mscfinder .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCFINDER - V2.11 external package First release. .le .ih SEE ALSO finder .endhelp mscred-5.05-2018.07.09/doc/mscfindgain.hlp000066400000000000000000000162401332166314300175250ustar00rootroot00000000000000.help mscfindgain Aug00 mscred .ih NAME mscfindgain -- calculate the gain and readout noise of a mosaic of CCD .ih SYNOPSIS MSCFINDGAIN uses Janesick's method for determining the gain and read noise in a CCD from a pair of dome flat exposures and a pair of zero frame exposures (zero length dark exposures). .ih USAGE mscfindgain flat1 flat2 zero1 zero2 .ih PARAMETERS .ls flat1, flat2 First and second mosaic dome flats. .le .ls zero1, zero2 First and second zero frames (zero length dark exposures). .le .ls extname = "" List of extension names for which the gain is to be determined. If a blank list is specified then all extensions are analyzed. .le .ls mask = "BPM" Bad pixel mask to use in excluding bad pixels. When there are multiple extensions the mask should be specified through the BPM header keyword. .le .ls section = "" The selected image section for the statistics. This should be chosen to exclude bad columns or rows, cosmic rays and other blemishes, and the overscan region. The flat field illumination should be constant over this section. The sections are applied to all the selected extensions. To use different sections the task must be run using the \fIextname\fR parameter to select specific extensions for the desired statistics section. Note that bad pixel masks is a better method of selecting data. .le .ls center = "mean" The statistical measure of central tendency that is used to estimate the data level of each image. This can have the values: \fBmean\fR, \fBmidpt\fR, or \fBmode\fR. These are calculated using the same algorithm as the IMSTATISTICS task. .le .ls nclip = 3 Number of sigma clipping iterations. If the value is zero then no clipping is performed. .le .ls lclip = 4, uclip = 4 Lower and upper sigma clipping factors used with the mean value and standard deviation to eliminate cosmic rays and unmasked bad pixels. Since \fBmscfindgain\fR is sensitive to the statistics of the data the clipping factors should be symmetric (the same both above and below the mean) and should not bias the standard deviation. Thus the values should not be made smaller than around 4 sigma otherwise the gain and readnoise estimates will be affected. .le .ls binwidth = 0.1 The bin width of the histogram (in sigma) that is used to estimate the \fBmidpt\fR or \fBmode\fR of the data section in each image. The default case of center=\fBmean\fR does not use this parameter. .le .ls verbose = yes Label the gain and readnoise on output, rather than print them two per line? .le .ih DESCRIPTION MSCFINDGAIN uses Janesick's method for determining the gain and read noise in a CCD from a pair of dome flat exposures and a pair of zero frame exposures (zero length dark exposures). This task operates on mosaic exposures in multiextension format. The \fIextname\fR parameter may be used to select all extensions, a single extension, or some subset of extensions. The task requires that the flats and zeros be unprocessed and uncoadded so that the noise characteristics of the data are preserved. Note, however, that the frames may be bias subtracted if the average of many zero frames is used, and that the overscan region may be removed prior to using this task. Bad pixels should be eliminated to avoid affecting the statistics. This can be done with bad pixels masks and sigma clipping. Alternatively an image section (which is the same for all extensions) may be chosen. The sigma clipping should not significantly affect the assumed gaussian distribution while eliminating outlyers due to cosmic rays and unmasked bad pixels. This means that clipping factors should be symmetric and should have values four or more sigma from the mean. .ih ALGORITHM The formulae used by the task are: .nf flatdif = flat1 - flat2 zerodif = zero1 - zero2 gain = ((mean(flat1) + mean(flat2)) - (mean(zero1) + mean(zero2))) / ((sigma(flatdif))**2 - (sigma(zerodif))**2 ) readnoise = gain * sigma(zerodif) / sqrt(2) .fi where the gain is given in electrons per ADU and the readnoise in electrons. Pairs of each type of comparison frame are used to reduce the effects of gain variations from pixel to pixel. The derivation follows from the definition of the gain (N(e) = gain * N(ADU)) and from simple error propagation. Also note that the measured variance (sigma**2) is related to the exposure level and read-noise variance (sigma(readout)**2) as follows: .nf variance(e) = N(e) + variance(readout) .fi Where N(e) is the number of electrons (above the zero level) in a given duration exposure. In our implementation, the \fBmean\fR used in the formula for the gain may actually be any of the \fBmean\fR, \fBmidpt\fR (an estimate of the median), or \fBmode\fR as determined by the \fBcenter\fR parameter. For the \fBmidpt\fR or \fBmode\fR choices only, the value of the \fBbinwidth\fR parameter determines the bin width (in sigma) of the histogram that is used in the calculation. \fBMscfindgain\fR uses the \fBimstatistics\fR task to compute the statistics. .ih EXAMPLES To calculate the gain and readnoise within a 100x100 section: .nf ms> mscfindgain flat1 flat2 zero1 zero2 section="[271:370,361:460]" .fi To calculate the gain and readnoise using the mode to estimate the data level for each image section: .nf ms> mscfindgain.section="[271:370,361:460]" ms> mscfindgain flat1 flat2 zero1 zero2 center=mode .fi The effects of cosmic rays can be seen in the following example using artificial noise created with the \fBartdata.mknoise\fR package. The images have a gain of 5 and a readnoise of 10 with 100 cosmic rays added over the 512x512 images. The zero level images have means of zero and the flat field images have means of 1000. The first execution uses the default clipping and the second turns off the clipping. .nf ms> mscfindgain flat1 flat2 zero1 zero2 MSCFINDGAIN: mask = BPM, center = mean, binwidth = 0.1 nclip = 3, lclip = 4., uclip = 4. Flats = flat1[im1] & flat2[im1] Zeros = zero1[im1] & zero2[im1] Gain = 5.01 electrons per ADU Read noise = 10.00 electrons Flats = flat1[im2] & flat2[im2] Zeros = zero1[im2] & zero2[im2] Gain = 5.00 electrons per ADU Read noise = 10.01 electrons ms> mscfindgain flat1 flat2 zero1 zero2 nclip=0 MSCFINDGAIN: mask = BPM, center = mean, binwidth = 0.1 nclip = 0, lclip = 4., uclip = 4. Flats = flat1[im1] & flat2[im1] Zeros = zero1[im1] & zero2[im1] Gain = 2.86 electrons per ADU Read noise = 189.5 electrons Flats = flat1[im2] & flat2[im2] Zeros = zero1[im2] & zero2[im2] Gain = 1.95 electrons per ADU Read noise = 127.8 electrons .fi .ih BUGS The image headers are not checked to see if the frames have been processed. There is no provision for finding the "best" values and their errors from several flats and zeros. .ih REVISIONS .ls MSCFINDGAIN - V4.1: December 5, 2000 New parameters to allow specifying bad pixel masks and sigma clipping were added. The output format was also improved. .le .ls MSCFINDGAIN - V4.0: August 22, 2000 This task is new in the version. .le .ih SEE ALSO nproto.findgain, findthresh, imstatistics, imhistogram, implot .endhelp mscred-5.05-2018.07.09/doc/mscfocus.hlp000066400000000000000000000007731332166314300170710ustar00rootroot00000000000000.help mscfocus Aug97 mscred .ih NAME mscfocus -- measure focus from Mosaic focus exposures .ih SYNOPSIS This is a customized version of the \fBstarfocus\fR task which operates from NOAO Mosaic focus exposured displayed with \fBmscdisplay\fR. It uses keywords in the headers to determine focus values and sequence patterns. .ih USAGE mscfocus images .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCFOCUS - V2.11 external package First release. .le .ih SEE ALSO kpnofocus starfocus .endhelp mscred-5.05-2018.07.09/doc/mscgetcatalog.hlp000066400000000000000000000120131332166314300200520ustar00rootroot00000000000000.help mscgetcatalog Aug00 mscred .ih NAME mscgetcatalog -- Get coordinates from a Web server covering mosaic exposures .ih SYNOPSIS MSCGETCATALOG is a task for getting coordinates and magnitudes from Web-based catalog servers. The task returns a text file of coordinates and magnitudes for a field centered on the specified mosaic exposure(s). .ih USAGE mscgetcatalog input output .ih PARAMETERS .ls input List of mosaic exposures. .le .ls output Output text file containing catalog coordinates and magnitudes. .le .ls magmin = 0., magmax = 25. Range of magnitudes to select from the catalog. .le .ls catalog = "NOAO:USNO-A2" Catalog to be used. With IRAF V2.11 and earlier the choices are: .ls NOAO:USNO-A2 The USNO A2 catalog using a server from NOAO. .le .ls CADC:USNO-A2 The USNO A2 catalog using a server from the CADC. .le With IRAF V2.12 the catalogs supported by the \fBastcat\fR package may also be used. For a list of catalogs use the command: .nf cl> aclist * verbose- .fi .le .ls rmin = 21. Minimum radius in arc minutes from the center of the input exposures to include in the output file. The actual radius used is the maximum of this parameter and the maximum radius to the corners of all the input extensions. .le .ih DESCRIPTION \fBMscgetcatalog\fR is a task for getting coordinates and magnitudes from Web-based catalog servers. This requires that you can make http requests from the system where this task is executed. Proxy servers are not supported. Note that if the server does not respond this task may not return and would need to be interupted. \fBMscgetcatalog\fR returns a text file, specified by the \fIoutput\fR parameter, of coordinates and magnitudes for a field centered on the mosaic exposure(s), specified by the \fIinput\fR . This requires that the mosaic exposures have an approximate world coordinate system (WCS). The catalog of sources is generally used to calibrate the WCS provided there is sufficient overlap between the field and the approximate WCS. This file can be used with various \fBmscred\fR tasks such as \fBmsccmatch\fR, \fBmscimatch\fR, \fBmsczero\fR, and \fBmsctvmark\fR. Currently all coordinates, input and output, are J2000. The task \fBmsccmatch\fR may execute this task to generate the coordinates to use by specifying .nf !mscgetcatalog $I $C .fi for the \fIcoords\fR parameter. The "$I" field is replaced by the mosaic exposure being calibrated and "$C" is replaced by a temporary filename used by the task. The center of the circular region to be extracted from the catalog is determined by the midpoint of the coordinates of all the extension corners in the list of input mosaic exposures. The maximum radius from this point to all the corners determines a minimum radius for the region. The \fIrmin\fR parameter may be used to force a minimum radius though if the radius including all the corners is larger then that radius is used. The currently supported catalogs include approximate magnitudes. When magnitudes are available the \fImagmin\fR and \fImagmax\fR parameters may be used to restrict the output coordinates to a specified magnitude range. The selection of catalogs in IRAF V2.11 and earlier is limited to "NOAO:USNO-A2" and "CADC:USNO-A2". In V2.12 the catalogs supported by the new catalog access package \fBastcat\fR may also be used. A list of catalogs may be obtained using the command: .nf cl> aclist * verbose- .fi The catalog names must be specified exactly as shown in the list. .ih EXAMPLES 1. This example illustrates getting coordinates for the brightest stars in an NOAO mosaic exposure using the default USNO-A2 server at NOAO. This specifies the output as "STDOUT" to print to the terminally. More commonly this would be a filename and the magnitude limit would include fainter stars. .nf ms> mscgetcat obj110 STDOUT magmax=11 15:23:19.94 -0:08:41.8 10.60 12.20 15:23:41.25 -0:16:17.8 8.60 11.60 15:24:57.69 -0:06:16.8 10.90 12.10 15:25:34.79 -0:01:02.8 10.60 12.30 15:25:40.38 -0:01:11.5 10.60 11.50 15:25:54.55 -0:17:02.8 10.40 11.80 15:22:58.95 0:05:55.9 10.40 13.90 15:23:05.07 0:04:17.0 11.00 12.10 15:24:09.96 0:03:04.2 11.00 11.90 15:26:00.73 0:17:46.3 8.60 9.40 .fi 2. To use the Guide Star Catalog 2 (in IRAF V2.12): .nf ms> mscgetcat obj110 STDOUT catalog=gsc2@stsci magmax=11 15:23:19.94 -0:08:41.8 10.60 12.20 15:23:41.25 -0:16:17.8 8.60 11.60 15:24:57.69 -0:06:16.8 10.90 12.10 15:25:34.79 -0:01:02.8 10.60 12.30 15:25:40.38 -0:01:11.5 10.60 11.50 15:25:54.55 -0:17:02.8 10.40 11.80 15:22:58.95 0:05:55.9 10.40 13.90 15:23:05.07 0:04:17.0 11.00 12.10 15:24:09.96 0:03:04.2 11.00 11.90 15:26:00.73 0:17:46.3 8.60 9.40 .fi .ih REVISIONS .ls MSCGETCATALOG - V4.7: April, 2002 Modified to allow use of the ASTCAT package which provides access to a larger variety of catalogs. .le .ls MSCGETCATALOG - V4.0: August 22, 2000 This task is new in this release. .le .ih SEE ALSO msccmatch, mscimatch, msczero, msctvmark .endhelp mscred-5.05-2018.07.09/doc/mscguide.hlp000066400000000000000000002575421332166314300170570ustar00rootroot00000000000000.help mscguide Sep98 mscred .sp 3 .ce \fBGuide to the NOAO Mosaic Data Handling Software\fR .ce Francisco Valdes .ce September 1998 .ce MSCRED Version 2.0 .sh Sections .nf 1. Introduction 2. Multiextension FITS Files 3. Examining Mosaic Data 3.1 Displaying the Data 2.1.1 On-the-Fly (OTF) Calibration 2.1.2 Real-Time Display with the DCA 3.2 Examining the Data 3.3 Examining the Headers 3.4 Determining Best Focus 4. Data Reductions 4.1 Some Preliminaries 4.2 Basic CCD Calibration 4.2.1 Calibration Data to Obtain At the Telescope 4.2.2 Preparing Calibration Data 4.2.3 Pupil Image Removal from Flat Fields 4.2.3.1 Broadband Data 4.2.3.2 Narrowband Data 4.2.4 Object Exposure Reductions 4.2.5 Pupil Image Removal from Object Data 4.2.5.1 Broadband Data 4.2.5.2 Narrowband Data 4.2.6 Dark Sky or Twilight Sky Flat Fields 4.2.7 The Variable Pixel Scale and Zero Point Uniformity 4.3 Coordinate Calibration 4.3.1 Setting Coordinate Zero Points and Measuring Coordinates 4.3.2 Matching Coordinate Systems 4.4 Putting the Pieces Together 4.4.1 Removing Sky Gradients 4.4.2 Constructing Single Images 4.4.3 Matching Intensity Scales 4.4.4 Making the Final Stack Image .fi .sh 1. Introduction This document discusses handling and reducing CCD mosaic data, particularly data from the NOAO CCD Mosaic Imager (referred to here as the NOAO Mosaic), using IRAF and the \fBmscred\fR package. It is not a beginner's guide and assumes some previous experience with IRAF and CCD reductions. The first section discusses the mosaic data format and how to use it with IRAF. This format is more complex than single CCD images because of the multiple CCDs and possibly multiple amplifiers per CCD. To keep the data from each exposure self-contained the multiple CCD images are stored in a single file. This multiple image per file has many advantages but it does mean that some commands for dealing with images behave differently. The second section describes the tools used to examine the mosaic data. These tools are used during observing as well as during data reductions. The last section describes the reduction of mosaic data. This includes basic CCD instrumental calibration and combining mosaic exposures into single images. .sh 2. Multiextension FITS Files The data format used by the NOAO Mosaic Data Handling Software (MDHS) is a multiextension FITS (MEF) file. This format is produced by the the Data Capture Agent (DCA) when observing with the NOAO Mosaic. The MEF file for the NOAO Mosaic currently consists of nine FITS header and data units (HDU). The first HDU, called the primary or global header unit, contains only header information which is common to all the CCD images. The remaining eight HDUs, called extensions, contain the images from the eight CCDs. The fact that the image data is stored as a FITS file is not significant. Starting with IRAF V2.11, FITS files consisting of just a single primary image may be used in the same way as any other IRAF image format. The significant feature of the mosaic format is its multi-image structure. With multiextension FITS files you must either use tasks which are specifically designed to operate on these files as a unit or explicitly specify the image within the file that is to be operated upon by general IRAF image processing tasks. The tasks in the \fBmscred\fR package are designed to operate on the mosaic MEF files and so you only need to specify the filename. For image tasks outside the \fBmscred\fR package you must specify the image in the MEF file using the syntax .nf filename[extension] .fi where "filename" is the name of the MEF file. The ".fits" filename extension is optional provided there is no confusion with other files with the same basename. The image "extension" is specified either using an extension name or the position of the extension in the file (where the first extension is 1). The extension names in the NOAO Mosaic data are "im1" through "im8" for the eight CCDs. For a detail discussion of the IRAF FITS Image Kernel and the syntax it supports for multiextension FITS files see ftp://iraf.noao.edu/iraf/docs/fits_userguide.ps.Z. If you forget to specify an extension to a task that expects only single images you will get the following error which is your reminder to include an extension. .nf ms> imhead obj012 1 ERROR: FXF: must specify which FITS extension (obj012) .fi Two of the most common tasks that require specifying an image extension are \fBdisplay\fR to display a single CCD image (the task \fBmscdisplay\fR is used to display all the images at once) and \fBimheader\fR to list the header of a particular CCD. So, for example, the following commands might be used. .nf ms> display obj012[im2] 1 ms> imhead obj012[3] l+ .fi Other tasks you may use this way are \fBimexam\fR and \fBimplot\fR. A common question is how to specify a list of extensions. Modification of the syntax to allow wildcard templates in the extension specification is under study. Currently you must specify each extension explicitly, though the filename itself may be a wildcard; for example the first image in a set of files can be collectively specified with .nf obj*[im1] .fi There are two methods for specifying some or all extensions in tasks that operate upon lists of images. One is to make @files. This can be done explicitly with an editor. However the \fBproto\fR task \fBimextensions\fR can expand MEF files into an @file as in the following example. .nf ms> imexten obj012,obj13 > list ms> imhead @list .fi Read the help page for further information, additional parameters, and examples. Another method is to use the special \fBmscred\fR task \fBmsccmd\fR. This task can be used on the command line or as a simple interactive command interpreter. The idea is that you use the special designations "$input" and "$output" for task parameters which allow lists of images. Then lists of MEF filenames are specified for the input and output which are expanded and substituted into the task parameters when it is executed. For example, .nf ms> msccmd "imhead $input l+" input=obj012,obj013 .fi For additional information and examples consult the help page for that task. Note that the tasks \fBimstat\fR and \fBimarith\fR are so useful and common that there are specific \fBmscred\fR tasks \fBmscstat\fR and \fBmscarith\fR that operate on all or a subset of image extensions. So these tasks need not be used with \fBmsccmd\fR or with @files. We conclude with a discussion of the special operations of copying, renaming, deleting, and reading and writing FITS tapes as they apply to the mosaic MEF files. To copy a mosaic file as a unit use \fBcopy\fR, making sure to explicitly specify the "fits" extension. If you use \fBimcopy\fR it will expect you to specify a particular extension and will copy only that extension. While \fBimcopy\fR is not the way to copy an complete MEF file the tasks \fBimrename\fR and \fBimdelete\fR are the commands for renaming and deleting these files; though \fBrename\fR and \fBdelete\fR will also work provided you are explicit with the extension. Finally the mosaic data should be kept as a MEF file and so the special mosaic tasks \fBmscwfits\fR and \fBmscrfits\fR should be used. The current \fBwfits\fR and \fBrfits\fR are not intended for this type of data. .sh 3. Examining Mosaic Data During observing a small set of IRAF commands are commonly used to examine the data. This section describes these commands. While the discussion is oriented towards examining the data at the telescope during the course of observing, the tools described here are also used when reducing data at a later time. .sh 3.1 Displaying the Data The two commands \fBdisplay\fR and \fBmscdisplay\fR are used to display the data in a display server window. The display server is a separate process which must be running before displaying the images. The observing environment at the telescope will generally have the XIMTOOL display server already running with a window on a separate monitor. If it is not running for some reason it can be started with a menu selection. Away from the telescope you would start XIMTOOL or SAOIMAGE as you do normally. The display server must be told what size "frame buffer" to allocate for holding the display pixels. This determines how many pixels may be loaded at one time. Note that the display window may be smaller than this size and the display server allows you to move the portion viewed and zoom/unzoom any region. If the image size is larger than the frame buffer you can display a portion of the image at full resolution or the full image at a lower resolution. The frame buffer size is queried and set with the commands: .nf ms> show stdimage imt4096 ms> set stdimage=imt2048 .fi There are trade-offs in the frame buffer selection. A large frame buffer allows you to have higher resolution for the large mosaic images but it uses more memory and takes longer to load. The \fBdisplay\fR task is used to display individual images in the display server. This task is a standard IRAF task about which you are assumed to have some basic knowledge. There are many display options which are discussed in the help page. The only special factor in using this task with mosaic data is that you must specify which CCD image to display using the image extension syntax discussed previously. As an example, to display the central portion of extension im3 in the first frame and the whole image in the second frame: .nf ms> display obj123[im3] 1 fill- ms> display obj123[im3] 2 fill+ .fi The \fBmscdisplay\fR task is based on \fBdisplay\fR with a number of specialized enhancements for displaying mosaic data. It displays the entire mosaic observation in a single frame by "filling" each image in a tiled region of the frame buffer. The default filling (defined by the order parameter) subsamples the image by uniform integer steps to fit the tile and then replicates pixels to scale to the full tile size. The resolution is set by the frame buffer size. As mentioned before, trying to increase the resolution with a larger buffer size has the penalty of longer display times. An example display command is: .nf ms> mscdisplay obj123 1 .fi The default parameters for \fBmscdisplay\fR are shown below. Many of the parameters are the same as \fBdisplay\fR but there are also a few that are specific to the task of displaying a mosaic of CCD images as indicated with an asterisk. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscdisplay image = root name for image to be displayed frame = 1 frame to be written into * (mimpars= ) mosaic image parameters * (check = no) check if image is loaded * (onepass= no) load all extensions in one pass? (bpmask = BPM) bad pixel mask (bpdispl= none) bad pixel display (none|overlay|interpolate) (bpcolor= red) bad pixel colors (overlay= ) overlay mask (ocolors= green) overlay colors (erase = yes) erase frame (border_= no) erase unfilled area of window (select_= yes) display frame being loaded (repeat = no) repeat previous display parameters (fill = no) scale image to fit display window (zscale = yes) display range of greylevels near median (contras= 0.25) contrast adjustment for zscale algorithm (zrange = yes) display full image intensity range (zmask = ) sample mask * (zcombin= auto) Algorithm for combining z1 and z2 values... (nsample= 1000) maximum number of sample pixels to use (order = 0) spatial interpolator order (0=replicate,... (z1 = 0.) minimum greylevel to be displayed (z2 = 1000.) maximum greylevel to be displayed (ztrans = linear) greylevel transformation (linear|log|none|user) (lutfile= ) file containing user defined look up table .fi The mapping of the pixel values to grey levels includes the same automatic or range scaling algorithms as in \fBdisplay\fR. This is done for each image in the mosaic separately. The new parameter "zcombine" then selects whether to display each image with it's own independent display range ("none") or to combine the display ranges into a single display range based on the minimum and maximum values ("minmax"), the average of the minimum and maximum values ("average"), or the median ("median") of the minimum and maximum values. The independent scaling is most appropriate for raw data while the "minmax" scaling is recommend for processed data which are gain calibrated. The special value "auto" (the default) checks if the display data has been flat fielded, either by separate processing or with on-the-fly calibration, and if so it uses "minmax" scaling and if not it used independent scaling. The "mimpars" (mosaic image parameters) parameter is actually a reference to another set of parameters. The default with no value is to use the parameters from the parameter task \fBmimpars\fR. These parameters can be examined and set with \fBepar\fR either by typing ":e" when over this parameter in \fBmscdisplay\fR or by running \fBepar\fR directly on this task; i.e. epar mimpars. The parameters for NOAO Mosaic data are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mimpars (extname= ) extension name pattern (exttmpl= _![1-9]![1-9]![1-9].*) extension template (xgap = 72) minimum X gap between images (ygap = 36) minimum Y gap between images (process= no) do calibration processing? (oversca= yes) do line-by-line overscan subtraction? (flatfie= yes) do flat field correction? (caldir = mscdb$noao/kpno/4meter/caldir/) calibration directory (filter = !filter) filter .fi The "extname" parameter is used to select as subset of the image extensions to display. It is a pattern to match extension image names. For extensions such as im1, im2, etc. the pattern typically uses the character selection template such as "[1256]" to select anything with a 1, 2, 5, or 6 in the name. The pattern matching syntax can be found in the help for the task \fBmatch\fR. The "exttmplt" parameter is for use with non-MEF data. The gap parameters define the gap size in the display. The remaining parameters are for the on-the-fly calibration discussed below. .sh 3.1.1 On-the-Fly (OTF) Calibration Raw mosaic data can exhibit significant instrumental artifacts which may interfere with inspecting the data prior to reductions. The most significant artifact is gain variations both within each CCD image and between the CCDs. In the simplest case of constant gain variations between the CCDs the independent display scaling, "zcombine" of none or auto, may be sufficient. But when there are significant flat field patterns it may be desirable to apply a quick, approximate flat field calibration as the data are being displayed. \fBMscdisplay\fR can apply an on-the-fly (OTF) calibration to raw mosaic exposures. This does not change the actual data files and the calibration is intended to be quick and approximate. The calibration steps performed are a line-by-line bias subtraction using the overscan region of the data and a division by a flat field. If the data have been overscan corrected or flat field corrected by \fBccdproc\fR then the task will automatically skip those steps. The title of the display will indicate if the data have been calibrated by adding "[bias]" for bias subtraction and "[bias,flat=XXX]" for bias subtraction and flat fielding using an OTF flat field called XXX. The bias subtraction is performed by averaging the overscan pixels in a line and subtracting this average from all the pixels in the line. This removes the amplifier bias and line-by-line patterns. The flat field or response calibration is performed by reading special compact flat field calibration data which provides an approximate relative response for each pixel in each amplifier readout. Depending on how the calibration file is derived this will approximately correct for pixel sensitivity variations, gain variations between the amplifiers, sky illumination variations, and any pupil ghost pattern (as occurs with NOAO Mosaic data from the Mayall (KPNO 4meter) telescope). The "process" parameter in the \fBmimpars\fR parameter set shown earlier selects whether to turn on or off the OTF processing. If it is no then regardless of the "overscan" or "flatfield" parameter settings no calibration is applied. If it is yes then one or both calibration operations can be selected. Because the \fBmimpars\fR parameters can be set on the command line, it is common to leave the "process" parameter set one way, say to "no", and then override the value when displaying. For example, .nf ms> mscdisplay obj023 1 proc+ ms> mscdisplay flat022 2 proc+ flatfield- .fi The flat field calibration requires special calibration files. The "caldir" parameter defines a directory containing the calibration files. This can be a standard directory or a user directory. Note that if a directory is specified it must end with $ or /. Within the calibration directory the calibration file to apply is selected by the "filter" parameter. For automatic selection of calibrations, the calibrations can be selected by the filter string in the header (or by giving the same filter string in the "filter" parameter). To use the filter string in the header the value of the filter parameter is set to "!" where is the keyword for the filter string. Creating the a calibration directory and calibration files is done with the task \fBmscotfflat\fR. For the NOAO Mosaic a calibration directory is provided. However you can create your own as described in the help for \fBmscotfflat\fR. The "filter" parameter can be set to one of these names. .sh 3.1.2 Real-Time Display with the DCA During data acquisition the \fBmscdisplay\fR task can be used to display mosaic data as it is being written to disk by the DCA. It begins execution shortly after the readout begins and displays the portion of the recorded image which has been written to disk. It then continually displays new data which has been written by the DCA until the exposure is completely written to the display. The DCA control panel allows you to select whether to display the data during readout and how it is to be displayed. This includes selecting the OTF calibration. One toggle is equivalent to the "process" parameter. If the processing is turned on the DCA automatically selects only overscan bias subtraction for non-object exposures and selects both bias subtraction and flat field division for object exposures. The "filter" parameter is set by passing through the filter string from the data acquisition system or by overriding this and using the filter menu to select one of the available calibrations. .sh 3.2 Examining the Data The task \fBmscexamine\fR allows interactive examination of mosaic images. It is essentially the same as the standard \fBimexamine\fR task except that it translates the cursor position in a tiled mosaic display into the image coordinates of the appropriate extension image. Line and column plots also piece together the extensions at the particular line or column of the mosaic display. To enter the task after displaying an image the command is: .nf ms> mscexam .fi As with \fBimexamine\fR, one may specify the mosaic MEF filename to be examined and if it is not currently displayed it will be displayed using the current parameters of \fBmscdisplay\fR. It is important to realize that this task shares the \fBmimpars\fR parameters with \fBmscdisplay\fR. To get data values back that match what is displayed the parameters must agree with those used to display the data. In particular, if the data are display with OTF processing then \fBmscexam\fR must be told this either by explicitly setting the process flat in \fBmimpars\fR or setting it on the command line, .nf ms> mscexam proc+ .fi .sh 3.3 Examining the Headers There was discussion earlier concerning the use of generic image tasks with the NOAO Mosaic data. The tasks \fBimheader\fR and \fBhselect\fR fall into this category. The two important points to keep in mind are that you must specify either an extension name or the extension position and that the headers of an extension are the combination of the global header and the extension headers. Often one does not need to list all the headers for all the extensions. The image title and many keywords of interest are common to all the extensions. Thus one of the following commands will be sufficient to get header information about an exposure or set of exposures: .nf ms> imhead obj*[1] l- # Title listing ms> imhead obj123[1] l+ | page # Paged long listing ms> hselect obj*[1] $I,filter,exptime,obstime yes .fi If you need to list header information from all the extensions then you need to take the additional step of creating an @file or using \fBmsccmd\fR. For example to get the default read noise and gain values for each CCD: .nf ms> imextensions obj123 > list123 ms> hselect @list123 $I,rdnoise,gain yes or ms> msccmd "hselect $input $I,rdnoise,gain yes" input=obj123 .fi The \fBccdlist\fR task in the \fBmscred\fR package is specialized for the mosaic data. It provides a compact description of the name, title, pixel type, filter, amplifier, and processing flags. The "extname" parameter may be used to select a particular extension, a set of extensions, or all extensions. Because all extensions should generally be at the same state of reduction it may be desirable to list only the first extension. Like most of the CCD reduction tasks you can also select only a certain type of exposure for listing. Examples of the two modes are: .nf # Summary for all exposures ms> ccdlist *.fits extname=im1 # Summary for all object exposures ms> ccdlist *.fits extname=im1 ccdtype=object # List of all extensions. ms> ccdlist obj123 extname="" .fi .sh 3.4 Determining Best Focus Focus sequence frames can be evaluated for the best focus using \fBmscexam\fR and the 'r' or 'a' keys. However, there is a special task for measuring the sequence of focus images called \fBmscfocus\fR. This displays a focus exposure with \fBmscdisplay\fR (if needed) and then lets you select one or more bright stars to measure. This task is customized so that all you need do is mark the top image in any CCD. For NOAO Mosaic data, header information tells the task how many exposures, the spacings between the exposures, and the focus values. After the measurements are made they are displayed and analyzed graphically and written to the terminal and logfile. This task is the mosaic analog of the \fBkpnofocus\fR and \fBstarfocus\fR tasks for single CCD data. .sh 4. Data Reductions The reduction of CCD mosaic data can be divided into two stages. The first is the basic calibration of the individual CCDs. This stage is similar to reducing data from single CCD exposures except that the calibration operations are repeated for all the CCDs in the mosaic. The only significant difference is that any scaling of an exposure, such as in normalizing the flat field calibration, must be done uniformly over all the CCDs. The details of repeating the calibrations for all CCDs and the scaling of the calibration data are taken care of by the software and the data format so that these operations appear the same as with single CCD data. There are some steps which are not typical for CCD data with smaller fields of view or specific to the NOAO Mosaic at the Mayall telescope. At the Mayall telescope there are reflections off the corrector that produce a visible image of the pupil. Coating of the corrector minimizes this image but it may be desirable to remove this instrumental signature which would otherwise cause a small variation of the photometric zero point as well as an unwanted visible feature. There are two sections discussing removal of this feature from the flat field data and from the object exposures. If your data is from the KPNO 0.9 meter telescope or the image is faint enough that it is not of concern then you can skip the extended discussion. A caveat about the pupil removal steps described here is that this document was written prior to the latest removal of the corrector for better anti-reflection coating. So the NOAO staff have little experience with these corrections though earlier work has shown that these steps will do a good job. Another step of the basic CCD calibration stage which has generally been ignored or forgotten with smaller single CCD formats is the variable pixel scale. The large field of view provided by a mosaic and the optics required to provide it can lead to a significant variation in the pixel scale. This effect is important with the Mayall telescope and is also present in the NOAO 0.9 meter data to a smaller degree. It is likely to be present in other telescopes as well. When the pixel scale varies significantly the standard flat field calibration operation will cause the photometric zero point to vary. A simple calibration step can be performed to remove this effect. However, if you intend to produce single images from the mosaic of CCDs this step is not necessary since the resampling operation naturally accounts for this effect. The second stage of data reductions is unique to mosaic data. This stage is the combining of the multiple CCD images and multiple exposures into a single image. Since creating a single image from a single mosaic exposure is of marginal value, the thrust of this stage of the reductions is the combining of multiple exposures which have been spatially offset or "dithered" to cover both the gaps between the individual CCDs and any defects. The steps required to produce a single deep integration from dithered exposures consist of accurately registering the images, mosaicing the exposures into single images with the same spatial sampling, measuring changes in the intensity scale due to variations in transparency and sky brightness, and combining the individual images into a single deep image with the gaps and bad pixels removed. .sh 4.1 Some Preliminaries The command \fBsetinstrument\fR is used to set default parameters for the tasks in the \fBmscred\fR package appropriate to a particular instrument. For users of the NOAO Mosaic it is recommended you run this command the first time you reduce data. Subsequently you should not do this since it will reset parameters you later changed. To set the parameters for reducing the NOAO Mosaic data type the command .nf ms> setinstrument kpno 4meter CCDMosaThin1 review- .fi Substitute "36inch" for "4meter" if the data is from the Kitt Peak 0.9 meter telescope. For some of the operations it is useful to specify lists of exposures corresponding to a dither set. The examples in this guide show using @files for dither sets. An @file is simply a list of filenames. These can be created in several ways including using a text editor. One way is with the \fBfiles\fR command to expand a file template. For example, .nf ms> files obj021,obj022,obj023,obj024,obj025 > field1 ms> dir @field1 obj021 obj002 obj003 obj004 obj005 .fi .sh 4.2 Basic CCD Calibration Basic CCD instrumental calibrations consist of correcting each CCD for electronic bias levels, zero exposure patterns, dark counts, and pixel sensitivities. A cosmetic replacement of bad pixels may also be included. For the Mayall telescope the pupil image due to reflections off the corrector must be removed from the flat field and object exposures. An additional calibration is required to correct for the variable pixel scale across the field of view if you intend to do photometry on the individual CCD images. .sh 4.2.1 Calibration Data to Obtain At the Telescope Good data reductions begin with obtaining good calibration data at the telescope. This section discusses the NOAO Mosaic but the general principles will apply to other detectors, though the relative importance of different calibrations will depend on the quality of the CCDs and the stability of the camera. The standard calibration data are sequences of zero exposures and sequences of dome flat field exposures. While dark count exposures, matched to the typical object exposure times, were important for the first generation (engineering grade) NOAO Mosaic, dark counts are expected to be low in the science grade detectors. Thus dark count exposures are probably not necessary. Dome flat fields (dome flats) provide a fair basic flattening of the data to 2% or so, but sky flat fields (sky flats) are required to produce dithered data that can be combined without introducing obvious artifacts. Good sky flats can flatten the data to 0.1%. In our experience twilight exposures do not work well. Instead dark sky flat fields are derived from unregisted object exposures taken during the night or run. If your observing program consists of only large extended objects or single pointings then you should also take some dithered exposures of "blank" sky. At the Mayall telescope there is a pupil image caused by reflections off the corrector. For broadband photometry the effects of the pupil image are small but they can be reduced even further by reduction steps to remove the image. One useful calibration for this removal is a narrowband dome flat field. The idea is that the narrowband flat field has a more prominent pupil image that can be used as a template for the much fainter broadband pupil image. Lastly, good astrometry is required to register and stack the Mosaic images. The NOAO Mosaic data contains previously determined astrometry recorded in the headers of the raw exposures. This is sufficient for most purposes. However, for cameras without astrometry or to generate your own astrometry solutions, fields with a reasonable density of stars with cataloged accurate coordinates must be taken. Note that with the new generation of large astrometric catalogs and the large field of view of a mosaic, it may be that the object exposures already contain sufficient information for deriving new astrometric calibrations or corrections. Note that this guide does not yet discuss how to create the astrometric coordinate system solutions. .sh 4.2.2 Preparing Calibration Data This section describes how to prepare the basic calibration data. The steps are virtually the same as with the \fBccdred\fR package and, in fact, the command names and parameters are the same. The basic calibration data of zero level, dark count, and dome flat fields are generally taken as a sequence of identical exposures which are combined to minimize the noise. A later section discusses preparing a sky flat field calibration using the object exposures. The calibration exposures are individually reduced by \fBccdproc\fR and then combined. Thus, it is necessary to first set the \fBccdproc\fR parameters. Because this task knows which operations are appropriate for particular types of calibration exposures you can set all the parameters for object exposures. Below is a typical set of parameters. The main optional setting is whether or not to replace bad pixels by interpolation, which is purely a cosmetic correction. However, it is recommended that this be done to avoid possible arithmetic problems in the processing. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = ccdproc images = List of Mosaic CCD images to process (output = ) List of output processed images (ccdtype= object) CCD image type to process (noproc = no) List processing steps only? (oversca= yes) Apply overscan strip correction? (trim = yes) Trim the image? (fixpix = yes) Apply bad pixel mask correction? (zerocor= yes) Apply zero level correction? (darkcor= no) Apply dark count correction? (flatcor= yes) Apply flat field correction? (sflatco= no) Apply sky flat field correction? (biassec= !biassec) Overscan strip image section (trimsec= !trimsec) Trim data section (fixfile= BPM) List of bad pixel masks (zero = Zero) List of zero level calibration images (dark = Dark) List of dark count calibration images (flat = Flat*) List of flat field images (sflat = Sflat*) List of secondary flat field images (minrepl= 1.) Minimum flat field value (interac= no) Fit overscan interactively? (functio= legendre) Fitting function (order = 1) Number of polynomial terms or spline pieces (sample = *) Sample points to fit (naverag= 1) Number of sample points to combine (niterat= 1) Number of rejection iterations (low_rej= 3.) Low sigma rejection factor (high_re= 3.) High sigma rejection factor (grow = 0.) Rejection growing radius .fi The overscan correction has two methods as selected by the fitting function. A value of "legendre" (or "chebyshev" or "spline3") take all the overscan data and fit a smooth function along the column direction. The "order" value of 1 shown above fits a single constant value. This leaves to the zero level calibration to subtract any details of line-by-line structure. A value of "mean", "median", or "minmax" take the mean, median, or mean excluding the minimum and maximum values, of the overscan at each line and subtract that value from that line. The other fitting parameters are ignored. The advantage of this is that systematic line-by-line patterns are subtracted. The disadvantage is, since the sample of overscan pixels is small at each line, that this can also introduce a statistical line-by-line pattern. There is currently no recommendation for the NOAO Mosaic. The first step is generally to process and combine sequences of zero, dark, and dome flat exposures. This is done using the tasks \fBzerocombine\fR, \fBdarkcombine\fR, and \fBflatcombine\fR. The combining must be done in the following order since the processing of later calibration data requires the preceding calibration data. .nf ms> zerocombine *.fits ms> darkcombine *.fits ms> flatcombine *.fits .fi Each of these tasks search all the exposures for a particular type so it is fine to specify all files, though if the file names code the type, such as "dflatNNN", then one can use that as the wildcard to shorten the search of all the data. Also \fBflatcombine\fR has the feature that it will combine the data separately for each filter. However, you can use explicit file lists, templates, or @files to limit the input files. The output combined names have standard default values which the above settings for \fBccdproc\fR use. It is a good idea to first check that the different calibration types and filters are correctly identified by the software. This is done using the \fBccdlist\fR command .nf ms> ccdlist *.fits .fi Unless you change the parameters "mscred.backup" and "mscred.bkuproot" the original raw files will be saved in the subdirectory "Raw/". If you want to start over, delete the processed files and copy the raw files back to the working directory. If disk space is a concern and you are satisfied with the combined calibration files you can delete the individual processed calibration files. There is a parameter in the combining tasks that will delete the individual files automatically after processing and combining. .sh 4.2.3 Pupil Image Removal from Flat Fields NOAO Mosaic data taken at the Mayall (4meter) telescope include a pupil image caused by reflections off the corrector. The magnitude of this image is a function of the filter and the state of the anti-reflection coatings on the corrector. It is also a function of the total light, including from outside the field of view, and somewhat on the location of bright stars. It might appear at first that one simply divides the object exposures by the flat field as is done for the OTF display calibration. However this is not photometrically correct because the pupil image is an additive light effect and not a detector response. Instead the pupil image must first be removed from the flat field before applying it to the object data. The object data is then corrected after flat fielding by subtracting the extra light from the pupil image. The pupil image is removed from the flat field by dividing by an estimate of the pupil image pattern. The challenge is to determine the pupil image contribution in the presence of other flat field structure. There are two current approaches to obtaining the pupil image pattern for removal from the data. One is to use data from another source where the pupil pattern is more easily separated from the flat field pattern. The second is to derive the pattern from the data assuming something about the form of the pattern. In particular, to use the difference in scales between the larger pupil pattern and the smaller flat field pattern. The first approach is preferable since it better preserves fine structure in the pupil image but the second is needed when no other data is available. .sh 4.2.3.1 Broadband Data For broadband data the recommended procedure is to obtain a narrowband flat field exposure. This narrowband exposure will have a stronger pupil image relative to the flat field pattern and, when the pupil image is scaled down to match the broadband image flat field, the errors from the flat field response will be diminished. The pupil image is extracted from the narrowband flat field using the task \fBmscpupil\fR. This task determines the background levels in a ring inside and outside the main pupil image and subtracts this background to produced the pupil image template. Outside the outer background ring the template is set to zero. In effect this is like "scrapping off" the pupil image from the exposure. The relevant parameters are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscpupil input = List of input images output = List of output images (masks = BPM) List of masks (type = data) Output type (xc = 27.) Pattern center offset (pixels) (yc = 9.) Pattern center offset (pixels) (rin = 300.) Radius of inner background ring (pixels) (drin = 20.) Width of inner background ring (pixels) (rout = 1500.) Radius of outer background ring (pixels) (drout = 20.) Width of outer background ring (pixels) (funcin =chebyshev) Inner azimuthal background fitting function (orderin= 2) Inner azimuthal background fitting order (funcout= spline3) Outer azimuthal background fitting function (orderou= 2) Outer azimuthal background fitting order * (rfuncti= spline3) Radial profile fitting function * (rorder = 40) Radial profile fitting order * (abin = 0.) Azimuthal bin (deg) * (astep = 0.) Azimuthal step (deg) (niterat= 3) Number of rejection iterations (lreject= 3.) Low rejection rms factor (hreject= 3.) High rejection rms factor (datamin= INDEF) Minimum good data value (datamax= INDEF) Maximum good data value (verbose= yes) Print information? .fi The output type is set to "data" to extract the pupil image after background subtraction. The pattern center parameters are offsets from the astrometric center and the inner and outer radii are measured from the pattern center. The default values are for the last measured Mayall pupil image. The fitting parameters marked with an asterisk are not used when extracting the pupil image directly. The pupil image template is scaled and removed from the flat field using the task \fBrmpupil\fR. The removal is done with the arithmetic operation .nf I(out) = I(in) / (scale * I(template) + 1) .fi where I(out) are the output corrected pixel values, I(in) are the input pixel values, I(template) are the pupil image template pixel values, and scale is the relative scale factor to be applied. The parameters for the pupil image removal task are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = rmpupil input = Input mosaic exposure output = Output mosaic exposure template= Template mosaic exposure (type = ratio) Type of removal (extname= [2367]) Extensions for fit (blkavg = 8) Block average factor (fudge = 1.6) Fudge factor (interac= yes) Interactive? (mscexam= no) Examine corrections with MSCEXAM? .fi The "input" is the broadband flat field, the "output" is the corrected flat field, and the "template" is the narrowband pupil image produced by \fBmscpupil\fR. The type of removal for a flat field is "ratio" as given by the equation above. Determining the optimal scaling of the template pupil image to the input pupil image is normally done interactively. The task makes a guess at scaling. If this task is used non-interactively this will be the scale used. When the task is used interactively the input and corrected mosaic exposures are displayed and then a query for a new scale is given. By repeatedly adjusting the scale factor the best visual removal can be obtained. When done the output corrected flat field is created using the last specified scale factor. Note that to quit requires entering dummy special values for the scale factor. A value of zero means to create the final output exposure with the last scale factor and a value of -1 means to quit without producing any output. Because this operation is fairly slow and iterative there are some steps that can be taken to it speed up. The "extname" parameter selects just those extensions to look at. For NOAO Mosaic data the default selects the central four extensions covered by the pupil image. The "blkavg" parameter applies a block average to the input exposure and template. This makes the display and iterative corrections faster. When the best scale factor has been determined the entire input image at full resolution is corrected by the full resolution template to create the output flat field. If one wants to use the facilities of \fBmscexam\fR to evaluate each iterative correction then the "mscexam" parameter can be set. However, the most powerful estimate for the optimal scale factor is viewing the display and possibly blinking between the uncorrected and corrected frames. .sh 4.2.3.2 Narrowband Data For narrowband data the pupil image template must be derived from the data itself. This is done by fitting the data with an axially symmetric pattern. The fitting is performed by \fBmscpupil\fR with the parameters .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscpupil input = List of input images output = List of output images (masks = BPM) List of masks (type = ratio) Output type (xc = 27.) Pattern center offset (pixels) (yc = 9.) Pattern center offset (pixels) (rin = 300.) Radius of inner background ring (pixels) (drin = 20.) Width of inner background ring (pixels) (rout = 1500.) Radius of outer background ring (pixels) (drout = 20.) Width of outer background ring (pixels) (funcin =chebyshev) Inner azimuthal background fitting function (orderin= 2) Inner azimuthal background fitting order (funcout= spline3) Outer azimuthal background fitting function (orderou= 2) Outer azimuthal background fitting order (rfuncti= spline3) Radial profile fitting function (rorder = 40) Radial profile fitting order (abin = 0.) Azimuthal bin (deg) (astep = 0.) Azimuthal step (deg) (niterat= 3) Number of rejection iterations (lreject= 3.) Low rejection rms factor (hreject= 3.) High rejection rms factor (datamin= INDEF) Minimum good data value (datamax= INDEF) Maximum good data value (verbose= yes) Print information? .fi Note that this only differs from the previously shown parameters by setting the "type" parameter to ratio. Because the template is derived from the data itself there is no need to use \fBrmpupil\fR to iteratively determine a scale factor. The "output" parameter is the corrected flat field. The corrected narrowband flat field will show some artifacts from fine structure in the pupil image. However, a large fraction of the pupil image will be removed. Later reduction steps of applying a sky flat field and combining with dithering further eliminate effects of this approximate solution to the pupil image. .sh 4.2.4 Object Exposure Reductions At this point you will have some subset of combined zero level, dark count, and flat field calibration data. The calibration data is applied to the object exposures, either in bulk or as observations are completed, using the task \fBccdproc\fR. The command is simply .nf ms> ccdproc .fi .sh 4.2.5 Pupil Image Removal from Object Data The pupil ring image in the object exposures is removed by subtraction since this is excess light. Again this is only required for data where the pupil image occurs, such as from the Mayall telescope. The tasks for modeling and removing the image are the same as for removal from the flat field except that the "type" parameter is set to "difference". .sh 4.2.5.1 Broadband Data Probably the best subtraction will be obtained by using the pupil image template from a narrowband flat field. This would be the same as used for the flat field and extracted from the narrowband flat field using \fBmscpupil\fR with "type = data". The subtraction is carried out using \fBrmpupil\fR with "type = difference". An alternative, since the pupil image is weak and the fine structure is unimportant, is to use \fBmscpupil\fR with "type = difference" to determine a smooth large scale ring pattern and subtract it from the data. The iterative sigma rejection and the "datamin" and "datamax" parameters are used to eliminate smaller scale astronomical objects in the field from affecting the background fits and the ring profile fits. For this application the "abin" parameter should be set to a value such as 30 degrees and the "astep" parameter to a smaller value such as 5 degrees. The main advantage of this method is that no iterative scaling is required since the fit is done directly to the data. The difficulty, though, is if there is a bright star or fairly extended object, particularly in the inner background ring, then the fit will be poor and the subtraction will show gross artifacts. The last alternative, and the one to use if there is no narrowband flat field for the template and the field has bright stars which affect fitting directly to the data, is to make a "sky flat" to generate the pupil image template. This is done as described in the section for creating a sky flat. Once the sky flat is created with the pupil image then \fBmscpupil\fR is used to separate the pupil image from the background and \fBrmpupil\fR is used to scale and subtract the image from the object exposures. Note that after the pupil image is subtracted then a new sky flat should be created. .sh 4.2.5.2 Narrowband Data For narrowband data the two alternatives described for the broadband data are used. The first is to fit and subtract a smooth ring model from each object exposure using \fBmscpupil\fR. This is the same as described for removing the pupil image from the flat field except the "type" parameter is set to difference. The second is to create a sky flat from disregistered exposures, extract the pupil pattern with \fBmscpupil\fR, and then subtract it from each object exposure using \fBrmpupil\fR. .sh 4.2.6 Dark Sky or Twilight Sky Flat Fields You will notice that there are two flat field corrections which can be performed by \fBccdproc\fR. The first one is for an initial flat field such as the dome flat obtained at the beginning of the night, a standard flat field from a previous night or run, or a final combined dome flat and sky flat from some other night or run. The second is for a dark sky or twilight sky flat field prepared from the object exposures after they have been calibrated with the first flat field. Sky flat fields are created by combining object exposures with objects removed by using data in each pixel that is only sky. In principle one could use exposures of the twilight sky but our experience is that these do not work well. You are welcome to take some exposures and try using them. We have found that dark sky flat fields derived from the object exposures do work quite well. Mosaic observations already typically dither a field. One will do even better by combining observations from other fields. The more data used the better the resulting sky flat will be. The main criterion for including data is to avoid observations contaminated by varying background light from the moon or scattered light from bright stars off the field. Of course, another factor that has to be considered is whether a field has a very large extended object which appears in many of the observations. These will not be useful. The sky flat field is created using the task \fBsflatcombine\fR with parameters selected to reject objects appearing above a median. We don't have much experience with creating sky flats currently so some experimentation with parameters may be required. Below is one possibly set of parameters. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = sflatcombine input = List of images to combine (output = Sflat) Output sky flat field root name (combine= average) Type of combine operation (reject = avsigclip) Type of rejection (ccdtype= object) CCD image type to combine (subsets= yes) Combine images by subset parameter? (scale = mode) Image scaling (statsec= ) Image section for computing statistics (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 6.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= rdnoise) ccdclip: CCD readout noise (electrons) (gain = gain) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (pclip = -0.5) pclip: Percentile clipping parameter (blank = 1.) Value if there are no pixels (grow = 3.) Radius (pixels) for neighbor rejection .fi This task is a combination of \fBccdproc\fR to first process the images, if they have not previously been processed, and \fBcombine\fR to combine the offset images with rejection of object pixels. A new feature of this task is the "grow" parameter which now provides a two dimensional circular rejection of pixels around pixels rejected by the rejection algorithm. Whatever rejection algorithm is used it is likely that the best results will be when the clipping sigmas are non-symmetric as shown above. Note that a very low rejection threshold or very large grow radius will make the task quite slow. After producing a good sky flat that has no evidence of objects it may be applied directly to the data by using it as the second flat field correction. .nf ms> ccdproc sflatcor=yes sflat=Sflat* .fi Note that the object exposures used in creating the sky flat will already have been processed except for the application of the sky flat so \fBccdproc\fR will only apply the sky flat field calibration. The sky flat field includes corrections at all scales from pixel-to-pixel sensitivity variations to large scale illumination differences. If the signal-to-noise is poorer than the dome flat field you might wish to apply a filtering/smoothing operation to the sky flat data thus relying on the dome flat field for the pixel-to-pixel sensitivity calibration and the sky flat field for larger scale illumination corrections. There are a number of filtering tasks in IRAF. A median is a good filter and there is the choice of a ring median or box median. To apply one of these general filtering tasks you would use \fBmsccmd\fR to run it on all the CCDs .nf ms> msccmd msccmd: median $input $output 10 10 Input files: SflatV Output files: SflatMedV msccmd: q .fi Because the object exposures are first processed with the dome flat (or other flat field) you would normally run \fBccdproc\fR again on the data using the sky flat and any observations that have not been processed at all will use both the dome flat and the sky flat. However, if you want to make a single flat field to apply to raw data, say if starting over or using it for a second night, you can combine the two flat field corrections into a single flat field to be used as the only flat field correction. This is done by multiplying the two flat fields using \fBmscarith\fR .nf ms> mscarith FlatV * SflatV FinalflatV .fi .sh 4.2.7 The Variable Pixel Scale and Zero Point Uniformity A key assumption in the traditional reduction of CCD images is that the pixel scale is uniform and that a properly reduced blank sky image will have a uniform and flat appearance. Unfortunately, this is not correct when the pixel scale varies over the field. In the case of the NOAO Mosaic at the Mayall telescope, the pixel scale decreases approximately quadratically from the field center, with the pixels in the field corners being 6% smaller in the radial direction, and 8% smaller in area. Pixels in field corners thus would properly detect only 92% of the sky level seen in the field center, even with uniform sensitivity. At the same time the same number of \fItotal\fR photons would be detected from a star regardless of how many pixels the PSF would be distributed over. Forcing the sky to be uniform over the image has the deleterious effect of causing the photometric zeropoint to vary from center to field corners by 8%. Note that this effect is different from vignetting where the flux actually delivered to the image margins is less than that at the center, an effect that \fIis\fR corrected by the flat field. In practice, the photometric effect of the variable pixel scale can be ignored provided that the reduced images will be part of a dither-sequence to be stacked later on. As discussed below, prior to stacking the images they first must be re-gridded, which produces pixels of essentially constant angular scale. This is done with the \fBmscimage\fR task, which re-grids the pixels and has a "flux conservation" option that can scale the pixels photometrically by the associated area change. If this function is disabled, then "improperly" flattened images will have a uniform zero point restored. In short, the flat field adjusted (if inappropriately) for the different pixel sizes, so \fBmscimage\fR would then do no further adjustment. Stars would be too bright in the corners of the flattened images, but after re-gridding, their total fluxes would be seen to be scaled down to the appropriate values. If the mosaic CCD images are to be analyzed individually, as might be done for standard star fields, then after the flat field reductions are complete the differential scale effects must be restored. At present we are developing a routine in the \fBmscred\fR package to do this, without actually re-gridding the image. The correction process is simple; the scale at any point in the Mosaic field is already known from the astrometry so one just calculates and multiplies by the correction. The final image would appear to have a variable sky level, but would be photometrically uniform. .sh 4.3 Coordinate Calibration For some projects the basic flux calibrated CCD exposures may be all that is required. However, if you want to obtain coordinate information or combine multiple exposures which are dithered on the sky or taken with different filters, you must calibrate the celestial world coordinate system (WCS) of the data. This may be done in an absolute or relative sense; an absolute calibration ties the data coordinates to catalog coordinates while a relative calibration ties multiple exposures to the same coordinates. Determining the WCS from scratch is a complicated business and requires special observations of astrometry fields. However, for NOAO Mosaic data a standard coordinate calibration determined earlier is automatically inserted into your data by the data capture agent. The default coordinate system is sufficiently accurate for most purposes and just requires some small adjustments as described below. To piece a single exposure into a single image that does not require registration to any other data you may use the default WCS and skip the WCS calibration steps. The WCS is a mapping from pixels in the mosaic data to celestial coordinates relative to a reference point on the sky. The reference point, or zero point, is set using the telescope pointing coordinate. The telescope pointing is generally off by a small amount, though it could be completely wrong in some hardware/software error situations. In addition, differential atmospheric refraction introduces small axis scale changes and rotations, which are significant due to the large field of view of the mosaic even during the course of single set of dithered exposured. Putting observations from different filters onto the same coordinate system also requires mapping small scale changes, since currently there is only a single standard WCS solution derived through one filter. [In the future filter dependent solutions will be made available.] The WCS calibration operations consist of adjusting the standard coordinate system calibration to a desired zero point and applying small axis scale changes and rotations. This is done using objects (usually stars) in the exposures. Unlike a full WCS calibration, which requires a high density of stars with accurate catalog coordinates, the adjustments to the default WCS calibration require only a few objects; only one objects is needed to provide a zero point correction. The WCS adjustments are determined by specifying coordinates for one or more objects in the data. The coordinates can be obtained from a reference catalog or, more commonly, by measuring coordinates from one reference exposure to which other exposures are to be "registered". A combination of using a catalog coordinate for one object in the field to set the zero point in a reference exposure and then measuring the positions of other stars in the reference image based on that zero point calibration may also be done. The two tasks you will use are \fBmsczero\fR and \fBmsccmatch\fR. \fBMsczero\fR is used to interactively set the zero point of the coordinates, register multiple exposures closely, and generate a list of coordinates in a reference exposure to which other exposures in a dither set are registered. \fBMsccmatch\fR finds objects at the positions specified by a list of coordinates and determines corrections for the zero point, axis scale change, and axis rotation. .sh 4.3.1 Setting Coordinate Zero Points and Measuring Coordinates \fBMsczero\fR is an interactive display task for mosaic exposures that allows measuring coordinates and adjusting the WCS zero point. The task parameters are shown below. The last set of parameters (starting with "ra") are for the task to query and maintain lists. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msczero images = List of mosaic exposures (nframes= 2) Number of frames to use (logfile= default) Log file for measurements ra = RA (hours) dec = DEC (degrees) update = yes Update WCS zero point? (fd1 = ) (fd2 = ) .fi The task displays each exposure in the list, in turn, and responds to cursor key commands. You can go forward and backward through the input list or quit at any point. The exposures are displayed by cycling through the specified number of frames starting with the first frame. As an aid to efficiency, if the exposure is already loaded in the appropriate frame then the display step is skipped. This task has several uses (type '?' to get the list of command options): .nf 1. Set the WCS zero point by specifying the coordinate of a star. 2. Create a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. 3. Report coordinates at the cursor position. .fi It may be that the WCS zero points, based on the telescope pointing coordinates, are accurate enough that you can use this task on only a reference exposure to generate a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. However, because it is fairly quick to explicitly check and set the zero point of all the exposures in a dither set to the same coordinate for a common reference star, it is recommended you do this first. To check and set the zero points for a set of dithered exposures run \fBmsczero\fR with a list of the exposures .nf ms> msczero @field1 .fi After the first exposure is displayed either find a reasonably bright unsaturated star which will be in all the exposures or find a star whose coordinate is known from a catalog such as the HST Guide Star Catalog. Move the cursor to the star and type 'z' (zero) to invoke a centering algorithm. Note that even though the exposure may be displayed at lower resolution the centering is done with the full resolution data. The task will then tell you what it thinks the coordinate is and ask you for a new coordinate. The first time 'z' is typed it will prompt with the measured coordinate and thereafter it will prompt with the last entered value. If you are referencing all the exposures to the first exposure in the list accept the measured coordinate (and write the value down in case you need it later) otherwise enter the desired coordinate. Note that all further measurements of the image will automatically apply the measured zero point correction but the exposure WCS is not actually updated until you type 'n' (next) or 'q' (quit). If you want to print coordinates without changing the zero point correction use the space bar or 'c' (center) to center on an object and print the centered coordinate. If you changed the WCS zero point you will be shown the zero point offsets and given the option to update the WCS in the data file when you type 'n'. Then the next exposure in the list will be displayed. Find the same star and type 'z' again. Since it will retain the last entered coordinate you should only need to accept the prompted coordinates. When you have done this for all the exposures their coordinate systems will be registered at least at that point. The WCS in the dither set may still not be registered over all the field due to refraction effects. Also the intensity scales of the dithered exposures may not be the same due to changes in transparency and sky brightness. These effects are calibrated by matching objects throughout the field in position and brightness. This requires a list of coordinates tied to one of the dithered exposures as a reference. Usually the first exposure in the set is used as the reference. \fBMsczero\fR is used to create a list from objects in the reference exposure. .nf ms> msczero obj021 .fi Select objects, usually stars, throughout the field and type 'x' for each one. This will center on the object and and record the coordinate in a logfile. The default logfile name "default" creates a log file beginning with "Coords." and followed by the name of the exposure. In the example this will be "Coords.obj021". To be useful for coordinate matching this list should have a good number of stars, say three or four from each CCD, with emphasis on the field edges but allowing for the dithering. For the intensity matching you want to have stars with a range of brightness (though not saturated or extremely faint) and which are mostly isolated so that a region around them may be used for sky. The lists for the coordinate and intensity matching do not have to be the same but it is reasonable to just create one list. .sh 4.3.2 Matching Coordinate Systems The task \fBmsccmatch\fR determines and applies a linear correction to the WCS to match objects, generally stars, in an exposure to a set of reference celestial coordinates. This correction maintains the detector geometry and optical distortions while adjusting for changes in apparent sky position such as produced by atmospheric refraction and telescope pointing errors. The linear correction consists of a zero point shift, scale changes in the right ascension and declination axes, and rotations of the axes. To use this task you need a list of reference celestial coordinates, right ascension in hours and declination in degrees, and the mosaic exposure coordinate system must be relatively close to the reference coordinate system. The default WCS plus telescope pointing may be close enough, but if not you would use \fBmsczero\fR to register the zero points at some point in the exposures. Since it is relatively simple to register a set of dithered exposures to a common star with \fBmsczero\fR this is recommended procedure before using \fBmsccmatch\fR. The reference coordinates should cover all of the mosaic field of view to be sensitive to the small rotation and scale effects. The coordinate list might be obtained from a catalog or measured from one of the exposures to which other overlapping exposures will be matched. For the purposes of making a well aligned stacked image from a set of dithered exposures one generally uses one of the exposures as the source of the reference coordinates. \fBMsccmatch\fR operates on a set of input mosaic exposures; each in turn. For an exposure it converts each input celestial coordinate to a pixel coordinate in one of the extensions using the current WCS. If the coordinate does not fall in any extension the coordinate is not used. The pixel coordinate is used as a starting point for the \fBapphot.center\fR task. If the centering fails for some reason, such as the object being too near the edge or the final position being too far from the initial position, the coordinate is not used. For those objects successfully found a fit is made between the original celestial coordinates and the measured coordinates expressed as arc seconds from the exposure tangent point. The fit is constrained to yield some combination of shift, scale change, and rotation for each of the celestial coordinate axes. These parameters are then used to update the exposure WCS so that the adjusted measured coordinates best agrees with the reference coordinates. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msccmatch input = List of input mosaic exposures coords = Coordinate file (ra/dec) (nfit = 4) Min for fit (>0) or max not found (<=0) (rms = 2.) Maximum fit RMS to accept (arcsec) (maxshif= 5.) Maximum centering shift (arcsec) (fitgeom= rxyscale) Fitting geometry (update = yes) Update coordinate systems? (interac= yes) Interactive? (fit = yes) Interactive fitting? (verbose= yes) Verbose? accept = yes Accept solution? .fi The input is a list of mosaic exposures and a file of reference celestial coordinates. The exposures should all include a significant number of objects from the list of coordinates. The task can be run interactively or non-interactively based on the "interactive" parameter. In interactive mode you can graphically interact with the fitting (selected with the "fit" parameter) and accept or reject a fit based on the printed fit parameters. The fitting is done using the task \fBgeomap\fR and the interactive mode allows you to view the distribution of coordinates, residuals verses the input coordinates, delete bad values, and possibly change the fitting constraints (see the help for \fBgeomap\fR for more information). The linear transformation may be constrained by the "fitgeometry" parameter as described in the help for \fBgeomap\fR. This may be desirable if there are only a few coordinates or if you want to impose some physical assumption. Note that the effects of atmospheric refraction actually do cause independent scale changes and rotations in the two axes so the default "rxyscale" should be used. There are some constraints which are placed on the task. The "maxscale" parameter limits how far the objects may be found from the initial coordinates. This constraint protects against incorrect identifications and tells the centering routine how much of the image to look at. This parameter should be as small as possible consistent with the errors in the WCS. If you first zero the coordinates then the objects should be found quite close to the initial coordinates. When the "verbose" parameter is set the results of the centering will be printed consisting of the image extension name, the final pixel coordinates, the shift in pixel coordinates from the initial value, and the formal uncertainties in the pixel coordinates. If an error occurs one of the error codes from \fBapphot.center\fR will be reported such as "BigShift" for objects with too big a shift from the initial position and "EdgeImage" for objects to near the edge of the image. The "nfit" parameter requires a certain number of coordinates to be included in the fit. If specified as a negative number the parameter is interpreted as a maximum number that may be lost from the input list due to being off the exposure or failing to be centered. The "rms" parameter requires that the final RMS of the residuals about the fit for each axis be less than a certain value. .sh 4.4 Putting the Pieces Together This section tells you how to make single images from each multiextension exposure and how to combine sets of dithered images into a final deep image free from gaps and artifacts. Obtaining good results depends on having well-flattened data, a uniform sky, a dither pattern that samples the gaps and bad regions of the detectors, and accurately registered world coordinates. Most difficulties are caused by variable sky conditions or scattered light within a dither sequence or the data used to create a sky flat. .sh 4.4.1 Removing Sky Gradients Any sky level mismatches when combining dithered exposures produce artifacts in the final image. The three sources of such mismatches are sky gradients, sky level differences between the CCDs, and sky level differences between exposures. While the flat field calibration, particularly with a sky flat, should remove differences in sky levels between CCDs, in practice there may still be small errors. And the flat field will not deal with sky gradients across the large field of view. Exposure-to-exposure sky brightness variations can be dealt with at a later stage but even this is tricky. The best final result is obtained by fitting a low order surface (a plane or quadratic) to the sky and subtracting it from each CCD of each object exposure at this stage. This will force the sky to be zero for all CCDs and all exposures. Note that if one wants to preserve a sky level for statistical reasons it is possible to add a uniform constant after the subtraction to all the data (or add the constant to the final dither stacked image). To fit and subtract a sky and sky gradient the combination of \fBimsurfit\fR and \fBmsccmd\fR is used. With \fBimsurfit\fR use the option to fit to medians in large blocks to remove the effects of objects. .nf ms> msccmd msccmd: imsurfit $input $output xo=2 yo=2 type=resid xm=100 ym=100 Input files: obj* Output files: obj* msccmd: q .fi In this example the input and output are the same, replacing the original by the sky subtracted data, but one can create new output files if desired. Note that x and y orders of 2 correspond to a plane and orders of 3 correspond to a quadratic surface. .sh 4.4.2 Constructing Single Images Making a single image from a mosaic exposure is done by mapping the pixels from each extension to a single uniform grid on the sky. The WCS calibrations described in previous sections provide this. For making a single image from a single exposure the WCS calibration is not critical and the default WCS is sufficient. For combining multiple dithered exposures all the exposures must be registered to a common coordinate system, either relative to one reference exposure or to a set of catalog stars, and each exposure must be resampled to the same final coordinate system. The task that makes single images from mosaic exposures is \fBmscimage\fR. Its parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimage input = List of input mosaic exposures output = List of output images (referen= ) Reference image (pixmask= yes) Create pixel mask? (verbose= )_.verbose) Verbose output? # Resampling parameters (blank = 0.) Blank value (interpo= linear) Interpolant for data (minterp= linear) Interpolant for mask (fluxcon= no) Preserve flux per unit area? (ntrim = 7) Edge trim in each extension (nxblock= 2048) X dimension of working block size in pixels (nyblock= 1024) Y dimension of working block size in pixels # Geometric mapping parameters (interac= no) Fit mapping interactively? (nx = 10) Number of x grid points (ny = 20) Number of y grid points (fitgeom= general) Fitting geometry (functio=chebyshev) Surface type (xxorder= 4) Order of x fit in x (xyorder= 4) Order of x fit in y (xxterms= half) X fit cross terms type (yxorder= 4) Order of y fit in x (yyorder= 4) Order of y fit in y (yxterms= half) Y fit cross terms type .fi An output image is created for each input mosaic exposure. The output image is created with a coordinate system defined by the specified "reference" image. If no reference image is specified then the first input mosaic exposure is used to define a simple tangent plane coordinate system with optical distortions removed, and that coordinate system is used for all the input mosaic exposures. The important point is that for a set of dithered exposures all the output images must be created with the same coordinate system grid so that they may be combined by simple integer shifts along the image axes. The normal usage is to specify all the mosaic exposures in a dither set as the input, give a matching list of output images, and leave the reference image unspecified. If all the exposures in a dither set are not done at the same time then you must specify one of the earlier output images as the reference image to continue to create the output images on the same coordinate grid. The output images are created with a size that just covers the input data and initially filled with the specified "blank" value. This is the value that the mosaic gaps will have in the final output image. Then each extension is resampled into the appropriate part of the output image. The coordinate mapping is generated by \fBgeomap\fR using the geometric mapping parameters which you don't need to change. The resampling is done with the specified interpolation function. The small rotations in the CCDs produce edge effects in the interpolated output pieces so a small trim is required to eliminate these. [At the time this document was prepared the best value for the new science grade NOAO Mosaic had not been determined.] Linear interpolation is the fastest and most straightforward. Other interpolation functions are available. In particular sinc interpolation is now available as an add-on option (see the \fBmscred\fR installation instructions). Experience with sinc interpolation shows that it is not overly slow and does provide improved results; particularly with maintaining the statistical characteristics of the sky noise. The "minterpolant" parameter allows using a faster and more local interpolation function for the mask. This is particularly useful when using sinc interpolation of the data to allow flagging only around the actual bad pixels and not extending out as far as the sinc interpolation does. It is useful for the later combining step to make bad pixel masks that reflect the interpolation and resampling from the input data. These may be created by setting the "pixmask" parameter. If this parameter is set and the input mosaic data have bad pixel masks defined through the header BPM keywords (default bad pixel masks are provided in the NOAO Mosaic data) then the masks will be interpolated in exactly the same way as the data. The interpolated masks will appear in the working directory with names related to the output image names and with the output images containing the BPM keyword pointing to these masks. The input bad pixel masks are assumed to have zero for good data and one for bad data and the output masks have zero for good data and values between zero and ten thousand for bad data. The value is the result of interpolation and reflects the relative contribution of good and bad data. The "fluxconserve" parameter applies a pixel area correction if selected. As discussed earlier, standard flat fielding distorts the flux per unit area in pixels of different projected size by making them have the same flux per pixel. In effect this applies half of the flux conservation operation by adjusting the pixel values without adjusting the pixel sizes. \fBMscimage\fR does the second half by adjusting the pixel sizes. So for standard flat fielded data, the usual route to making a combined dithered image, the flux conservation parameter should not be used to arrive at a proper final flux per unit area in the resampled data. Flux conservation would only be used if the input mosaic data has previously been corrected back to proper flux per unit area through adjustment of the flat field or data for the variable pixel size inherent in the mosaic coordinate system. Below are two examples; one using prepared @files and one illustrating advanced usage of filename templates. .nf ms> mscimage @dither1 @outdither1 pixmask+ ms> mscimage obj02![2-5]* %obj%mos%02![2-5]* pixmask+ .fi In the second example the input template expands to obj022.fits to obj025.fits and the output template matches the input template using the first part of the %% substitution field and then replaces the "obj" with "mos" to give output images mos022.fits to mos025.fits. .sh 4.4.3 Matching Intensity Scales When stacking dithered exposures (the single images created in the previous step) to fill in the mosaic gaps and remove bad pixels and cosmic ray events it is critical that the intensity scales of the images match. Otherwise you will see artifacts from the gaps, places with bad data, and around objects as the combined intensity level jumps when data from an exposure is missing or rejected. Also the rejection algorithms require that the image intensities match both at the sky level and in the objects. There are two parameters that must be determined to match the intensity scales. One is a additive offset caused by sky brightness variations. The second is a multiplicative scale change caused by transparency and exposure time variations. Matching the intensity scales for a set of dithered exposures consists of determining values for these two scaling parameters relative to a reference exposure and setting them in the image headers. The actual adjustment of the pixels values occurs when stacking the exposures. The intensity matching values are determined by the task \fBmscimatch\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimatch input = List of images coords = File of coordinates (scale = yes) Determine scale? (zero = no) Determine zero offset? (box1 = 21) Inner box size for statistics (box2 = 51) Outer box size for statistics (lower = 1.) Lower limit for good data (upper = INDEF) Upper limit for good data (niterat= 3) Number of sigma clipping iterations (sigma = 3.) Sigma clipping factor (interac= no) Interactive? (verbose= yes) Verbose? .fi The input is a list of images to be matched and a file of celestial coordinates (RA in hours and DEC in degrees) to use in computing the matching parameters. The input images are the single images constructed from the mosaic exposures for a set of dithered observations. The parameters "scale" and "zero" select whether to determine the multiplicative scale, the zero level offsets, or both. If the sky has been subtracted at an earlier stage (as recommended) then only the multiplicative scale difference needs to be determined. The advantage of subtracting the sky earlier is that scale determination becomes better constrained. Also determining the sky from photometry (as done by this task) is less robust than the surface fitting which uses all of the sky data. The scaling parameters are determined by measuring the mean flux in a set of matching regions between each input image. The centers of the regions are specified by their celestial coordinates. The list of coordinates should consist of the positions of objects in the field. These objects should span a range of brightness. As noted previously, you would normally use the same coordinate list as used with \fBmsccmatch\fR, which is generally obtained using \fBmsczero\fR. However, you can use any IRAF task that produces a list of celestial coordinates from images with a WCS. One possibility is to use \fBrimcursor\fR on one of the displayed single images with the "wcs" parameter set to "world" and the "wxformat" set to "%.2H" to produce right ascension values in hours instead of degrees. The now accurately aligned coordinate systems in the images are used to identify the matching pixel coordinate center in each image. The regions to be measured consist of square boxes of the specified sizes about the pixel coordinate center. There are two boxes, an inner box and an outer box which excludes the inner box. The box sizes are intended to define photometry apertures for the objects and nearby background. It is not critical that they exactly fit the objects or that the objects necessarily be stars but this is usually how they will be set. Because of possible PSF variations the inner box should be large enough include all the light from stars over the whole data set. If the inner box is not fully contained in the input or reference image that box is not used for that pair. Similarly the outer box must be fully contained in the images but if only the outer box is outside one or both images the measurement for the inner box may still be used. In order to exclude regions that include the gaps or bad data in one or both of the pair of images all pixels in a box must have values between the specified good data limits. Those regions with values outside the limits are eliminated from the intensity matching. The mean fluxes in each region are used to simultaneously fit the relations .nf mean_j = A_ij + B_ij * mean_i .fi for all i and j where i and j are any pair of images. These equations are constrained by the fact that the scaling from image i to j, followed by the scaling from image j to k, must agree with the scaling from image i to image k. The final scaling coefficients reported and stored in the image header are A_1j and B_1j, which correspond to the scalings to the first image in the input list. The task will attempt to reject photometry points which are discrepant. If the task is run interactively it will also show plots of the photometry flux in one image verses another. It does this for sequential pairs of images. Points can be deleted in these plots and they will be excluded from the data used to determine the scaling parameters. When the task is done determining the scaling factors they will be printed and a prompt issued to accept or not accept the results. If the scaling parameters are accepted then the keywords \fBmsczero\fR and \fBmscscale\fR are recorded in the input image header when the "update" parameter is set. Note that the reference image is assigned values of 0 and 1 for these header keywords. .sh 4.4.4 Making the Final Stack Image After \fBmscimage\fR produces single images of each of the dithered mosaic exposures with a common coordinate system grid, a final image is created with the task \fBmscstack\fR. The task \fBmscimatch\fR is generally used to match the intensity scales of the images before this step as described in the previous section. However, for quick reductions or for other reasons the images may be stacked either with no intensity matching or using the "scale" and "zero" options of \fBmscstack\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscstack input = List of images to combine output = Output image (plfile = ) List of output pixel list files (optional) (combine= median) Type of combine operation (median|average) (reject = none) Type of rejection (masktyp= none) Mask type (maskval= 0.) Mask value (blank = 0.) Value if there are no pixels (scale = !mscscale) Image scaling (zero = !msczero) Image zero point offset (weight = none) Image weights (statsec= ) Image section for computing statistics (lthresh= 1.) Lower threshold (hthresh= INDEF) Upper threshold (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 3.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= 0.) ccdclip: CCD readout noise (electrons) (gain = 1.) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (sigscal= 0.1) Tolerance for sigma clipping scaling corrections (pclip = -0.5) pclip: Percentile clipping parameter (grow = 0) Radius (pixels) for 1D neighbor rejection .fi This task is a simple variant of \fBcombine\fR that registers the images using the coordinate systems and has the default threshold parameters set to ignore values below one DN based on the default "blank" value in \fBmscimage\fR for the gaps. If you have also generated bad pixel masks for the resampled images you can exclude them as well by setting "masktype" to "goodvalue". The real art in using this task is deciding how to scale and reject bad data not covered by the bad pixel masks. A "combine" of "median" is the simplest but it does not optimize the signal-to-noise for the number of images. If you "average" the data you will probably want to apply a rejection algorithm such as "avsigclip". Careful flat fielding will make each separate image have the same sky level across the different CCDs. However, the sky levels and transparency may still be varying from exposure to exposure. If you simply combine such data you will see imprints of the gaps. So it is generally a good idea to scale the images. This is done using the "scale" and "zero" parameters which can be set to header keyword values, files containing the values, or special values to compute image statistics in a particular region of the data. The recommended method for scaling is to use the intensity matching task \fBmscimatch\fR described in the previous section and use the image header keywords \fBmscscale\fR and \fBmsczero\fR produced by that task. An example of using this task to create a final image is given below. .nf ms> mscstack @field1 Field1 combine=average rej=avsigclip .fi .endhelp mscred-5.05-2018.07.09/doc/mscguide1.1.hlp000066400000000000000000001754541332166314300173000ustar00rootroot00000000000000.help mscguide Jan98 mscred .sp 3 .ce \fBGuide to the NOAO Mosaic Data Handling Software\fR .ce Francisco Valdes .ce February 1998 .ce MSCRED Version 1.1 .sh Introduction This document discusses handling and reducing CCD mosaic data, particularly data from the NOAO CCD Mosaic Camera, using IRAF and the \fBmscred\fR package. It is not a beginner's guide and assumes some previous experience with IRAF and CCD reductions. The first section discusses the mosaic data format and how to use it in IRAF. This format is more complex than single CCD images because of the multiple CCDs. To keep the data from each exposure self-contained the multiple CCD images are stored in a single file. This multiple image per file has many advantages but it does mean that some commands for dealing with images behave differently. The second section describes the tools used to examine the mosaic data. These tools are used during observing as well as during data reductions. The last section describes the reduction of mosaic data. This includes basic CCD instrumental calibration and combining mosaic exposures into single images. .sh 1. Multiextension FITS Files The data format used by the NOAO Mosaic Data Handling Software is a multiextension FITS (MEF) file. This format is produced by the the Data Capture Agent (DCA) when observing with the NOAO CCD Mosaic Camera. The MEF file for the NOAO Mosaic currently consists of nine FITS header and data units (HDU). The first HDU, called the primary or global header unit, contains only header information which is common to all the CCD images. The remaining eight HDUs, called extensions, contain the images from the eight CCDs. The fact that the image data is stored as a FITS file is not significant. Starting with IRAF V2.11, FITS files consisting of just a single primary image may be used in the same way as any other IRAF image format. The significant feature of the mosaic format is it's multi-image structure. With multiextension FITS files you must either use tasks which are specifically designed to operate on these files as a unit or explicitly specify the image within the file that is to be operated upon by general IRAF image processing tasks. The tasks in the \fBmscred\fR package are designed to operate on the mosaic MEF files and so you only need to specify the filename. For image tasks outside the \fBmscred\fR package you must specify the image in the MEF file using the syntax .nf filename[extension] .fi where "filename" is the name of the MEF file. The ".fits" filename extension does not need to be used in the filename. The image "extension" is specified either using an extension name or the position of the extension in the file (where the first extension is 1). The extension names in the NOAO Mosaic data are "im1" through "im8" for the eight CCDs. Two of the most common tasks that require specifying an image extension are \fBdisplay\fR to display a single CCD image (the task \fBmscdisplay\fR is used to display all the images at once) and \fBimheader\fR to list the header of a particular CCD. So, for example, the following commands might be used. .nf ms> display obj012[im2] 1 ms> imhead obj012[3] l+ .fi Other tasks you may use this way are \fBimexam\fR and \fBimplot\fR. A common question is how to specify a list of extensions. Modification of the syntax to allow wildcard templates in the extension specification is under study. Currently you must specify each extension explicitly, though the filename itself may be a wildcard; for example the first image in a set of files can be collectively specified with .nf obj*[im1] .fi There are two methods for specifying some or all extensions in tasks that operate upon lists of images. One is to make @files. This can be done explicitly with an editor. However the \fBproto\fR task \fBimextensions\fR can expand MEF files into an @file as in the following example. .nf ms> imexten obj012,obj13 > list ms> imhead @list .fi Read the help page for further information, additional parameters, and examples. Another method is to use the special \fBmscred\fR task \fBmsccmd\fR. This task can be used on the command line or as a simple interactive command interpreter. The idea is that you use the special designations "$input" and "$output" for task parameters which allow lists of images. Then lists of MEF filenames are specified for the input and output which are expanded and substituted into the task parameters when it is executed. For example, .nf ms> msccmd "imhead $input l+" input=obj012,obj013 .fi For additional information and examples consult the help page for that task. Note that the tasks \fBimstat\fR and \fBimarith\fR are so useful and common that there are specific \fBmscred\fR tasks \fBmscstat\fR and \fBmscarith\fR that operate on all or a subset of image extensions. So these tasks need not be used with \fBmsccmd\fR or with @files. We conclude with a discussion of the special operations of copying, renaming, deleting, and reading and writing FITS tapes as they apply to the mosaic MEF files. To copy a mosaic file as a unit use \fBcopy\fR, making sure to explicitly specify the "fits" extension. If you use \fBimcopy\fR it will expect you to specify a particular extension and will copy only that extension. While \fBimcopy\fR is not the way to copy an complete MEF file the tasks \fBimrename\fR and \fBimdelete\fR are the commands for renaming and deleting these files; though \fBrename\fR and \fBdelete\fR will also work provided you are explicit with the extension. Finally the mosaic data should be kept as a MEF file and so the the special mosaic tasks \fBmscwfits\fR and \fBmscrfits\fR should be used. The current \fBwfits\fR and \fBrfits\fR are not intended for this type of data. .sh 2. Examining Mosaic Data During observing a small set of IRAF commands are commonly used to examine the data. This section describes these commands. While this section is oriented to examining the data at the telescope during the course of observing, the tools described here are also used when reducing data at a later time. .sh 2.1 Displaying the Data: \fBdisplay\fR and \fBmscdisplay\fR The two commands \fBdisplay\fR and \fBmscdisplay\fR are used to display the data in a display server window. The display server is a separate process which must be running before displaying the images. The observing environment at the telescope will generally have the XIMTOOL display server already running with a window in a separate monitor. If it is not running for some reason it can be started with a menu selection. Away from the telescope you would start XIMTOOL or SAOIMAGE as you do normally. The display server must be told what size "frame buffer" to allocate for holding the display pixels. This determines how many pixels may be loaded at one time. Note that the display window may be smaller than this size and the display server allows you to move the portion viewed and zoom/unzoom any region. If the image size is larger than the frame buffer you can display a portion of the image at full resolution or the full image at a lower resolution. The frame buffer size is queried and set with the commands: .nf ms> show stdimage imt2048 ms> set stdimage=imt1024 .fi There are trade-offs in the frame buffer selection. A large frame buffer allows you to have higher resolution for the large mosaic images but it uses more memory and takes longer to load. The \fBdisplay\fR task is used to display individual images in the display server. This task is a standard IRAF task about which you are assumed to have some basic knowledge. There are many display options which are discussed in the help page. The only special factor in using this task with the mosaic data is that you must specify which CCD image to display using the image extension syntax discussed previously. As an example, to display the central portion of extension im3 in the first frame and the whole image in the second frame: .nf ms> display obj123[im3] 1 fill- ms> display obj123[im3] 2 fill+ .fi The \fBmscdisplay\fR task is based on \fBdisplay\fR with a number of specialized enhancements for displaying mosaic data. It displays the entire mosaic observation in a single frame by "filling" each image in a tiled region of the frame buffer. The default filling (defined by the order parameter) subsamples the image by uniform integer steps to fit the tile and then replicates pixels to scale to the full tile size. The resolution is set by the frame buffer size. As mentioned before, trying to increase the resolution with a larger buffer size has the penalty of longer display times. An example display command is: .nf ms> mscdisplay obj123 1 .fi Many of the parameters in \fBmscdisplay\fR are the same as \fBdisplay\fR and there are also a few that are specific to the task of displaying a mosaic of CCD images. The mapping of the pixel values to gray levels includes the same automatic or range scaling algorithms as in \fBdisplay\fR. This is done for each image in the mosaic separately. The new parameter "zcombine" then selects whether to display each image with it's own display range ("none") or to combine the display ranges into a single display range based on the minimum and maximum values ("minmax"), the average of the minimum and maximum values ("average"), or the median ("median") of the minimum and maximum values. The independent scaling is most appropriate for raw data while the "minmax" scaling is recommend for processed data which are gain calibrated. During data acquisition the \fBmscdisplay\fR task is used to display mosaic data as it is being written to disk by the DCA. It begins execution shortly after the readout begins and displays the portion of the recorded image which has been written to disk. It then alternately waits and displays new data which has been written by the DCA. It continues to sleep and display until all the data has been displayed. The automatic gray level scaling is computed on the initial amount of data. .sh 2.2 Examining the Data: \fBmscexamine\fR The task \fBmscexamine\fR allows interactive examination of mosaic images. It is essentially the same as the standard \fBimexamine\fR task except that it translates the cursor position in a tiled mosaic display into the image coordinates of the appropriate extension image. Line and column plots also piece together the extensions at the particular line or column of the mosaic display. To enter the task after displaying an image the command is: .nf ms> mscexam .fi As with \fBimexamine\fR, one may specify the mosaic MEF filename to be examined and if it is not currently displayed it will be displayed using the current parameters of \fBmscdisplay\fR. .sh 2.3 Examining the Headers: \fBimheader\fR, \fBhselect\fR, \fBccdlist\fR There was discussion earlier concerning the use of generic image tasks with the NOAO Mosaic data. The tasks \fBimheader\fR and \fBhselect\fR fall into this category. The two important points to keep in mind are that you must specify either an extension name or the extension position and that the headers of an extension are the combination of the global header and the extension headers. Often one does not need to list all the headers for all the extensions. The image title and many keywords of interest are common to all the extensions. Thus one of the following commands will be sufficient to get header information about an exposure or set of exposures: .nf ms> imhead obj*[1] l- # Title listing ms> imhead obj123[1] l+ | page # Paged long listing ms> hselect obj*[1] $I,filter,exptime,obstime yes .fi If you need to list header information from all the extensions then you need to take the additional step of creating an @file or using \fBmsccmd\fR. For example to get the default read noise and gain values for each CCD: .nf ms> imextensions obj123 > list123 ms> hselect @list123 $I,rdnoise,gain yes or ms> msccmd "hselect $input $I,rdnoise,gain yes" input=obj123 .fi The \fBccdlist\fR task in the \fBmscred\fR package is specialized for the mosaic data. It provides a compact description of the name, title, pixel type, filter, amplifier, and processing flags. The "extname" parameter may be used to select a particular extension, a set of extensions, or all extensions. Because all extensions should generally be at the same state of reduction it may be desirable to list only the first extension. Like most of the CCD reduction tasks you can also select only a certain type of exposure for listing. Examples of the two modes are: .nf # Summary for all exposures ms> ccdlist *.fits extname=im1 # Summary for all object exposures ms> ccdlist *.fits extname=im1 ccdtype=object # List of all extensions. ms> ccdlist obj123 extname="" .fi .sh 2.4 Determining Best Focus: \fBmscfocus\fR Focus sequence frames can be evaluated for the best focus using the task \fBmscfocus\fR. This displays a focus exposure with \fBmscdisplay\fR (if needed) and then lets you select one or more bright stars to measure. This task is customized so that all you need do is mark the top image in any CCD. For NOAO Mosaic data header information tells the task how many exposures, the spacings between the exposures, and the focus values. After the measurements are made they are displayed and analyzed graphically and written to the terminal and logfile. This task is the mosaic analog of the \fBkpnofocus\fR and \fBstarfocus\fR tasks for single CCD data. .sh 3. Data Reductions The reduction of CCD mosaic camera data can be divided into two stages. The first is the basic calibration of the individual CCDs. This stage is very similar to reducing data from single CCD exposures except that the calibration operations are repeated for all the CCDs in the mosaic. The only significant difference is that any scaling of an exposure, such as in normalizing the flat field calibration, must be done uniformly over all the CCDs. The details of repeating the calibrations for all CCDs and the scaling of the calibration data are taken care of by the software and the data format so that these operations appear the same as with single CCD data. There is one step of the basic CCD calibration stage which has generally been ignored or forgotten with smaller single CCD formats. The large field of view provided by a mosaic and the optics required to provide it can lead to a significant variation in the pixel scale. This effect is important with the NOAO 4meter telescopes and is also present in the NOAO 36inch data to a smaller degree. It is likely to be present in other telescopes as well. When the pixel scale varies significantly the standard flat field calibration operation will cause the photometric zero point to vary. A simple calibration step can be performed to remove this effect. However, if you intend to produce single images from the mosaic of CCDs this step is not necessary since the resampling operation naturally accounts for this effect. The second stage of data reductions is unique to mosaic data. This stage is the combining of the multiple CCD images and multiple exposures into a single image. Since creating a single image from a single mosaic exposure is of marginal value, the thrust of this stage of the reductions is the combining of multiple exposures which have been spatially offset or "dithered" to cover both the gaps between the individual CCDs and any defects (which are quite extensive in the "engineering grade" CCDs of the first NOAO Mosaic Camera). The steps required to produce a single deep integration from dithered exposures consists of accurately registering the images, mosaicking the exposures into single images with the same spatial sampling, measuring changes in the intensity scale due to variations in transparency and sky brightness, and combining the individual images into a single deep image with the gaps and bad pixels removed. .sh 3.1 Some Preliminaries The command \fBsetinstrument\fR is used to set default parameters for the tasks in the \fBmscred\fR package appropriate to a particular instrument. For users of the NOAO Mosaic Camera it is recommended you run this command the first time you reduce data. Subsequently you should not do this since it will reset parameters you later changed. To set the parameters for reducing the NOAO Mosaic data type the command .nf ms> setinstrument 4meter review- .fi Substitute "36inch" for "4meter" if the data is from the Kitt Peak 0.9 meter telescope. For some of the operations it is useful to specify lists of exposures corresponding to a dither set. The examples in this guide show using using @files for dither sets. An @file is simply a list of filenames. These can be created in several ways including using a text editor. One way is with the \fBfiles\fR command to expand a file template. For example, .nf ms> files obj021,obj022,obj023,obj024,obj025 > field1 ms> dir @field1 obj021 obj002 obj003 obj004 obj005 .fi .sh 3.2 Basic CCD Calibration Basic CCD instrumental calibrations consist of correcting each CCD for electronic bias levels, zero exposure patterns, dark counts, and pixel sensitivities. A cosmetic replacement of bad pixels may also be included. An additional calibration is required to correct for the variable pixel scale across the field of view if you intend to do photometry on the individual CCD images. .sh 3.2.1 Calibration Data to Obtain At the Telescope Good data reductions begin with obtaining good calibration data at the telescope. This section discusses the NOAO CCD Mosaic Camera but the general principles will apply to other detectors, though the relative importance of the different calibration will depend on the quality of the CCDs. The first generation (engineering grade) NOAO Mosaic CCDs operate at warmer temperatures than usual, so good dark count exposures (darks) are required in addition to the usual zero level exposures (zeros). Further, we recommend that you obtain darks with exposures similar to your science exposures. While many of the CCD features will scale with time, there are regions of charge overflow that may not be completely linear. Dome flat fields (dome flats) provide a fair basic flattening of the data to 2% or so, but dark sky flat fields (sky flats) or illumination corrections will be required to produce dithered data that can be combined without introducing obvious artifacts. Dark sky flats can flatten the data to 0.1%. We currently lack experience with twilight flats so we cannot comment on them. The default NOAO Mosaic dither pattern is a sequence of 5 exposures designed to insure at least 80% coverage for all portions of an astronomical image, given the gaps between the CCDS \fIand\fR many of the large defects, which in a number of cases are even wider than the gaps. Other things to be aware of include the small wells and nonlinear response of CCD 4. This chip saturates at only ~4X10^4 e^-, and becomes nonlinear by more than 1% above 1.5X10^4 e^-. At this time we are investigating the nonlinearity, which is unexpected, but the full well still sets a hard limit to the exposure level. In contrast, the other 7 CCDs appear to be highly linear up to this exposure level, and have much larger wells. Lastly, good astrometry is required to register and stack the Mosaic images. We have excellent solutions for the R and V band filters (which are automatically included in the data taken at the telescope), but the scale varies slightly with color, so you may want to image an astrometric field if you are using filters not bracketed by these colors. However, simple scaling of the default solutions can be done either to register data between filters or to register to a few stars with known coordinates to achieve quite good astrometry. So astrometric calibrations are not critical. Note that this guide and other documentation does not yet discuss how to create the coordinate system solutions and the Mosaic support team will eventually supply solutions for all of the filters. .sh 3.2.2 Preparing Calibration Data This section describes how to prepare the basic calibration data. The steps are virtually the same as with the \fBccdred\fR package and, in fact, the command names and parameters are the same. The basic calibration data of zero level, dark count, and dome or projector flat fields are generally taken as a sequence of identical exposures which are combined to minimize the noise. A later section discusses preparing a sky flat field calibration using the object exposures or twilight exposures. The calibration exposures are individually reduced by \fBccdproc\fR and then combined. Thus, it is necessary to first set the \fBccdproc\fR parameters. Because this task knows which operations are appropriate for particular types of calibration exposures you can set all the parameters. Below is a typical set of parameters. The main optional setting is whether or not to replace bad pixels by interpolation, which is purely a cosmetic correction. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = ccdproc images = List of Mosaic CCD images to process (ccdtype= object) CCD image type to process (noproc = no) List processing steps only? (oversca= yes) Apply overscan strip correction? (trim = yes) Trim the image? (fixpix = no) Apply bad pixel mask correction? (zerocor= yes) Apply zero level correction? (darkcor= yes) Apply dark count correction? (flatcor= yes) Apply flat field correction? (sflatco= no) Apply sky flat field correction? (biassec= !biassec) Overscan strip image section (trimsec= !trimsec) Trim data section (fixfile= ) List of bad pixel masks (zero = Zero) List of zero level calibration images (dark = Dark) List of dark count calibration images (flat = Flat*) List of flat field images (sflat = Sflat*) List of secondary flat field images (minrepl= 1.) Minimum flat field value (interac= no) Fit overscan interactively? (functio= legendre) Fitting function (order = 1) Number of polynomial terms or spline pieces (sample = *) Sample points to fit (naverag= 1) Number of sample points to combine (niterat= 1) Number of rejection iterations (low_rej= 3.) Low sigma rejection factor (high_re= 3.) High sigma rejection factor (grow = 0.) Rejection growing radius .fi The first step is generally to process and combine sequences of zero, dark, and dome flat exposures. This is done using the tasks \fBzerocombine\fR, \fBdarkcombine\fR, and \fBflatcombine\fR. The combining must be done in the following order since the processing of later calibration data requires the preceding calibration data. .nf ms> zerocombine *.fits ms> darkcombine *.fits ms> flatcombine *.fits .fi Each of these tasks search for all exposures of the particular type so it is fine to specify all files. Also \fBflatcombine\fR has the feature that it will combine the data separately for each filter. However, you can use explicit file lists, templates, or @files to limit the input files. The output combined names have some standard default values which the above settings for \fBccdproc\fR use. It is a good idea to first check that the different calibration types and filters are correctly identified by the software. This is done using the \fBccdlist\fR command .nf ms> ccdlist *.fits extname=im1 .fi Unless you change the parameters \fImscred.backup\fR and \fImscred.bkuproot\fR the original raw files will be saved in the subdirectory "Raw/". If you want to start over, delete the processed files and copy the raw files back to the working directory. If disk space is a concern and you are satisfied with the combined calibration files you can delete the individual processed calibration files. There is a parameter in the combining tasks that will delete the individual files automatically after processing and combining. .sh 3.2.3 Object Exposure Reductions At this point you will have some subset of combined zero level, dark count, and flat field calibration data. The calibration data is applied to the object exposures, either in bulk or as observations are completed, using the task \fBccdproc\fR. The command is simply .nf ms> ccdproc .fi .sh 3.2.4 Dark Sky or Twilight Sky Flat Fields You will notice that there are two flat field corrections which can be performed by \fBccdproc\fR. The first one is for an initial flat field such as the dome flat obtained at the beginning of the night, a standard flat field from a previous night or run, or a final combined dome flat and sky flat from some other night or run. The second is for a dark sky or twilight sky flat field prepared from the object exposures after they have been calibrated with the first flat field. Sky flat fields are created by combining object exposures with objects removed by using data in each pixel that is only sky. In principle one could use exposures of the twilight sky. We have no experience with this type of sky flat. You are welcome to take some exposures and try using them. We have found that dark sky flat fields derived from the object exposures do work quite well. Mosaic observations already typically dither a field. One will do even better by combining observations from other fields. The more data used the better the resulting sky flat will be. The main criterion for including data is to avoid observations contaminated by varying background light from the moon or scattered light from bright stars off the field. Of course, another factor that has to be considered is whether a field has a very large extended object which appears in many of the observations. These will not be useful. The sky flat field is created using the task \fBsflatcombine\fR with parameters selected to reject objects appearing above a median. We don't have much experience with creating sky flats currently so some experimentation with parameters may be required. Below is one possibly set of parameters. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = sflatcombine input = List of images to combine (output = Sflat) Output sky flat field root name (combine= average) Type of combine operation (reject = avsigclip) Type of rejection (ccdtype= object) CCD image type to combine (subsets= yes) Combine images by subset parameter? (scale = mode) Image scaling (statsec= ) Image section for computing statistics (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 6.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= rdnoise) ccdclip: CCD readout noise (electrons) (gain = gain) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (pclip = -0.5) pclip: Percentile clipping parameter (blank = 1.) Value if there are no pixels (grow = 3.) Radius (pixels) for neighbor rejection .fi This task is a combination of \fBccdproc\fR to first process the images, if they have not previously been processed, and \fBcombine\fB to combine the offset images with rejection of object pixels. A new feature of this package is the \fIgrow\fR parameter which now provides a two dimensional circular rejection of pixels around pixels rejected by the rejection algorithm selected. Whatever rejection algorithm is used it is likely that the best results will be when the clipping sigmas are non-symmetric as shown above. Note that a very low rejection threshold or very large grow radius will make the task quite slow. After producing a good sky flat that has no evidence of objects it may be applied directly to the data by using it as the second flat field correction. .nf ms> ccdproc sflatcor=yes sflat=Sflat* .fi Note that the object exposures used in creating the sky flat will already have been processed except for the application of the sky flat so \fBccdproc\fR will only apply the sky flat field calibration. The sky flat field includes corrections at all scales from pixel-to-pixel sensitivity variations to large scale illumination differences. If the signal-to-noise is poorer than the dome flat field you might wish to apply a filtering/smoothing operation to the sky flat data thus relying on the dome flat field for the pixel-to-pixel sensitivity calibration and the sky flat field for larger scale illumination corrections. There are a number of filtering tasks in IRAF. A median is a good filter and there is the choice of a ring median or box median. To apply one of these general filtering tasks you would use \fBmsccmd\fR to run it on all the CCDs .nf ms> msccmd msccmd: median $input $output 10 10 Input files: SflatV Output files: SflatMedV msccmd: q .fi Because the object exposures are first processed with the dome flat (or other flat field) you would normally run \fBccdproc\fR again on the data using the sky flat and any observations that have not been processed at all will use both the dome flat and the sky flat. However, if you want to make a single flat field to apply to raw data, say if starting over or using it for a second night, you can combine the two flat field corrections into a single flat field to be used as the only flat field correction. This is done by multiplying the two flat fields using \fBmscarith\fR .nf ms> mscarith FlatV * SflatV FinalflatV .fi .sh 3.2.4 The Variable Pixel Scale and Zero Point Uniformity A key assumption in the traditional reduction of CCD images is that the pixel scale is uniform and that a properly reduced blank sky image will have a uniform and flat appearance. Unfortunately, this is not correct when the pixel scale varies over the field. In the case of the NOAO Mosaic at the Mayall 4meter, the pixel scale decreases approximately quadratically from the field center, with the pixels in the field corners being 6% smaller in the radial direction, and 8% smaller in area. Pixels in field corners thus would properly detect only 92% of the sky level seen in the field center, even with uniform sensitivity. At the same time the same number of \fItotal\fR photons would be detected from a star regardless of how many pixels the PSF would be distributed over. Forcing the sky to be uniform over the image has the deleterious effect of causing the photometric zeropoint to vary from center to field corners by 8%. Note that this effect is different from vignetting where the flux actually delivered to the image margins is less than that at the center, an effect that \fIis\fR corrected by the flat field. In practice, the photometric effect of the variable pixel scale can be ignored provided that the reduced images will be part of a dither-sequence to be stacked later on. As discussed below, prior to stacking the images, they first must be re-gridded, which produces pixels of essentially constant angular scale. This is done with the \fBmscimage\fR task, which re-grids the pixels and has a "flux conservation" option that can scale the pixels photometrically by the associated area change. If this function is disabled, then "improperly" flattened images will have a uniform zero point restored. In short, the flat field adjusted (if inappropriately) for the different pixel sizes, so \fBmscimage\fR would then do no further adjustment. Stars would be too bright in the corners of the flattened images, but after re-gridding, their total fluxes would be seen to be scaled down to the appropriate values. If the Mosaic images are to be analyzed individually, however, as might be done for standard star fields, then after the flat field reductions are complete, the differential scale effects must be restored. At present we are in the process of developing a routine in the \fBmscred\fR package to do this, without actually re-gridding the image with \fBmscimage\fR (which can also be done with images not part of a dither-set). The correction process is simple; the scale at any point in the Mosaic field is already known from the astrometry, so one just calculates and multiplies by the correction. The final image would appear to have a variable sky level, but would be photometrically uniform. .sh 3.3 Coordinate Calibration For some projects the basic flux calibrated CCD exposures may be all that is required. However, if you want to obtain coordinate information or combine multiple exposures which are dithered on the sky or taken with different filters then you must calibrate the celestial world coordinate system (WCS) of the data. This may be done in an absolute or relative sense; an absolute calibration ties the data coordinates to catalog coordinates while a relative calibration ties multiple exposures to the same coordinates. Determining the WCS from scratch is a complicated business and requires special observations of astrometry fields. However, for NOAO Mosaic data a standard coordinate calibration determined earlier is automatically inserted into your data by the data capture agent. The calibration consists of an approximate "linear" solution in each header and a reference to a complete "plate" solution database that is part of the \fBmscred\fR package. [In the future the plate solution will be recorded in the header to provide the full coordinate system accuracy and to eliminate the tie to an external file.] The default coordinate system is sufficiently accurate for most purposes and just requires some small adjustments as described below. To piece a single exposure into a single image that does not require registration to any other data you may use the default WCS and skip the WCS calibration steps. The WCS is a mapping from pixels in the mosaic data to celestial coordinates relative to a reference point on the sky. The reference point, or zero point, is set using the telescope pointing coordinate. The telescope pointing is generally off by a small amount, though it could be completely wrong in some hardware/software error situations. In addition, differential atmospheric refraction introduces small axis scale changes and rotations, which are significant due to the large field of view of the mosaic even during the course of single set of dithered exposured. Putting observations from different filters onto the same coordinate system also requires mapping small scale changes since currently there is only a single standard WCS solution derived through one filter. [In the future filter dependent solutions will be made available.] The WCS calibration operations consist of adjusting the standard coordinate system calibration to a desired the zero point and applying small axis scale changes and rotations. This is done using objects (usually stars) in the exposures. Unlike a full WCS calibration, which requires a high density of stars with accurate catalog coordinates, the adjustments to the default WCS calibration require only a few objects; only one objects is needed to provide a zero point correction. The WCS adjustments are determined by specifying coordinates for one or more objects in the data. The coordinates can be obtained from a reference catalog or, more commonly, by measuring coordinates from one reference exposure to which other exposures are to be "registered". A combination of using a catalog coordinate for one object in the field to set the zero point in a reference exposure and then measuring the positions of other stars in the reference image based on that zero point calibration may also be done. The two tasks you will use are \fBmsczero\fR and \fBmsccmatch\fR. \fBMsczero\fR is used to interactively set the zero point of the coordinates, register multiple exposures closely, and generate a list of coordinates in a reference exposure to which other exposures in a dither set are registered. \fBMsccmatch\fR finds objects at the positions specified by a list of coordinates and determines corrections for the zero point, axis scale change, and axis rotation. .sh 3.3.1 Setting Coordinate Zero Points and Measuring Coordinates \fBMsczero\fR is an interactive display task for mosaic exposures that allows measuring coordinates and adjusting the WCS zero point. The task parameters are shown below. The last set of parameters are for the task to query and maintain lists. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msczero images = List of mosaic exposures (nframes= 2) Number of frames to use (logfile= default) Log file for measurements ra = RA (hours) dec = DEC (degrees) update = yes Update WCS zero point? (fd1 = ) (fd2 = ) .fi The task displays each exposure in the list, in turn, and responds to cursor key commands. You can go forward and backward through the input list or quit at any point. The exposures are displayed by cycling through the number of frames starting with the first frame. As an aid to efficiency, if the exposure is already loaded in the appropriate frame then the display step is skipped. This task has several uses (type '?' to get the list of command options). .nf 1. Set the WCS zero point by specifying the coordinate of a star. 2. Create a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. 3. Report coordinates at the cursor position. .fi It may be that the WCS zero points, based on the telescope pointing coordinates, are accurate enough that you can use this task on only a reference exposure to generate a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. However, because it is fairly quick to explicitly check and set the zero point of all the exposures in a dither set to the same coordinate for a common reference star it is recommended you do this first. To check and set the zero points for a set of dithered exposures run \fBmsczero\fR with a list of the exposures .nf ms> msczero @field1 .fi After the first exposure is displayed either find a reasonably bright unsaturated star which will be in all the exposures or find a star whose coordinate is known from a catalog such as the HST Guide Star Catalog. Move the cursor to the star and type 'z' (zero) to invoke a centering algorithm. Note that even though the exposure may be displayed at lower resolution the centering is done with the full resolution data. The task will then tell you what it thinks the coordinate is and ask you for a new coordinate. The first time 'z' is typed it will prompt with the measured coordinate and thereafter it will prompt with the last entered value. If you are referencing all the exposures to the first exposure in the list accept the measured coordinate (and write the value down in case you need it later) otherwise enter the desired coordinate. Note that all further measurements of the image will automatically apply the measured zero point correction but the exposure WCS is not actually updated until you type 'n' (next) or 'q' (quit). If you want to print coordinates without changing the zero point correction use the space bar or 'c' (center) to center on an object and print the centered coordinate. If you changed the WCS zero point you will shown the zero point offsets and given the option to update the WCS in the data file when you type 'n'. Then the next exposure in the list will be displayed. Find the same star and type 'z' again. Since it will retain the last entered coordinate you should only need to accept the prompted coordinates. When you have done this for all the exposures their coordinate systems will be registered at least at that point. The WCS in the dither set may still not be registered all over the field due to refraction effects. Also the intensity scales of the dithered exposures may not be the same due to changes in transparency and sky brightness. These effects are calibrated by matching objects throughout the field in position and brightness. This requires a list of coordinates tied to one of the dithered exposures as a reference. Usually the first exposure in the set is used as the reference. \fBMsczero\fR is used to create a list from objects in the reference exposure. .nf ms> msczero obj021 .fi Select objects, usually stars, throughout the field and type 'x' for each one. This will center on the object and and record the coordinate in a logfile. The default logfile name "default" creates a log file beginning with "Coords." and followed by the name of the exposure. In the example this will be "Coords.obj021". To be useful for coordinate matching this list should have a good number of stars, say three or four from each CCD, with emphasis on the field edges but allowing for the dithering. For the intensity matching you want to have stars with a range of brightness (though not saturated or extremely faint) and which are mostly isolated so that a region around them may be used for sky. The lists for the coordinate and intensity matching do not have to be the same but it is reasonable to just create one list. .sh 3.3.2 Matching Coordinate Systems The task \fBmsccmatch\fR determines and applies a linear correction to the WCS to match objects, generally stars, in an exposure to a set of reference celestial coordinates. This correction maintains the detector geometry and optical distortions while adjusting for changes in apparent sky position such as produced by atmospheric refraction and telescope pointing errors. The linear correction consists of a zero point shift, scale changes in the right ascension and declination axes, and rotations of the axes. To use this task you need a list of reference celestial coordinates, right ascension in hours and declination in degrees, and the mosaic exposure coordinate system must be relatively close to the reference coordinate system. The default WCS plus telescope pointing may be close enough, but if not you would use \fBmsczero\fR to register the zero points at some point in the exposures. Since it is relatively simple to register a set of dithered exposures to a common star with \fBmsczero\fR this is recommended procedure before using \fBmsccmatch\fR. The reference coordinates should cover all of the mosaic field of view to be sensitive to the small rotation and scale effects. The coordinate list might be obtained from a catalog or measured from one of the exposures to which other overlapping exposures will be matched. For the purposes of making a well aligned stacked image from a set of dithered exposures one generally uses one of the exposures as the source of the reference coordinates. \fBMsccmatch\fR operates on a set of input mosaic exposure in turn. For an exposure it converts each input celestial coordinate to a pixel coordinate in one of the extensions using the current WCS. If the the coordinate does not fall in any extension the coordinate is not used. The pixel coordinate is used as a starting point for the \fBapphot.center\fR task. If the centering fails for some reason, such as the object being too near the edge or the final position being too far from the initial position, the coordinate is not used. For those objects successfully found a fit is made between the original celestial coordinates and the measured coordinates expressed as arc seconds from the exposure tanget point. The fit is constrained to yield some combination of shift, scale change, and rotation for each of the celestial coordinate axes. These parameters are then used to update the exposure WCS so that the adjusted measured coordinates best agrees with the reference coordinates. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msccmatch input = List of input mosaic exposures coords = Coordinate file (ra/dec) (nfit = 4) Min for fit (>0) or max not found (<=0) (rms = 2.) Maximum fit RMS to accept (arcsec) (maxshif= 5.) Maximum centering shift (arcsec) (fitgeom= rxyscale) Fitting geometry (update = yes) Update coordinate systems? (interac= yes) Interactive? (fit = yes) Interactive fitting? (verbose= yes) Verbose? accept = yes Accept solution? .fi The input are a list of mosaic exposures and a file of reference celestial coordinates. The exposures should all include a significant number of objects from the list of coordinates. The task can be run interactively or non-interactively based on the \fIinteractive\fR parameter. In interactive mode you can graphically interact with the fitting (selected with the \fIfit\fR parameter) and accept or reject a fit based on the printed fit parameters. The fitting is done using the task \fBgeomap\fR and the interactive mode allows you to view the distribution of coordinates, residuals verses the input coordinates, delete bad values, and possibly change the fitting constraints (see the help for \fBgeomap\fR for more information). The linear transformation may be constrained by the \fIfitgeometry\fR parameter as described in the help for \fBgeomap\fR. This may be desirable if there are only a few coordinates or if you want to impose some physical assumption. Note that the effects of atmospheric refraction actually do cause independent scale changes and rotations in the two axes so the default "rxyscale" should be used. There are a some conditions which are placed on the task. The \fImaxscale\fR parameter limits how far the objects may be found from the initial coordinates. This constraint protects against incorrect identifications and tells the centering routine how much of the image to look at. This parameter should be as small as possible consistent with the errors in the WCS. If you first zero the coordinates then the objects should be found quite close to the initial coordinates. When the \fIverbose\fR parameter is set the results of the centering will be printed consisting of the image extension name, the final pixel coordinates, the shift in pixel coordinates from the initial value, and the formal uncertainties in the pixel coordinates. If an error occurs one of the error codes from \fBapphot.center\fR will be reported such as "BigShift" for objects with too big a shift from the initial position and "EdgeImage" for objects to near the edge of the image. The \fInfit\fR parameter requires a certain number of coordinates to be included in the fit. If specified as a negative number the parameter is interpreted as a maximum number that may be lost from the input list due to being off the exposure or failing to be centered. The \fIrms\fR parameter requires that the final RMS of the residuals about the fit for each axis be less than a certain value. .sh 3.4 Putting the Pieces Together This section tells you how to make single images from each exposure and how to combine sets of dithered images into a final deep image free from gaps and artifacts. Obtaining good results depends on having well-flattened data, a uniform sky, a dither pattern that samples the gaps and bad regions of the detectors, and accurately registered world coordinates. Most difficulties are caused by variable sky conditions or scattered light within a dither sequence or the data used to create a sky flat. .sh 3.4.1 Constructing Single Images Making a single image from a mosaic exposure is done by mapping the pixels from each extension to a single uniform grid on the sky. The WCS calibrations described in previous sections provide this. For making a single image from a single exposure the WCS calibration is not critical and the default WCS is sufficient. For combining multiple dithered exposures all the exposures must be registered to a common coordinate system, either relative to one reference exposure or to a set of catalog stars, and each exposure must be resampled to the same final coordinate system. The task that makes single images from mosaic exposures is \fBmscimage\fR. It's parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimage input = List of input Mosaic exposures output = List of output images (referen= ) Reference image (pixmask= no) Create pixel mask? (verbose= )_.verbose) Verbose output? # Resampling parmeters (blank = 0.) Blank value (interpo= linear) Interpolant (nearest,linear,poly3,poly5,spline3) (fluxcon= no) Preserve flux per unit area? (ntrim = 7) Edge trim in each extension (nxblock= 2048) X dimension of working block size in pixels (nyblock= 1024) Y dimension of working block size in pixels # Geometric mapping parameters (interac= no) Fit mapping interactively? (wcssol = yes) Use WCS plate solution? (nx = 10) Number of x grid points (ny = 20) Number of y grid points (fitgeom= general) Fitting geometry (functio= chebyshev) Surface type (xxorder= 4) Order of x fit in x (xyorder= 4) Order of x fit in y (xxterms= half) X fit cross terms type (yxorder= 4) Order of y fit in x (yyorder= 4) Order of y fit in y (yxterms= half) Y fit cross terms type .fi An output image is created for each input mosaic exposure. The output image is created with a coordinate system defined by the specified \fIreference\fR image. If no reference image is specified then the first input mosaic exposure is used to define a simple tangent plane coordinate system with optical distortions removed and that coordinate system is used for all the input mosaic exposures. The important point is that for a set of dithered exposures all the output images must be created with the same coordinate system grid so that they may be combined by simple integer shifts along the image axes. The normal usage is to specify all the mosaic exposures in a dither set as the input, give a matching list of output images, and leave the reference image unspecified. If all the exposures in a dither set are not done at the same time then you must specify one of the earlier output images as the reference image to continue to create the output images on the same coordinate grid. The output images are created with a size that just covers the input data and initially filled with the specified \fIblank\fR value. This is the value that the mosaic gaps will have in the final output image. Then each extension is resampled into the approprate part of the output image. The coordinate mapping is generated by \fBgeomap\fR using the geometric mapping parameters which you don't need to change. The resampling is done with the specified interpolation function. Linear interpolation is the fastest and most straightforward. Other interpolation functions are available and new ones, such as sinc, are under development. The small rotations in the CCDs produce edge effects in the interpolated output pieces so a small trim is required to eliminate these. It is useful for the later combining step to make bad pixel masks that reflect the interpolation and resampling from the input data. These may be created by setting the \fIpixmask\fR parameter. If this parameter is set and the input mosaic data have bad pixel masks defined through the header BPM keywords (default bad pixel masks are provided in the NOAO Mosaic data) then the masks will be interpolated in exactly the same way as the data. The interpolated masks will appear in the working directory with names related to the output image names and with the output images containing the BPM keyword pointing to these masks. The input bad pixel masks are assumed to have zero for good data and one for bad data and the output masks have zero for good data and values between zero and one thousand for bad data. The value is the result of interpolation and reflects the relative contribution of good and bad data. The \fIfluxconserve\fR parameter applies a pixel area correction if selected. As discussed earlier, standard flat fielding distorts the flux per unit area in pixels of different projected size by making them have the same flux per pixel. In effect this applies half of the flux conservation operation by adjusting the pixel values without adjusting the pixel sizes. \fBMscimage\fR does the second half by adjusting the pixel sizes. So for standard flat fielded data, the usual route to making a combined dithered image, the flux conservation parameter should not be used to arrive at a proper final flux per unit area in the resampled data. Flux conservation would only be used if the input mosaic data has previously been corrected back to proper flux per unit area through adjustment of the flat field or data for the variable pixel size inherent in the mosaic coordinate system. Below are two examples; one using prepared @files and one illustrating advanced usage of filename templates. .nf ms> mscimage @dither1 @outdither1 pixmask+ ms> mscimage obj02![2-5]* %obj%mos%02![2-5]* pixmask+ .fi In the second example the input template expands to obj022.fits to obj025.fits and the output template matches the input template using the first part of the %% substitution field and then replaces the "obj" with "mos" to give output images mos022.fits to mos025.fits. .sh 3.4.2 Matching Intensity Scales When stacking dithered exposures (the single images created in the previous step) to fill in the mosaic gaps and remove bad pixels and cosmic ray events it is critical that the intensity scales of the images match. Otherwise you will see artifacts from the gaps, places with bad data, and around objects as the combined intensity level jumps when data from an exposure is missing or rejected. Also the rejection algorithms require that the image intensities match both at the sky level and in objects. There are two parameters that must be determined to match the intensity scales. One is a additive offset caused by sky brightness variations. The second is a multiplicative scale change caused by transparency and exposure time variations. Matching the intensity scales for a set of dithered exposures consists of determining values for these two scaling parameters relative to a reference exposured and setting them in the image headers. The actual adjustment of the pixels values occurs when stacking the exposures. The intensity matching values are determined by the task \fBmscimatch\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimatch input = List of input images coords = Coordinates (referen= ) Reference image (box1 = 21) Box size for statistics (box2 = 51) Box size for statistics (lower = 1.) Lower limit for good data (upper = INDEF) Upper limit for good data (update = yes) Update images? (interac= yes) Interactive? (fit = yes) Fit interactively? (verbose= yes) Verbose? accept = yes Accept scaling? .fi The input consists of a list of images to be matched and a file of celestial coordinates (RA in hours and DEC in degrees) to use in computing the matching parameters. The input images are the single images constructed from the mosaic exposures for a set of dithered observations. The reference image to use may be specified explicitly otherwise the first image in the input list is used. Of course, all the images in the dither set must be matched relative to the same reference image. The scaling parameters are determined by measuring the mean flux in a set of matching regions between each input image and the reference image. The centers of the regions are specified by their celestial coordinates. The list of coordinates should consist of the positions of objects in the field. These objects should span a range of brightness. As noted previously, you would normally use the same coordinate list as used with \fBmsccmatch\fR, which is generally obtained using \fBmsczero\fR. However, you can use any IRAF task that produces a list of celestial coordinates from images with a WCS. One possibility is to use \fBrimcursor\fR on one of the displayed single images with the \fIwcs\fR parameter set to "world" and the \fIwxformat\fR set to "%.2H" to produce right ascension values in hours instead of degrees. The now accurately aligned coordinate systems in the images are used to identify the matching pixel coordinate center in each image. The regions to be measured consist of square boxes of the specified sizes about the pixel coordinate center. There are two boxes, an inner box and an outer box which excludes the inner box. The box sizes are intended to define photometry apertures for the objects and nearby background. It is not critical that they exactly fit the objects or that the objects necessarily be stars but this is usually how they will be set. Because of possible PSF variations the inner box should be large enough include all the light from stars over the whole data set. If the inner box is not fully contained in the input or reference image that box is not used for that pair. Similarly the outer box must be fully contained in the images but if only the outer box is outside one or both images the measurement for the inner box may still be used. In order to exclude regions that include the gaps or bad data in one or both of the pair of images all pixels in a box must have values between the specified good data limits. Those regions with values outside the limits are eliminated from the intensity matching. The mean fluxes in each region are used to fit the relation .nf mean(reference) - mean(input) = A + (B - 1) * mean(input) .fi This formulation is chosen so that one may constrain the fit to just finding A (the zero point offset) or both the zero point and scale. The fitting is done using the task \fBcurfit\fR. If both the \fIinteractive\fR and \fIfit\fR parameters are set then this task is excuted interactively and you can examine the fit and delete bad points and refit. Remember that what is plotted is the reference minius input flux verses input flux. You may change the fitting order to 1 to just fit the zero point offset or to 2 to fit the zero point and intensity scale. Any higher order is not allowed. You may delete points and turn on iterative rejection but these do not carry across to the next execution. If the interactive fitting is not selected but the task is run interactively or with the \fIverbose\fR parameter set a plot is produced of the fit. In verbose or interactive mode the result of the fit is printed with the offset adjusted to give the offset at the indicated reference intensity from the minimum reference image mean flux used (i.e. indicative of the offset at the sky level). In interactive mode you may then accept or reject the result. If the scaling parameters are accepted then the keywords \fBmsczero\fR and \fBmscscale\fR are recorded in the input image header when the \fIupdate\fR parameter is set. Note that the reference image is assigned values of 0 and 1 for these header keywords. .sh 3.4.2 Making the Final Stack Image After \fBmscimage\fR produces single images of each of the dithered mosaic exposures with a common coordinate system grid a final image is created with the task \fBmscstack\fR. The task \fBmscimatch\fR is generally used to match the intensity scales of the images before this step as described in the previous section. However, for quick reductions or for other reasons the images may be stacked either with no intensity matching or using the \fIscale\fR and \fIzero\fR options of \fBmscstack\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscstack input = List of images to combine output = Output image (plfile = ) List of output pixel list files (optional) (combine= median) Type of combine operation (median|average) (reject = none) Type of rejection (masktyp= none) Mask type (maskval= 0.) Mask value (blank = 0.) Value if there are no pixels (scale = !mscscale) Image scaling (zero = !msczero) Image zero point offset (weight = none) Image weights (statsec= ) Image section for computing statistics (lthresh= 1.) Lower threshold (hthresh= INDEF) Upper threshold (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 3.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= 0.) ccdclip: CCD readout noise (electrons) (gain = 1.) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (sigscal= 0.1) Tolerance for sigma clipping scaling corrections (pclip = -0.5) pclip: Percentile clipping parameter (grow = 0) Radius (pixels) for 1D neighbor rejection .fi This task is a simple variant of \fBcombine\fR that registers the images using the coordinate systems and has the default threshold parameters set to ignore values below one DN based on the default \fIblank\fR value in \fBmscimage\fR for the gaps. If you have also generated bad pixel masks for the resampled images you can exclude them as well by setting \fImasktype\fR to "goodvalue". The real art in using this task is deciding how to scale and reject bad data not covered by the bad pixel masks. A \fIcombine\fR of "median" is the simplest but it does not optimize the signal-to-noise for the number of images. If you "average" the data you will probably want to apply a rejection algorithm such as "avsigclip". Careful flat fielding will make each separate image have the same sky level across the different CCDs. However, the sky levels and transparency may still be varying from exposure to exposure. If you simply combine such data you will see imprints of the gaps. So it is generally a good idea to scale the images. This is done using the \fIscale\fR and \fIzero\fR parameters which can be set to header keyword values, files containing the values, or special values to compute image statistics in a particular region of the data. The recommended method for scaling is to use the intensity matching task \fBmscimatch\fR described in the previous section and use the image header keywords \fBmscscale\fR and \fBmsczero\fR produced by that task. An example of using this task to create a final image is given below. .nf ms> mscstack @field1 Field1 combine=average rej=avsigclip .fi .endhelp mscred-5.05-2018.07.09/doc/mscguide2.0.hlp000066400000000000000000002575421332166314300172770ustar00rootroot00000000000000.help mscguide Sep98 mscred .sp 3 .ce \fBGuide to the NOAO Mosaic Data Handling Software\fR .ce Francisco Valdes .ce September 1998 .ce MSCRED Version 2.0 .sh Sections .nf 1. Introduction 2. Multiextension FITS Files 3. Examining Mosaic Data 3.1 Displaying the Data 2.1.1 On-the-Fly (OTF) Calibration 2.1.2 Real-Time Display with the DCA 3.2 Examining the Data 3.3 Examining the Headers 3.4 Determining Best Focus 4. Data Reductions 4.1 Some Preliminaries 4.2 Basic CCD Calibration 4.2.1 Calibration Data to Obtain At the Telescope 4.2.2 Preparing Calibration Data 4.2.3 Pupil Image Removal from Flat Fields 4.2.3.1 Broadband Data 4.2.3.2 Narrowband Data 4.2.4 Object Exposure Reductions 4.2.5 Pupil Image Removal from Object Data 4.2.5.1 Broadband Data 4.2.5.2 Narrowband Data 4.2.6 Dark Sky or Twilight Sky Flat Fields 4.2.7 The Variable Pixel Scale and Zero Point Uniformity 4.3 Coordinate Calibration 4.3.1 Setting Coordinate Zero Points and Measuring Coordinates 4.3.2 Matching Coordinate Systems 4.4 Putting the Pieces Together 4.4.1 Removing Sky Gradients 4.4.2 Constructing Single Images 4.4.3 Matching Intensity Scales 4.4.4 Making the Final Stack Image .fi .sh 1. Introduction This document discusses handling and reducing CCD mosaic data, particularly data from the NOAO CCD Mosaic Imager (referred to here as the NOAO Mosaic), using IRAF and the \fBmscred\fR package. It is not a beginner's guide and assumes some previous experience with IRAF and CCD reductions. The first section discusses the mosaic data format and how to use it with IRAF. This format is more complex than single CCD images because of the multiple CCDs and possibly multiple amplifiers per CCD. To keep the data from each exposure self-contained the multiple CCD images are stored in a single file. This multiple image per file has many advantages but it does mean that some commands for dealing with images behave differently. The second section describes the tools used to examine the mosaic data. These tools are used during observing as well as during data reductions. The last section describes the reduction of mosaic data. This includes basic CCD instrumental calibration and combining mosaic exposures into single images. .sh 2. Multiextension FITS Files The data format used by the NOAO Mosaic Data Handling Software (MDHS) is a multiextension FITS (MEF) file. This format is produced by the the Data Capture Agent (DCA) when observing with the NOAO Mosaic. The MEF file for the NOAO Mosaic currently consists of nine FITS header and data units (HDU). The first HDU, called the primary or global header unit, contains only header information which is common to all the CCD images. The remaining eight HDUs, called extensions, contain the images from the eight CCDs. The fact that the image data is stored as a FITS file is not significant. Starting with IRAF V2.11, FITS files consisting of just a single primary image may be used in the same way as any other IRAF image format. The significant feature of the mosaic format is its multi-image structure. With multiextension FITS files you must either use tasks which are specifically designed to operate on these files as a unit or explicitly specify the image within the file that is to be operated upon by general IRAF image processing tasks. The tasks in the \fBmscred\fR package are designed to operate on the mosaic MEF files and so you only need to specify the filename. For image tasks outside the \fBmscred\fR package you must specify the image in the MEF file using the syntax .nf filename[extension] .fi where "filename" is the name of the MEF file. The ".fits" filename extension is optional provided there is no confusion with other files with the same basename. The image "extension" is specified either using an extension name or the position of the extension in the file (where the first extension is 1). The extension names in the NOAO Mosaic data are "im1" through "im8" for the eight CCDs. For a detail discussion of the IRAF FITS Image Kernel and the syntax it supports for multiextension FITS files see ftp://iraf.noao.edu/iraf/docs/fits_userguide.ps.Z. If you forget to specify an extension to a task that expects only single images you will get the following error which is your reminder to include an extension. .nf ms> imhead obj012 1 ERROR: FXF: must specify which FITS extension (obj012) .fi Two of the most common tasks that require specifying an image extension are \fBdisplay\fR to display a single CCD image (the task \fBmscdisplay\fR is used to display all the images at once) and \fBimheader\fR to list the header of a particular CCD. So, for example, the following commands might be used. .nf ms> display obj012[im2] 1 ms> imhead obj012[3] l+ .fi Other tasks you may use this way are \fBimexam\fR and \fBimplot\fR. A common question is how to specify a list of extensions. Modification of the syntax to allow wildcard templates in the extension specification is under study. Currently you must specify each extension explicitly, though the filename itself may be a wildcard; for example the first image in a set of files can be collectively specified with .nf obj*[im1] .fi There are two methods for specifying some or all extensions in tasks that operate upon lists of images. One is to make @files. This can be done explicitly with an editor. However the \fBproto\fR task \fBimextensions\fR can expand MEF files into an @file as in the following example. .nf ms> imexten obj012,obj13 > list ms> imhead @list .fi Read the help page for further information, additional parameters, and examples. Another method is to use the special \fBmscred\fR task \fBmsccmd\fR. This task can be used on the command line or as a simple interactive command interpreter. The idea is that you use the special designations "$input" and "$output" for task parameters which allow lists of images. Then lists of MEF filenames are specified for the input and output which are expanded and substituted into the task parameters when it is executed. For example, .nf ms> msccmd "imhead $input l+" input=obj012,obj013 .fi For additional information and examples consult the help page for that task. Note that the tasks \fBimstat\fR and \fBimarith\fR are so useful and common that there are specific \fBmscred\fR tasks \fBmscstat\fR and \fBmscarith\fR that operate on all or a subset of image extensions. So these tasks need not be used with \fBmsccmd\fR or with @files. We conclude with a discussion of the special operations of copying, renaming, deleting, and reading and writing FITS tapes as they apply to the mosaic MEF files. To copy a mosaic file as a unit use \fBcopy\fR, making sure to explicitly specify the "fits" extension. If you use \fBimcopy\fR it will expect you to specify a particular extension and will copy only that extension. While \fBimcopy\fR is not the way to copy an complete MEF file the tasks \fBimrename\fR and \fBimdelete\fR are the commands for renaming and deleting these files; though \fBrename\fR and \fBdelete\fR will also work provided you are explicit with the extension. Finally the mosaic data should be kept as a MEF file and so the special mosaic tasks \fBmscwfits\fR and \fBmscrfits\fR should be used. The current \fBwfits\fR and \fBrfits\fR are not intended for this type of data. .sh 3. Examining Mosaic Data During observing a small set of IRAF commands are commonly used to examine the data. This section describes these commands. While the discussion is oriented towards examining the data at the telescope during the course of observing, the tools described here are also used when reducing data at a later time. .sh 3.1 Displaying the Data The two commands \fBdisplay\fR and \fBmscdisplay\fR are used to display the data in a display server window. The display server is a separate process which must be running before displaying the images. The observing environment at the telescope will generally have the XIMTOOL display server already running with a window on a separate monitor. If it is not running for some reason it can be started with a menu selection. Away from the telescope you would start XIMTOOL or SAOIMAGE as you do normally. The display server must be told what size "frame buffer" to allocate for holding the display pixels. This determines how many pixels may be loaded at one time. Note that the display window may be smaller than this size and the display server allows you to move the portion viewed and zoom/unzoom any region. If the image size is larger than the frame buffer you can display a portion of the image at full resolution or the full image at a lower resolution. The frame buffer size is queried and set with the commands: .nf ms> show stdimage imt4096 ms> set stdimage=imt2048 .fi There are trade-offs in the frame buffer selection. A large frame buffer allows you to have higher resolution for the large mosaic images but it uses more memory and takes longer to load. The \fBdisplay\fR task is used to display individual images in the display server. This task is a standard IRAF task about which you are assumed to have some basic knowledge. There are many display options which are discussed in the help page. The only special factor in using this task with mosaic data is that you must specify which CCD image to display using the image extension syntax discussed previously. As an example, to display the central portion of extension im3 in the first frame and the whole image in the second frame: .nf ms> display obj123[im3] 1 fill- ms> display obj123[im3] 2 fill+ .fi The \fBmscdisplay\fR task is based on \fBdisplay\fR with a number of specialized enhancements for displaying mosaic data. It displays the entire mosaic observation in a single frame by "filling" each image in a tiled region of the frame buffer. The default filling (defined by the order parameter) subsamples the image by uniform integer steps to fit the tile and then replicates pixels to scale to the full tile size. The resolution is set by the frame buffer size. As mentioned before, trying to increase the resolution with a larger buffer size has the penalty of longer display times. An example display command is: .nf ms> mscdisplay obj123 1 .fi The default parameters for \fBmscdisplay\fR are shown below. Many of the parameters are the same as \fBdisplay\fR but there are also a few that are specific to the task of displaying a mosaic of CCD images as indicated with an asterisk. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscdisplay image = root name for image to be displayed frame = 1 frame to be written into * (mimpars= ) mosaic image parameters * (check = no) check if image is loaded * (onepass= no) load all extensions in one pass? (bpmask = BPM) bad pixel mask (bpdispl= none) bad pixel display (none|overlay|interpolate) (bpcolor= red) bad pixel colors (overlay= ) overlay mask (ocolors= green) overlay colors (erase = yes) erase frame (border_= no) erase unfilled area of window (select_= yes) display frame being loaded (repeat = no) repeat previous display parameters (fill = no) scale image to fit display window (zscale = yes) display range of greylevels near median (contras= 0.25) contrast adjustment for zscale algorithm (zrange = yes) display full image intensity range (zmask = ) sample mask * (zcombin= auto) Algorithm for combining z1 and z2 values... (nsample= 1000) maximum number of sample pixels to use (order = 0) spatial interpolator order (0=replicate,... (z1 = 0.) minimum greylevel to be displayed (z2 = 1000.) maximum greylevel to be displayed (ztrans = linear) greylevel transformation (linear|log|none|user) (lutfile= ) file containing user defined look up table .fi The mapping of the pixel values to grey levels includes the same automatic or range scaling algorithms as in \fBdisplay\fR. This is done for each image in the mosaic separately. The new parameter "zcombine" then selects whether to display each image with it's own independent display range ("none") or to combine the display ranges into a single display range based on the minimum and maximum values ("minmax"), the average of the minimum and maximum values ("average"), or the median ("median") of the minimum and maximum values. The independent scaling is most appropriate for raw data while the "minmax" scaling is recommend for processed data which are gain calibrated. The special value "auto" (the default) checks if the display data has been flat fielded, either by separate processing or with on-the-fly calibration, and if so it uses "minmax" scaling and if not it used independent scaling. The "mimpars" (mosaic image parameters) parameter is actually a reference to another set of parameters. The default with no value is to use the parameters from the parameter task \fBmimpars\fR. These parameters can be examined and set with \fBepar\fR either by typing ":e" when over this parameter in \fBmscdisplay\fR or by running \fBepar\fR directly on this task; i.e. epar mimpars. The parameters for NOAO Mosaic data are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mimpars (extname= ) extension name pattern (exttmpl= _![1-9]![1-9]![1-9].*) extension template (xgap = 72) minimum X gap between images (ygap = 36) minimum Y gap between images (process= no) do calibration processing? (oversca= yes) do line-by-line overscan subtraction? (flatfie= yes) do flat field correction? (caldir = mscdb$noao/kpno/4meter/caldir/) calibration directory (filter = !filter) filter .fi The "extname" parameter is used to select as subset of the image extensions to display. It is a pattern to match extension image names. For extensions such as im1, im2, etc. the pattern typically uses the character selection template such as "[1256]" to select anything with a 1, 2, 5, or 6 in the name. The pattern matching syntax can be found in the help for the task \fBmatch\fR. The "exttmplt" parameter is for use with non-MEF data. The gap parameters define the gap size in the display. The remaining parameters are for the on-the-fly calibration discussed below. .sh 3.1.1 On-the-Fly (OTF) Calibration Raw mosaic data can exhibit significant instrumental artifacts which may interfere with inspecting the data prior to reductions. The most significant artifact is gain variations both within each CCD image and between the CCDs. In the simplest case of constant gain variations between the CCDs the independent display scaling, "zcombine" of none or auto, may be sufficient. But when there are significant flat field patterns it may be desirable to apply a quick, approximate flat field calibration as the data are being displayed. \fBMscdisplay\fR can apply an on-the-fly (OTF) calibration to raw mosaic exposures. This does not change the actual data files and the calibration is intended to be quick and approximate. The calibration steps performed are a line-by-line bias subtraction using the overscan region of the data and a division by a flat field. If the data have been overscan corrected or flat field corrected by \fBccdproc\fR then the task will automatically skip those steps. The title of the display will indicate if the data have been calibrated by adding "[bias]" for bias subtraction and "[bias,flat=XXX]" for bias subtraction and flat fielding using an OTF flat field called XXX. The bias subtraction is performed by averaging the overscan pixels in a line and subtracting this average from all the pixels in the line. This removes the amplifier bias and line-by-line patterns. The flat field or response calibration is performed by reading special compact flat field calibration data which provides an approximate relative response for each pixel in each amplifier readout. Depending on how the calibration file is derived this will approximately correct for pixel sensitivity variations, gain variations between the amplifiers, sky illumination variations, and any pupil ghost pattern (as occurs with NOAO Mosaic data from the Mayall (KPNO 4meter) telescope). The "process" parameter in the \fBmimpars\fR parameter set shown earlier selects whether to turn on or off the OTF processing. If it is no then regardless of the "overscan" or "flatfield" parameter settings no calibration is applied. If it is yes then one or both calibration operations can be selected. Because the \fBmimpars\fR parameters can be set on the command line, it is common to leave the "process" parameter set one way, say to "no", and then override the value when displaying. For example, .nf ms> mscdisplay obj023 1 proc+ ms> mscdisplay flat022 2 proc+ flatfield- .fi The flat field calibration requires special calibration files. The "caldir" parameter defines a directory containing the calibration files. This can be a standard directory or a user directory. Note that if a directory is specified it must end with $ or /. Within the calibration directory the calibration file to apply is selected by the "filter" parameter. For automatic selection of calibrations, the calibrations can be selected by the filter string in the header (or by giving the same filter string in the "filter" parameter). To use the filter string in the header the value of the filter parameter is set to "!" where is the keyword for the filter string. Creating the a calibration directory and calibration files is done with the task \fBmscotfflat\fR. For the NOAO Mosaic a calibration directory is provided. However you can create your own as described in the help for \fBmscotfflat\fR. The "filter" parameter can be set to one of these names. .sh 3.1.2 Real-Time Display with the DCA During data acquisition the \fBmscdisplay\fR task can be used to display mosaic data as it is being written to disk by the DCA. It begins execution shortly after the readout begins and displays the portion of the recorded image which has been written to disk. It then continually displays new data which has been written by the DCA until the exposure is completely written to the display. The DCA control panel allows you to select whether to display the data during readout and how it is to be displayed. This includes selecting the OTF calibration. One toggle is equivalent to the "process" parameter. If the processing is turned on the DCA automatically selects only overscan bias subtraction for non-object exposures and selects both bias subtraction and flat field division for object exposures. The "filter" parameter is set by passing through the filter string from the data acquisition system or by overriding this and using the filter menu to select one of the available calibrations. .sh 3.2 Examining the Data The task \fBmscexamine\fR allows interactive examination of mosaic images. It is essentially the same as the standard \fBimexamine\fR task except that it translates the cursor position in a tiled mosaic display into the image coordinates of the appropriate extension image. Line and column plots also piece together the extensions at the particular line or column of the mosaic display. To enter the task after displaying an image the command is: .nf ms> mscexam .fi As with \fBimexamine\fR, one may specify the mosaic MEF filename to be examined and if it is not currently displayed it will be displayed using the current parameters of \fBmscdisplay\fR. It is important to realize that this task shares the \fBmimpars\fR parameters with \fBmscdisplay\fR. To get data values back that match what is displayed the parameters must agree with those used to display the data. In particular, if the data are display with OTF processing then \fBmscexam\fR must be told this either by explicitly setting the process flat in \fBmimpars\fR or setting it on the command line, .nf ms> mscexam proc+ .fi .sh 3.3 Examining the Headers There was discussion earlier concerning the use of generic image tasks with the NOAO Mosaic data. The tasks \fBimheader\fR and \fBhselect\fR fall into this category. The two important points to keep in mind are that you must specify either an extension name or the extension position and that the headers of an extension are the combination of the global header and the extension headers. Often one does not need to list all the headers for all the extensions. The image title and many keywords of interest are common to all the extensions. Thus one of the following commands will be sufficient to get header information about an exposure or set of exposures: .nf ms> imhead obj*[1] l- # Title listing ms> imhead obj123[1] l+ | page # Paged long listing ms> hselect obj*[1] $I,filter,exptime,obstime yes .fi If you need to list header information from all the extensions then you need to take the additional step of creating an @file or using \fBmsccmd\fR. For example to get the default read noise and gain values for each CCD: .nf ms> imextensions obj123 > list123 ms> hselect @list123 $I,rdnoise,gain yes or ms> msccmd "hselect $input $I,rdnoise,gain yes" input=obj123 .fi The \fBccdlist\fR task in the \fBmscred\fR package is specialized for the mosaic data. It provides a compact description of the name, title, pixel type, filter, amplifier, and processing flags. The "extname" parameter may be used to select a particular extension, a set of extensions, or all extensions. Because all extensions should generally be at the same state of reduction it may be desirable to list only the first extension. Like most of the CCD reduction tasks you can also select only a certain type of exposure for listing. Examples of the two modes are: .nf # Summary for all exposures ms> ccdlist *.fits extname=im1 # Summary for all object exposures ms> ccdlist *.fits extname=im1 ccdtype=object # List of all extensions. ms> ccdlist obj123 extname="" .fi .sh 3.4 Determining Best Focus Focus sequence frames can be evaluated for the best focus using \fBmscexam\fR and the 'r' or 'a' keys. However, there is a special task for measuring the sequence of focus images called \fBmscfocus\fR. This displays a focus exposure with \fBmscdisplay\fR (if needed) and then lets you select one or more bright stars to measure. This task is customized so that all you need do is mark the top image in any CCD. For NOAO Mosaic data, header information tells the task how many exposures, the spacings between the exposures, and the focus values. After the measurements are made they are displayed and analyzed graphically and written to the terminal and logfile. This task is the mosaic analog of the \fBkpnofocus\fR and \fBstarfocus\fR tasks for single CCD data. .sh 4. Data Reductions The reduction of CCD mosaic data can be divided into two stages. The first is the basic calibration of the individual CCDs. This stage is similar to reducing data from single CCD exposures except that the calibration operations are repeated for all the CCDs in the mosaic. The only significant difference is that any scaling of an exposure, such as in normalizing the flat field calibration, must be done uniformly over all the CCDs. The details of repeating the calibrations for all CCDs and the scaling of the calibration data are taken care of by the software and the data format so that these operations appear the same as with single CCD data. There are some steps which are not typical for CCD data with smaller fields of view or specific to the NOAO Mosaic at the Mayall telescope. At the Mayall telescope there are reflections off the corrector that produce a visible image of the pupil. Coating of the corrector minimizes this image but it may be desirable to remove this instrumental signature which would otherwise cause a small variation of the photometric zero point as well as an unwanted visible feature. There are two sections discussing removal of this feature from the flat field data and from the object exposures. If your data is from the KPNO 0.9 meter telescope or the image is faint enough that it is not of concern then you can skip the extended discussion. A caveat about the pupil removal steps described here is that this document was written prior to the latest removal of the corrector for better anti-reflection coating. So the NOAO staff have little experience with these corrections though earlier work has shown that these steps will do a good job. Another step of the basic CCD calibration stage which has generally been ignored or forgotten with smaller single CCD formats is the variable pixel scale. The large field of view provided by a mosaic and the optics required to provide it can lead to a significant variation in the pixel scale. This effect is important with the Mayall telescope and is also present in the NOAO 0.9 meter data to a smaller degree. It is likely to be present in other telescopes as well. When the pixel scale varies significantly the standard flat field calibration operation will cause the photometric zero point to vary. A simple calibration step can be performed to remove this effect. However, if you intend to produce single images from the mosaic of CCDs this step is not necessary since the resampling operation naturally accounts for this effect. The second stage of data reductions is unique to mosaic data. This stage is the combining of the multiple CCD images and multiple exposures into a single image. Since creating a single image from a single mosaic exposure is of marginal value, the thrust of this stage of the reductions is the combining of multiple exposures which have been spatially offset or "dithered" to cover both the gaps between the individual CCDs and any defects. The steps required to produce a single deep integration from dithered exposures consist of accurately registering the images, mosaicing the exposures into single images with the same spatial sampling, measuring changes in the intensity scale due to variations in transparency and sky brightness, and combining the individual images into a single deep image with the gaps and bad pixels removed. .sh 4.1 Some Preliminaries The command \fBsetinstrument\fR is used to set default parameters for the tasks in the \fBmscred\fR package appropriate to a particular instrument. For users of the NOAO Mosaic it is recommended you run this command the first time you reduce data. Subsequently you should not do this since it will reset parameters you later changed. To set the parameters for reducing the NOAO Mosaic data type the command .nf ms> setinstrument kpno 4meter CCDMosaThin1 review- .fi Substitute "36inch" for "4meter" if the data is from the Kitt Peak 0.9 meter telescope. For some of the operations it is useful to specify lists of exposures corresponding to a dither set. The examples in this guide show using @files for dither sets. An @file is simply a list of filenames. These can be created in several ways including using a text editor. One way is with the \fBfiles\fR command to expand a file template. For example, .nf ms> files obj021,obj022,obj023,obj024,obj025 > field1 ms> dir @field1 obj021 obj002 obj003 obj004 obj005 .fi .sh 4.2 Basic CCD Calibration Basic CCD instrumental calibrations consist of correcting each CCD for electronic bias levels, zero exposure patterns, dark counts, and pixel sensitivities. A cosmetic replacement of bad pixels may also be included. For the Mayall telescope the pupil image due to reflections off the corrector must be removed from the flat field and object exposures. An additional calibration is required to correct for the variable pixel scale across the field of view if you intend to do photometry on the individual CCD images. .sh 4.2.1 Calibration Data to Obtain At the Telescope Good data reductions begin with obtaining good calibration data at the telescope. This section discusses the NOAO Mosaic but the general principles will apply to other detectors, though the relative importance of different calibrations will depend on the quality of the CCDs and the stability of the camera. The standard calibration data are sequences of zero exposures and sequences of dome flat field exposures. While dark count exposures, matched to the typical object exposure times, were important for the first generation (engineering grade) NOAO Mosaic, dark counts are expected to be low in the science grade detectors. Thus dark count exposures are probably not necessary. Dome flat fields (dome flats) provide a fair basic flattening of the data to 2% or so, but sky flat fields (sky flats) are required to produce dithered data that can be combined without introducing obvious artifacts. Good sky flats can flatten the data to 0.1%. In our experience twilight exposures do not work well. Instead dark sky flat fields are derived from unregisted object exposures taken during the night or run. If your observing program consists of only large extended objects or single pointings then you should also take some dithered exposures of "blank" sky. At the Mayall telescope there is a pupil image caused by reflections off the corrector. For broadband photometry the effects of the pupil image are small but they can be reduced even further by reduction steps to remove the image. One useful calibration for this removal is a narrowband dome flat field. The idea is that the narrowband flat field has a more prominent pupil image that can be used as a template for the much fainter broadband pupil image. Lastly, good astrometry is required to register and stack the Mosaic images. The NOAO Mosaic data contains previously determined astrometry recorded in the headers of the raw exposures. This is sufficient for most purposes. However, for cameras without astrometry or to generate your own astrometry solutions, fields with a reasonable density of stars with cataloged accurate coordinates must be taken. Note that with the new generation of large astrometric catalogs and the large field of view of a mosaic, it may be that the object exposures already contain sufficient information for deriving new astrometric calibrations or corrections. Note that this guide does not yet discuss how to create the astrometric coordinate system solutions. .sh 4.2.2 Preparing Calibration Data This section describes how to prepare the basic calibration data. The steps are virtually the same as with the \fBccdred\fR package and, in fact, the command names and parameters are the same. The basic calibration data of zero level, dark count, and dome flat fields are generally taken as a sequence of identical exposures which are combined to minimize the noise. A later section discusses preparing a sky flat field calibration using the object exposures. The calibration exposures are individually reduced by \fBccdproc\fR and then combined. Thus, it is necessary to first set the \fBccdproc\fR parameters. Because this task knows which operations are appropriate for particular types of calibration exposures you can set all the parameters for object exposures. Below is a typical set of parameters. The main optional setting is whether or not to replace bad pixels by interpolation, which is purely a cosmetic correction. However, it is recommended that this be done to avoid possible arithmetic problems in the processing. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = ccdproc images = List of Mosaic CCD images to process (output = ) List of output processed images (ccdtype= object) CCD image type to process (noproc = no) List processing steps only? (oversca= yes) Apply overscan strip correction? (trim = yes) Trim the image? (fixpix = yes) Apply bad pixel mask correction? (zerocor= yes) Apply zero level correction? (darkcor= no) Apply dark count correction? (flatcor= yes) Apply flat field correction? (sflatco= no) Apply sky flat field correction? (biassec= !biassec) Overscan strip image section (trimsec= !trimsec) Trim data section (fixfile= BPM) List of bad pixel masks (zero = Zero) List of zero level calibration images (dark = Dark) List of dark count calibration images (flat = Flat*) List of flat field images (sflat = Sflat*) List of secondary flat field images (minrepl= 1.) Minimum flat field value (interac= no) Fit overscan interactively? (functio= legendre) Fitting function (order = 1) Number of polynomial terms or spline pieces (sample = *) Sample points to fit (naverag= 1) Number of sample points to combine (niterat= 1) Number of rejection iterations (low_rej= 3.) Low sigma rejection factor (high_re= 3.) High sigma rejection factor (grow = 0.) Rejection growing radius .fi The overscan correction has two methods as selected by the fitting function. A value of "legendre" (or "chebyshev" or "spline3") take all the overscan data and fit a smooth function along the column direction. The "order" value of 1 shown above fits a single constant value. This leaves to the zero level calibration to subtract any details of line-by-line structure. A value of "mean", "median", or "minmax" take the mean, median, or mean excluding the minimum and maximum values, of the overscan at each line and subtract that value from that line. The other fitting parameters are ignored. The advantage of this is that systematic line-by-line patterns are subtracted. The disadvantage is, since the sample of overscan pixels is small at each line, that this can also introduce a statistical line-by-line pattern. There is currently no recommendation for the NOAO Mosaic. The first step is generally to process and combine sequences of zero, dark, and dome flat exposures. This is done using the tasks \fBzerocombine\fR, \fBdarkcombine\fR, and \fBflatcombine\fR. The combining must be done in the following order since the processing of later calibration data requires the preceding calibration data. .nf ms> zerocombine *.fits ms> darkcombine *.fits ms> flatcombine *.fits .fi Each of these tasks search all the exposures for a particular type so it is fine to specify all files, though if the file names code the type, such as "dflatNNN", then one can use that as the wildcard to shorten the search of all the data. Also \fBflatcombine\fR has the feature that it will combine the data separately for each filter. However, you can use explicit file lists, templates, or @files to limit the input files. The output combined names have standard default values which the above settings for \fBccdproc\fR use. It is a good idea to first check that the different calibration types and filters are correctly identified by the software. This is done using the \fBccdlist\fR command .nf ms> ccdlist *.fits .fi Unless you change the parameters "mscred.backup" and "mscred.bkuproot" the original raw files will be saved in the subdirectory "Raw/". If you want to start over, delete the processed files and copy the raw files back to the working directory. If disk space is a concern and you are satisfied with the combined calibration files you can delete the individual processed calibration files. There is a parameter in the combining tasks that will delete the individual files automatically after processing and combining. .sh 4.2.3 Pupil Image Removal from Flat Fields NOAO Mosaic data taken at the Mayall (4meter) telescope include a pupil image caused by reflections off the corrector. The magnitude of this image is a function of the filter and the state of the anti-reflection coatings on the corrector. It is also a function of the total light, including from outside the field of view, and somewhat on the location of bright stars. It might appear at first that one simply divides the object exposures by the flat field as is done for the OTF display calibration. However this is not photometrically correct because the pupil image is an additive light effect and not a detector response. Instead the pupil image must first be removed from the flat field before applying it to the object data. The object data is then corrected after flat fielding by subtracting the extra light from the pupil image. The pupil image is removed from the flat field by dividing by an estimate of the pupil image pattern. The challenge is to determine the pupil image contribution in the presence of other flat field structure. There are two current approaches to obtaining the pupil image pattern for removal from the data. One is to use data from another source where the pupil pattern is more easily separated from the flat field pattern. The second is to derive the pattern from the data assuming something about the form of the pattern. In particular, to use the difference in scales between the larger pupil pattern and the smaller flat field pattern. The first approach is preferable since it better preserves fine structure in the pupil image but the second is needed when no other data is available. .sh 4.2.3.1 Broadband Data For broadband data the recommended procedure is to obtain a narrowband flat field exposure. This narrowband exposure will have a stronger pupil image relative to the flat field pattern and, when the pupil image is scaled down to match the broadband image flat field, the errors from the flat field response will be diminished. The pupil image is extracted from the narrowband flat field using the task \fBmscpupil\fR. This task determines the background levels in a ring inside and outside the main pupil image and subtracts this background to produced the pupil image template. Outside the outer background ring the template is set to zero. In effect this is like "scrapping off" the pupil image from the exposure. The relevant parameters are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscpupil input = List of input images output = List of output images (masks = BPM) List of masks (type = data) Output type (xc = 27.) Pattern center offset (pixels) (yc = 9.) Pattern center offset (pixels) (rin = 300.) Radius of inner background ring (pixels) (drin = 20.) Width of inner background ring (pixels) (rout = 1500.) Radius of outer background ring (pixels) (drout = 20.) Width of outer background ring (pixels) (funcin =chebyshev) Inner azimuthal background fitting function (orderin= 2) Inner azimuthal background fitting order (funcout= spline3) Outer azimuthal background fitting function (orderou= 2) Outer azimuthal background fitting order * (rfuncti= spline3) Radial profile fitting function * (rorder = 40) Radial profile fitting order * (abin = 0.) Azimuthal bin (deg) * (astep = 0.) Azimuthal step (deg) (niterat= 3) Number of rejection iterations (lreject= 3.) Low rejection rms factor (hreject= 3.) High rejection rms factor (datamin= INDEF) Minimum good data value (datamax= INDEF) Maximum good data value (verbose= yes) Print information? .fi The output type is set to "data" to extract the pupil image after background subtraction. The pattern center parameters are offsets from the astrometric center and the inner and outer radii are measured from the pattern center. The default values are for the last measured Mayall pupil image. The fitting parameters marked with an asterisk are not used when extracting the pupil image directly. The pupil image template is scaled and removed from the flat field using the task \fBrmpupil\fR. The removal is done with the arithmetic operation .nf I(out) = I(in) / (scale * I(template) + 1) .fi where I(out) are the output corrected pixel values, I(in) are the input pixel values, I(template) are the pupil image template pixel values, and scale is the relative scale factor to be applied. The parameters for the pupil image removal task are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = rmpupil input = Input mosaic exposure output = Output mosaic exposure template= Template mosaic exposure (type = ratio) Type of removal (extname= [2367]) Extensions for fit (blkavg = 8) Block average factor (fudge = 1.6) Fudge factor (interac= yes) Interactive? (mscexam= no) Examine corrections with MSCEXAM? .fi The "input" is the broadband flat field, the "output" is the corrected flat field, and the "template" is the narrowband pupil image produced by \fBmscpupil\fR. The type of removal for a flat field is "ratio" as given by the equation above. Determining the optimal scaling of the template pupil image to the input pupil image is normally done interactively. The task makes a guess at scaling. If this task is used non-interactively this will be the scale used. When the task is used interactively the input and corrected mosaic exposures are displayed and then a query for a new scale is given. By repeatedly adjusting the scale factor the best visual removal can be obtained. When done the output corrected flat field is created using the last specified scale factor. Note that to quit requires entering dummy special values for the scale factor. A value of zero means to create the final output exposure with the last scale factor and a value of -1 means to quit without producing any output. Because this operation is fairly slow and iterative there are some steps that can be taken to it speed up. The "extname" parameter selects just those extensions to look at. For NOAO Mosaic data the default selects the central four extensions covered by the pupil image. The "blkavg" parameter applies a block average to the input exposure and template. This makes the display and iterative corrections faster. When the best scale factor has been determined the entire input image at full resolution is corrected by the full resolution template to create the output flat field. If one wants to use the facilities of \fBmscexam\fR to evaluate each iterative correction then the "mscexam" parameter can be set. However, the most powerful estimate for the optimal scale factor is viewing the display and possibly blinking between the uncorrected and corrected frames. .sh 4.2.3.2 Narrowband Data For narrowband data the pupil image template must be derived from the data itself. This is done by fitting the data with an axially symmetric pattern. The fitting is performed by \fBmscpupil\fR with the parameters .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscpupil input = List of input images output = List of output images (masks = BPM) List of masks (type = ratio) Output type (xc = 27.) Pattern center offset (pixels) (yc = 9.) Pattern center offset (pixels) (rin = 300.) Radius of inner background ring (pixels) (drin = 20.) Width of inner background ring (pixels) (rout = 1500.) Radius of outer background ring (pixels) (drout = 20.) Width of outer background ring (pixels) (funcin =chebyshev) Inner azimuthal background fitting function (orderin= 2) Inner azimuthal background fitting order (funcout= spline3) Outer azimuthal background fitting function (orderou= 2) Outer azimuthal background fitting order (rfuncti= spline3) Radial profile fitting function (rorder = 40) Radial profile fitting order (abin = 0.) Azimuthal bin (deg) (astep = 0.) Azimuthal step (deg) (niterat= 3) Number of rejection iterations (lreject= 3.) Low rejection rms factor (hreject= 3.) High rejection rms factor (datamin= INDEF) Minimum good data value (datamax= INDEF) Maximum good data value (verbose= yes) Print information? .fi Note that this only differs from the previously shown parameters by setting the "type" parameter to ratio. Because the template is derived from the data itself there is no need to use \fBrmpupil\fR to iteratively determine a scale factor. The "output" parameter is the corrected flat field. The corrected narrowband flat field will show some artifacts from fine structure in the pupil image. However, a large fraction of the pupil image will be removed. Later reduction steps of applying a sky flat field and combining with dithering further eliminate effects of this approximate solution to the pupil image. .sh 4.2.4 Object Exposure Reductions At this point you will have some subset of combined zero level, dark count, and flat field calibration data. The calibration data is applied to the object exposures, either in bulk or as observations are completed, using the task \fBccdproc\fR. The command is simply .nf ms> ccdproc .fi .sh 4.2.5 Pupil Image Removal from Object Data The pupil ring image in the object exposures is removed by subtraction since this is excess light. Again this is only required for data where the pupil image occurs, such as from the Mayall telescope. The tasks for modeling and removing the image are the same as for removal from the flat field except that the "type" parameter is set to "difference". .sh 4.2.5.1 Broadband Data Probably the best subtraction will be obtained by using the pupil image template from a narrowband flat field. This would be the same as used for the flat field and extracted from the narrowband flat field using \fBmscpupil\fR with "type = data". The subtraction is carried out using \fBrmpupil\fR with "type = difference". An alternative, since the pupil image is weak and the fine structure is unimportant, is to use \fBmscpupil\fR with "type = difference" to determine a smooth large scale ring pattern and subtract it from the data. The iterative sigma rejection and the "datamin" and "datamax" parameters are used to eliminate smaller scale astronomical objects in the field from affecting the background fits and the ring profile fits. For this application the "abin" parameter should be set to a value such as 30 degrees and the "astep" parameter to a smaller value such as 5 degrees. The main advantage of this method is that no iterative scaling is required since the fit is done directly to the data. The difficulty, though, is if there is a bright star or fairly extended object, particularly in the inner background ring, then the fit will be poor and the subtraction will show gross artifacts. The last alternative, and the one to use if there is no narrowband flat field for the template and the field has bright stars which affect fitting directly to the data, is to make a "sky flat" to generate the pupil image template. This is done as described in the section for creating a sky flat. Once the sky flat is created with the pupil image then \fBmscpupil\fR is used to separate the pupil image from the background and \fBrmpupil\fR is used to scale and subtract the image from the object exposures. Note that after the pupil image is subtracted then a new sky flat should be created. .sh 4.2.5.2 Narrowband Data For narrowband data the two alternatives described for the broadband data are used. The first is to fit and subtract a smooth ring model from each object exposure using \fBmscpupil\fR. This is the same as described for removing the pupil image from the flat field except the "type" parameter is set to difference. The second is to create a sky flat from disregistered exposures, extract the pupil pattern with \fBmscpupil\fR, and then subtract it from each object exposure using \fBrmpupil\fR. .sh 4.2.6 Dark Sky or Twilight Sky Flat Fields You will notice that there are two flat field corrections which can be performed by \fBccdproc\fR. The first one is for an initial flat field such as the dome flat obtained at the beginning of the night, a standard flat field from a previous night or run, or a final combined dome flat and sky flat from some other night or run. The second is for a dark sky or twilight sky flat field prepared from the object exposures after they have been calibrated with the first flat field. Sky flat fields are created by combining object exposures with objects removed by using data in each pixel that is only sky. In principle one could use exposures of the twilight sky but our experience is that these do not work well. You are welcome to take some exposures and try using them. We have found that dark sky flat fields derived from the object exposures do work quite well. Mosaic observations already typically dither a field. One will do even better by combining observations from other fields. The more data used the better the resulting sky flat will be. The main criterion for including data is to avoid observations contaminated by varying background light from the moon or scattered light from bright stars off the field. Of course, another factor that has to be considered is whether a field has a very large extended object which appears in many of the observations. These will not be useful. The sky flat field is created using the task \fBsflatcombine\fR with parameters selected to reject objects appearing above a median. We don't have much experience with creating sky flats currently so some experimentation with parameters may be required. Below is one possibly set of parameters. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = sflatcombine input = List of images to combine (output = Sflat) Output sky flat field root name (combine= average) Type of combine operation (reject = avsigclip) Type of rejection (ccdtype= object) CCD image type to combine (subsets= yes) Combine images by subset parameter? (scale = mode) Image scaling (statsec= ) Image section for computing statistics (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 6.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= rdnoise) ccdclip: CCD readout noise (electrons) (gain = gain) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (pclip = -0.5) pclip: Percentile clipping parameter (blank = 1.) Value if there are no pixels (grow = 3.) Radius (pixels) for neighbor rejection .fi This task is a combination of \fBccdproc\fR to first process the images, if they have not previously been processed, and \fBcombine\fR to combine the offset images with rejection of object pixels. A new feature of this task is the "grow" parameter which now provides a two dimensional circular rejection of pixels around pixels rejected by the rejection algorithm. Whatever rejection algorithm is used it is likely that the best results will be when the clipping sigmas are non-symmetric as shown above. Note that a very low rejection threshold or very large grow radius will make the task quite slow. After producing a good sky flat that has no evidence of objects it may be applied directly to the data by using it as the second flat field correction. .nf ms> ccdproc sflatcor=yes sflat=Sflat* .fi Note that the object exposures used in creating the sky flat will already have been processed except for the application of the sky flat so \fBccdproc\fR will only apply the sky flat field calibration. The sky flat field includes corrections at all scales from pixel-to-pixel sensitivity variations to large scale illumination differences. If the signal-to-noise is poorer than the dome flat field you might wish to apply a filtering/smoothing operation to the sky flat data thus relying on the dome flat field for the pixel-to-pixel sensitivity calibration and the sky flat field for larger scale illumination corrections. There are a number of filtering tasks in IRAF. A median is a good filter and there is the choice of a ring median or box median. To apply one of these general filtering tasks you would use \fBmsccmd\fR to run it on all the CCDs .nf ms> msccmd msccmd: median $input $output 10 10 Input files: SflatV Output files: SflatMedV msccmd: q .fi Because the object exposures are first processed with the dome flat (or other flat field) you would normally run \fBccdproc\fR again on the data using the sky flat and any observations that have not been processed at all will use both the dome flat and the sky flat. However, if you want to make a single flat field to apply to raw data, say if starting over or using it for a second night, you can combine the two flat field corrections into a single flat field to be used as the only flat field correction. This is done by multiplying the two flat fields using \fBmscarith\fR .nf ms> mscarith FlatV * SflatV FinalflatV .fi .sh 4.2.7 The Variable Pixel Scale and Zero Point Uniformity A key assumption in the traditional reduction of CCD images is that the pixel scale is uniform and that a properly reduced blank sky image will have a uniform and flat appearance. Unfortunately, this is not correct when the pixel scale varies over the field. In the case of the NOAO Mosaic at the Mayall telescope, the pixel scale decreases approximately quadratically from the field center, with the pixels in the field corners being 6% smaller in the radial direction, and 8% smaller in area. Pixels in field corners thus would properly detect only 92% of the sky level seen in the field center, even with uniform sensitivity. At the same time the same number of \fItotal\fR photons would be detected from a star regardless of how many pixels the PSF would be distributed over. Forcing the sky to be uniform over the image has the deleterious effect of causing the photometric zeropoint to vary from center to field corners by 8%. Note that this effect is different from vignetting where the flux actually delivered to the image margins is less than that at the center, an effect that \fIis\fR corrected by the flat field. In practice, the photometric effect of the variable pixel scale can be ignored provided that the reduced images will be part of a dither-sequence to be stacked later on. As discussed below, prior to stacking the images they first must be re-gridded, which produces pixels of essentially constant angular scale. This is done with the \fBmscimage\fR task, which re-grids the pixels and has a "flux conservation" option that can scale the pixels photometrically by the associated area change. If this function is disabled, then "improperly" flattened images will have a uniform zero point restored. In short, the flat field adjusted (if inappropriately) for the different pixel sizes, so \fBmscimage\fR would then do no further adjustment. Stars would be too bright in the corners of the flattened images, but after re-gridding, their total fluxes would be seen to be scaled down to the appropriate values. If the mosaic CCD images are to be analyzed individually, as might be done for standard star fields, then after the flat field reductions are complete the differential scale effects must be restored. At present we are developing a routine in the \fBmscred\fR package to do this, without actually re-gridding the image. The correction process is simple; the scale at any point in the Mosaic field is already known from the astrometry so one just calculates and multiplies by the correction. The final image would appear to have a variable sky level, but would be photometrically uniform. .sh 4.3 Coordinate Calibration For some projects the basic flux calibrated CCD exposures may be all that is required. However, if you want to obtain coordinate information or combine multiple exposures which are dithered on the sky or taken with different filters, you must calibrate the celestial world coordinate system (WCS) of the data. This may be done in an absolute or relative sense; an absolute calibration ties the data coordinates to catalog coordinates while a relative calibration ties multiple exposures to the same coordinates. Determining the WCS from scratch is a complicated business and requires special observations of astrometry fields. However, for NOAO Mosaic data a standard coordinate calibration determined earlier is automatically inserted into your data by the data capture agent. The default coordinate system is sufficiently accurate for most purposes and just requires some small adjustments as described below. To piece a single exposure into a single image that does not require registration to any other data you may use the default WCS and skip the WCS calibration steps. The WCS is a mapping from pixels in the mosaic data to celestial coordinates relative to a reference point on the sky. The reference point, or zero point, is set using the telescope pointing coordinate. The telescope pointing is generally off by a small amount, though it could be completely wrong in some hardware/software error situations. In addition, differential atmospheric refraction introduces small axis scale changes and rotations, which are significant due to the large field of view of the mosaic even during the course of single set of dithered exposured. Putting observations from different filters onto the same coordinate system also requires mapping small scale changes, since currently there is only a single standard WCS solution derived through one filter. [In the future filter dependent solutions will be made available.] The WCS calibration operations consist of adjusting the standard coordinate system calibration to a desired zero point and applying small axis scale changes and rotations. This is done using objects (usually stars) in the exposures. Unlike a full WCS calibration, which requires a high density of stars with accurate catalog coordinates, the adjustments to the default WCS calibration require only a few objects; only one objects is needed to provide a zero point correction. The WCS adjustments are determined by specifying coordinates for one or more objects in the data. The coordinates can be obtained from a reference catalog or, more commonly, by measuring coordinates from one reference exposure to which other exposures are to be "registered". A combination of using a catalog coordinate for one object in the field to set the zero point in a reference exposure and then measuring the positions of other stars in the reference image based on that zero point calibration may also be done. The two tasks you will use are \fBmsczero\fR and \fBmsccmatch\fR. \fBMsczero\fR is used to interactively set the zero point of the coordinates, register multiple exposures closely, and generate a list of coordinates in a reference exposure to which other exposures in a dither set are registered. \fBMsccmatch\fR finds objects at the positions specified by a list of coordinates and determines corrections for the zero point, axis scale change, and axis rotation. .sh 4.3.1 Setting Coordinate Zero Points and Measuring Coordinates \fBMsczero\fR is an interactive display task for mosaic exposures that allows measuring coordinates and adjusting the WCS zero point. The task parameters are shown below. The last set of parameters (starting with "ra") are for the task to query and maintain lists. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msczero images = List of mosaic exposures (nframes= 2) Number of frames to use (logfile= default) Log file for measurements ra = RA (hours) dec = DEC (degrees) update = yes Update WCS zero point? (fd1 = ) (fd2 = ) .fi The task displays each exposure in the list, in turn, and responds to cursor key commands. You can go forward and backward through the input list or quit at any point. The exposures are displayed by cycling through the specified number of frames starting with the first frame. As an aid to efficiency, if the exposure is already loaded in the appropriate frame then the display step is skipped. This task has several uses (type '?' to get the list of command options): .nf 1. Set the WCS zero point by specifying the coordinate of a star. 2. Create a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. 3. Report coordinates at the cursor position. .fi It may be that the WCS zero points, based on the telescope pointing coordinates, are accurate enough that you can use this task on only a reference exposure to generate a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. However, because it is fairly quick to explicitly check and set the zero point of all the exposures in a dither set to the same coordinate for a common reference star, it is recommended you do this first. To check and set the zero points for a set of dithered exposures run \fBmsczero\fR with a list of the exposures .nf ms> msczero @field1 .fi After the first exposure is displayed either find a reasonably bright unsaturated star which will be in all the exposures or find a star whose coordinate is known from a catalog such as the HST Guide Star Catalog. Move the cursor to the star and type 'z' (zero) to invoke a centering algorithm. Note that even though the exposure may be displayed at lower resolution the centering is done with the full resolution data. The task will then tell you what it thinks the coordinate is and ask you for a new coordinate. The first time 'z' is typed it will prompt with the measured coordinate and thereafter it will prompt with the last entered value. If you are referencing all the exposures to the first exposure in the list accept the measured coordinate (and write the value down in case you need it later) otherwise enter the desired coordinate. Note that all further measurements of the image will automatically apply the measured zero point correction but the exposure WCS is not actually updated until you type 'n' (next) or 'q' (quit). If you want to print coordinates without changing the zero point correction use the space bar or 'c' (center) to center on an object and print the centered coordinate. If you changed the WCS zero point you will be shown the zero point offsets and given the option to update the WCS in the data file when you type 'n'. Then the next exposure in the list will be displayed. Find the same star and type 'z' again. Since it will retain the last entered coordinate you should only need to accept the prompted coordinates. When you have done this for all the exposures their coordinate systems will be registered at least at that point. The WCS in the dither set may still not be registered over all the field due to refraction effects. Also the intensity scales of the dithered exposures may not be the same due to changes in transparency and sky brightness. These effects are calibrated by matching objects throughout the field in position and brightness. This requires a list of coordinates tied to one of the dithered exposures as a reference. Usually the first exposure in the set is used as the reference. \fBMsczero\fR is used to create a list from objects in the reference exposure. .nf ms> msczero obj021 .fi Select objects, usually stars, throughout the field and type 'x' for each one. This will center on the object and and record the coordinate in a logfile. The default logfile name "default" creates a log file beginning with "Coords." and followed by the name of the exposure. In the example this will be "Coords.obj021". To be useful for coordinate matching this list should have a good number of stars, say three or four from each CCD, with emphasis on the field edges but allowing for the dithering. For the intensity matching you want to have stars with a range of brightness (though not saturated or extremely faint) and which are mostly isolated so that a region around them may be used for sky. The lists for the coordinate and intensity matching do not have to be the same but it is reasonable to just create one list. .sh 4.3.2 Matching Coordinate Systems The task \fBmsccmatch\fR determines and applies a linear correction to the WCS to match objects, generally stars, in an exposure to a set of reference celestial coordinates. This correction maintains the detector geometry and optical distortions while adjusting for changes in apparent sky position such as produced by atmospheric refraction and telescope pointing errors. The linear correction consists of a zero point shift, scale changes in the right ascension and declination axes, and rotations of the axes. To use this task you need a list of reference celestial coordinates, right ascension in hours and declination in degrees, and the mosaic exposure coordinate system must be relatively close to the reference coordinate system. The default WCS plus telescope pointing may be close enough, but if not you would use \fBmsczero\fR to register the zero points at some point in the exposures. Since it is relatively simple to register a set of dithered exposures to a common star with \fBmsczero\fR this is recommended procedure before using \fBmsccmatch\fR. The reference coordinates should cover all of the mosaic field of view to be sensitive to the small rotation and scale effects. The coordinate list might be obtained from a catalog or measured from one of the exposures to which other overlapping exposures will be matched. For the purposes of making a well aligned stacked image from a set of dithered exposures one generally uses one of the exposures as the source of the reference coordinates. \fBMsccmatch\fR operates on a set of input mosaic exposures; each in turn. For an exposure it converts each input celestial coordinate to a pixel coordinate in one of the extensions using the current WCS. If the coordinate does not fall in any extension the coordinate is not used. The pixel coordinate is used as a starting point for the \fBapphot.center\fR task. If the centering fails for some reason, such as the object being too near the edge or the final position being too far from the initial position, the coordinate is not used. For those objects successfully found a fit is made between the original celestial coordinates and the measured coordinates expressed as arc seconds from the exposure tangent point. The fit is constrained to yield some combination of shift, scale change, and rotation for each of the celestial coordinate axes. These parameters are then used to update the exposure WCS so that the adjusted measured coordinates best agrees with the reference coordinates. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msccmatch input = List of input mosaic exposures coords = Coordinate file (ra/dec) (nfit = 4) Min for fit (>0) or max not found (<=0) (rms = 2.) Maximum fit RMS to accept (arcsec) (maxshif= 5.) Maximum centering shift (arcsec) (fitgeom= rxyscale) Fitting geometry (update = yes) Update coordinate systems? (interac= yes) Interactive? (fit = yes) Interactive fitting? (verbose= yes) Verbose? accept = yes Accept solution? .fi The input is a list of mosaic exposures and a file of reference celestial coordinates. The exposures should all include a significant number of objects from the list of coordinates. The task can be run interactively or non-interactively based on the "interactive" parameter. In interactive mode you can graphically interact with the fitting (selected with the "fit" parameter) and accept or reject a fit based on the printed fit parameters. The fitting is done using the task \fBgeomap\fR and the interactive mode allows you to view the distribution of coordinates, residuals verses the input coordinates, delete bad values, and possibly change the fitting constraints (see the help for \fBgeomap\fR for more information). The linear transformation may be constrained by the "fitgeometry" parameter as described in the help for \fBgeomap\fR. This may be desirable if there are only a few coordinates or if you want to impose some physical assumption. Note that the effects of atmospheric refraction actually do cause independent scale changes and rotations in the two axes so the default "rxyscale" should be used. There are some constraints which are placed on the task. The "maxscale" parameter limits how far the objects may be found from the initial coordinates. This constraint protects against incorrect identifications and tells the centering routine how much of the image to look at. This parameter should be as small as possible consistent with the errors in the WCS. If you first zero the coordinates then the objects should be found quite close to the initial coordinates. When the "verbose" parameter is set the results of the centering will be printed consisting of the image extension name, the final pixel coordinates, the shift in pixel coordinates from the initial value, and the formal uncertainties in the pixel coordinates. If an error occurs one of the error codes from \fBapphot.center\fR will be reported such as "BigShift" for objects with too big a shift from the initial position and "EdgeImage" for objects to near the edge of the image. The "nfit" parameter requires a certain number of coordinates to be included in the fit. If specified as a negative number the parameter is interpreted as a maximum number that may be lost from the input list due to being off the exposure or failing to be centered. The "rms" parameter requires that the final RMS of the residuals about the fit for each axis be less than a certain value. .sh 4.4 Putting the Pieces Together This section tells you how to make single images from each multiextension exposure and how to combine sets of dithered images into a final deep image free from gaps and artifacts. Obtaining good results depends on having well-flattened data, a uniform sky, a dither pattern that samples the gaps and bad regions of the detectors, and accurately registered world coordinates. Most difficulties are caused by variable sky conditions or scattered light within a dither sequence or the data used to create a sky flat. .sh 4.4.1 Removing Sky Gradients Any sky level mismatches when combining dithered exposures produce artifacts in the final image. The three sources of such mismatches are sky gradients, sky level differences between the CCDs, and sky level differences between exposures. While the flat field calibration, particularly with a sky flat, should remove differences in sky levels between CCDs, in practice there may still be small errors. And the flat field will not deal with sky gradients across the large field of view. Exposure-to-exposure sky brightness variations can be dealt with at a later stage but even this is tricky. The best final result is obtained by fitting a low order surface (a plane or quadratic) to the sky and subtracting it from each CCD of each object exposure at this stage. This will force the sky to be zero for all CCDs and all exposures. Note that if one wants to preserve a sky level for statistical reasons it is possible to add a uniform constant after the subtraction to all the data (or add the constant to the final dither stacked image). To fit and subtract a sky and sky gradient the combination of \fBimsurfit\fR and \fBmsccmd\fR is used. With \fBimsurfit\fR use the option to fit to medians in large blocks to remove the effects of objects. .nf ms> msccmd msccmd: imsurfit $input $output xo=2 yo=2 type=resid xm=100 ym=100 Input files: obj* Output files: obj* msccmd: q .fi In this example the input and output are the same, replacing the original by the sky subtracted data, but one can create new output files if desired. Note that x and y orders of 2 correspond to a plane and orders of 3 correspond to a quadratic surface. .sh 4.4.2 Constructing Single Images Making a single image from a mosaic exposure is done by mapping the pixels from each extension to a single uniform grid on the sky. The WCS calibrations described in previous sections provide this. For making a single image from a single exposure the WCS calibration is not critical and the default WCS is sufficient. For combining multiple dithered exposures all the exposures must be registered to a common coordinate system, either relative to one reference exposure or to a set of catalog stars, and each exposure must be resampled to the same final coordinate system. The task that makes single images from mosaic exposures is \fBmscimage\fR. Its parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimage input = List of input mosaic exposures output = List of output images (referen= ) Reference image (pixmask= yes) Create pixel mask? (verbose= )_.verbose) Verbose output? # Resampling parameters (blank = 0.) Blank value (interpo= linear) Interpolant for data (minterp= linear) Interpolant for mask (fluxcon= no) Preserve flux per unit area? (ntrim = 7) Edge trim in each extension (nxblock= 2048) X dimension of working block size in pixels (nyblock= 1024) Y dimension of working block size in pixels # Geometric mapping parameters (interac= no) Fit mapping interactively? (nx = 10) Number of x grid points (ny = 20) Number of y grid points (fitgeom= general) Fitting geometry (functio=chebyshev) Surface type (xxorder= 4) Order of x fit in x (xyorder= 4) Order of x fit in y (xxterms= half) X fit cross terms type (yxorder= 4) Order of y fit in x (yyorder= 4) Order of y fit in y (yxterms= half) Y fit cross terms type .fi An output image is created for each input mosaic exposure. The output image is created with a coordinate system defined by the specified "reference" image. If no reference image is specified then the first input mosaic exposure is used to define a simple tangent plane coordinate system with optical distortions removed, and that coordinate system is used for all the input mosaic exposures. The important point is that for a set of dithered exposures all the output images must be created with the same coordinate system grid so that they may be combined by simple integer shifts along the image axes. The normal usage is to specify all the mosaic exposures in a dither set as the input, give a matching list of output images, and leave the reference image unspecified. If all the exposures in a dither set are not done at the same time then you must specify one of the earlier output images as the reference image to continue to create the output images on the same coordinate grid. The output images are created with a size that just covers the input data and initially filled with the specified "blank" value. This is the value that the mosaic gaps will have in the final output image. Then each extension is resampled into the appropriate part of the output image. The coordinate mapping is generated by \fBgeomap\fR using the geometric mapping parameters which you don't need to change. The resampling is done with the specified interpolation function. The small rotations in the CCDs produce edge effects in the interpolated output pieces so a small trim is required to eliminate these. [At the time this document was prepared the best value for the new science grade NOAO Mosaic had not been determined.] Linear interpolation is the fastest and most straightforward. Other interpolation functions are available. In particular sinc interpolation is now available as an add-on option (see the \fBmscred\fR installation instructions). Experience with sinc interpolation shows that it is not overly slow and does provide improved results; particularly with maintaining the statistical characteristics of the sky noise. The "minterpolant" parameter allows using a faster and more local interpolation function for the mask. This is particularly useful when using sinc interpolation of the data to allow flagging only around the actual bad pixels and not extending out as far as the sinc interpolation does. It is useful for the later combining step to make bad pixel masks that reflect the interpolation and resampling from the input data. These may be created by setting the "pixmask" parameter. If this parameter is set and the input mosaic data have bad pixel masks defined through the header BPM keywords (default bad pixel masks are provided in the NOAO Mosaic data) then the masks will be interpolated in exactly the same way as the data. The interpolated masks will appear in the working directory with names related to the output image names and with the output images containing the BPM keyword pointing to these masks. The input bad pixel masks are assumed to have zero for good data and one for bad data and the output masks have zero for good data and values between zero and ten thousand for bad data. The value is the result of interpolation and reflects the relative contribution of good and bad data. The "fluxconserve" parameter applies a pixel area correction if selected. As discussed earlier, standard flat fielding distorts the flux per unit area in pixels of different projected size by making them have the same flux per pixel. In effect this applies half of the flux conservation operation by adjusting the pixel values without adjusting the pixel sizes. \fBMscimage\fR does the second half by adjusting the pixel sizes. So for standard flat fielded data, the usual route to making a combined dithered image, the flux conservation parameter should not be used to arrive at a proper final flux per unit area in the resampled data. Flux conservation would only be used if the input mosaic data has previously been corrected back to proper flux per unit area through adjustment of the flat field or data for the variable pixel size inherent in the mosaic coordinate system. Below are two examples; one using prepared @files and one illustrating advanced usage of filename templates. .nf ms> mscimage @dither1 @outdither1 pixmask+ ms> mscimage obj02![2-5]* %obj%mos%02![2-5]* pixmask+ .fi In the second example the input template expands to obj022.fits to obj025.fits and the output template matches the input template using the first part of the %% substitution field and then replaces the "obj" with "mos" to give output images mos022.fits to mos025.fits. .sh 4.4.3 Matching Intensity Scales When stacking dithered exposures (the single images created in the previous step) to fill in the mosaic gaps and remove bad pixels and cosmic ray events it is critical that the intensity scales of the images match. Otherwise you will see artifacts from the gaps, places with bad data, and around objects as the combined intensity level jumps when data from an exposure is missing or rejected. Also the rejection algorithms require that the image intensities match both at the sky level and in the objects. There are two parameters that must be determined to match the intensity scales. One is a additive offset caused by sky brightness variations. The second is a multiplicative scale change caused by transparency and exposure time variations. Matching the intensity scales for a set of dithered exposures consists of determining values for these two scaling parameters relative to a reference exposure and setting them in the image headers. The actual adjustment of the pixels values occurs when stacking the exposures. The intensity matching values are determined by the task \fBmscimatch\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimatch input = List of images coords = File of coordinates (scale = yes) Determine scale? (zero = no) Determine zero offset? (box1 = 21) Inner box size for statistics (box2 = 51) Outer box size for statistics (lower = 1.) Lower limit for good data (upper = INDEF) Upper limit for good data (niterat= 3) Number of sigma clipping iterations (sigma = 3.) Sigma clipping factor (interac= no) Interactive? (verbose= yes) Verbose? .fi The input is a list of images to be matched and a file of celestial coordinates (RA in hours and DEC in degrees) to use in computing the matching parameters. The input images are the single images constructed from the mosaic exposures for a set of dithered observations. The parameters "scale" and "zero" select whether to determine the multiplicative scale, the zero level offsets, or both. If the sky has been subtracted at an earlier stage (as recommended) then only the multiplicative scale difference needs to be determined. The advantage of subtracting the sky earlier is that scale determination becomes better constrained. Also determining the sky from photometry (as done by this task) is less robust than the surface fitting which uses all of the sky data. The scaling parameters are determined by measuring the mean flux in a set of matching regions between each input image. The centers of the regions are specified by their celestial coordinates. The list of coordinates should consist of the positions of objects in the field. These objects should span a range of brightness. As noted previously, you would normally use the same coordinate list as used with \fBmsccmatch\fR, which is generally obtained using \fBmsczero\fR. However, you can use any IRAF task that produces a list of celestial coordinates from images with a WCS. One possibility is to use \fBrimcursor\fR on one of the displayed single images with the "wcs" parameter set to "world" and the "wxformat" set to "%.2H" to produce right ascension values in hours instead of degrees. The now accurately aligned coordinate systems in the images are used to identify the matching pixel coordinate center in each image. The regions to be measured consist of square boxes of the specified sizes about the pixel coordinate center. There are two boxes, an inner box and an outer box which excludes the inner box. The box sizes are intended to define photometry apertures for the objects and nearby background. It is not critical that they exactly fit the objects or that the objects necessarily be stars but this is usually how they will be set. Because of possible PSF variations the inner box should be large enough include all the light from stars over the whole data set. If the inner box is not fully contained in the input or reference image that box is not used for that pair. Similarly the outer box must be fully contained in the images but if only the outer box is outside one or both images the measurement for the inner box may still be used. In order to exclude regions that include the gaps or bad data in one or both of the pair of images all pixels in a box must have values between the specified good data limits. Those regions with values outside the limits are eliminated from the intensity matching. The mean fluxes in each region are used to simultaneously fit the relations .nf mean_j = A_ij + B_ij * mean_i .fi for all i and j where i and j are any pair of images. These equations are constrained by the fact that the scaling from image i to j, followed by the scaling from image j to k, must agree with the scaling from image i to image k. The final scaling coefficients reported and stored in the image header are A_1j and B_1j, which correspond to the scalings to the first image in the input list. The task will attempt to reject photometry points which are discrepant. If the task is run interactively it will also show plots of the photometry flux in one image verses another. It does this for sequential pairs of images. Points can be deleted in these plots and they will be excluded from the data used to determine the scaling parameters. When the task is done determining the scaling factors they will be printed and a prompt issued to accept or not accept the results. If the scaling parameters are accepted then the keywords \fBmsczero\fR and \fBmscscale\fR are recorded in the input image header when the "update" parameter is set. Note that the reference image is assigned values of 0 and 1 for these header keywords. .sh 4.4.4 Making the Final Stack Image After \fBmscimage\fR produces single images of each of the dithered mosaic exposures with a common coordinate system grid, a final image is created with the task \fBmscstack\fR. The task \fBmscimatch\fR is generally used to match the intensity scales of the images before this step as described in the previous section. However, for quick reductions or for other reasons the images may be stacked either with no intensity matching or using the "scale" and "zero" options of \fBmscstack\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscstack input = List of images to combine output = Output image (plfile = ) List of output pixel list files (optional) (combine= median) Type of combine operation (median|average) (reject = none) Type of rejection (masktyp= none) Mask type (maskval= 0.) Mask value (blank = 0.) Value if there are no pixels (scale = !mscscale) Image scaling (zero = !msczero) Image zero point offset (weight = none) Image weights (statsec= ) Image section for computing statistics (lthresh= 1.) Lower threshold (hthresh= INDEF) Upper threshold (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 3.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= 0.) ccdclip: CCD readout noise (electrons) (gain = 1.) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (sigscal= 0.1) Tolerance for sigma clipping scaling corrections (pclip = -0.5) pclip: Percentile clipping parameter (grow = 0) Radius (pixels) for 1D neighbor rejection .fi This task is a simple variant of \fBcombine\fR that registers the images using the coordinate systems and has the default threshold parameters set to ignore values below one DN based on the default "blank" value in \fBmscimage\fR for the gaps. If you have also generated bad pixel masks for the resampled images you can exclude them as well by setting "masktype" to "goodvalue". The real art in using this task is deciding how to scale and reject bad data not covered by the bad pixel masks. A "combine" of "median" is the simplest but it does not optimize the signal-to-noise for the number of images. If you "average" the data you will probably want to apply a rejection algorithm such as "avsigclip". Careful flat fielding will make each separate image have the same sky level across the different CCDs. However, the sky levels and transparency may still be varying from exposure to exposure. If you simply combine such data you will see imprints of the gaps. So it is generally a good idea to scale the images. This is done using the "scale" and "zero" parameters which can be set to header keyword values, files containing the values, or special values to compute image statistics in a particular region of the data. The recommended method for scaling is to use the intensity matching task \fBmscimatch\fR described in the previous section and use the image header keywords \fBmscscale\fR and \fBmsczero\fR produced by that task. An example of using this task to create a final image is given below. .nf ms> mscstack @field1 Field1 combine=average rej=avsigclip .fi .endhelp mscred-5.05-2018.07.09/doc/mscguide3.0.hlp000066400000000000000000003747431332166314300173030ustar00rootroot00000000000000.help mscguide Dec00 mscred .sp 3 .ce \fBGuide to the NOAO Mosaic Data Handling Software\fR .ce Francisco Valdes .ce December 2000 .ce MSCRED Version 4.0 .sh Sections .nf 1. Introduction 2. Multiextension FITS Files 3. Examining Mosaic Data 3.1 Displaying the Data 2.1.1 On-the-Fly (OTF) Calibration 2.1.2 Real-Time Display with the DCA 3.2 Examining the Data 3.3 Examining the Headers 3.4 Determining Best Focus 4. Data Reductions 4.1 Some Preliminaries 4.2 Basic CCD Calibration 4.2.1 Calibration Data to Obtain At the Telescope 4.2.2 Preparing Calibration Data 4.2.3 Pupil Image Removal from Flat Fields 4.2.3.1 Broadband Data 4.2.3.2 Narrowband Data 4.2.4 Object Exposure Reductions 4.2.5 Pupil Image Removal from Object Data 4.2.5.1 Broadband Data 4.2.5.2 Narrowband Data 4.2.6 Dark Sky or Twilight Sky Flat Fields 4.2.7 The Variable Pixel Scale and Zero Point Uniformity 4.3 Coordinate Calibration 4.3.1 Setting Coordinate Zero Points and Measuring Coordinates 4.3.2 Matching Coordinate Systems 4.4 Putting the Pieces Together 4.4.1 Removing Sky Gradients 4.4.2 Constructing Single Images 4.4.3 Matching Intensity Scales 4.4.4 Making the Final Stack Image .fi .sh 1. Introduction This document discusses the handling and reduction of CCD mosaic data. The software and the discussions are applicable to all CCD mosaic data which use the multiextension FITS format described below. This includes the NOAO mosaic imagers as well as similar instruments from AAO, CFA, CFHT, ESO, INT, and possibly others that I am not aware of. However, this presentation is also intended as a user's guide for the NOAO Mosaic images (currently the two 8-CCD mosaics at KPNO and CTIO and the 2-CCD mosaic at WIYN). Therefore some discussion concerns effects which may be (or may not be) specific to these systems. The NOAO Mosaic Data Handling System (MDHS) includes data acquisition, real-time, data reduction, pipeline, and archiving software. While all of the components of the MDHS may be used with a variety of instruments this document discusses only the telescope and data reduction tools which are part of the IRAF \fBmscred\fP package or general IRAF packages. This guide is not a beginner's guide and assumes some previous experience with IRAF and CCD reductions. The first section discusses the mosaic data format and how to use it with IRAF. This format is more complex than single CCD images because of the multiple CCDs and, possibly, multiple amplifiers per CCD. To keep the data from each exposure self-contained the multiple CCD images are stored in a single file. This multiple image per file has many advantages but it does mean that some commands for dealing with images behave differently. The second section describes the tools used to examine the mosaic data. These tools are used during observing as well as during data reductions. The last section describes the reduction of mosaic data. This includes basic CCD instrumental calibration and combining mosaic exposures into single images. .sh 2. Multiextension FITS Files The data format used by the NOAO Mosaic Data Handling Software (MDHS) is a multiextension FITS (MEF) file. This format is produced by the the Data Capture Agent (DCA) when observing with the NOAO mosaic cameras. For example the MEF file for the NOAO 8K mosaics currently consists of either nine or seventeen FITS header and data units (HDU). The first HDU, called the primary or global header unit, contains only header information which is common to all the CCD images. The remaining eight or sixteen HDUs, called extensions, contain the images from the eight CCDs using either one amplifier per CCD or two amplifiers per CCD. The fact that the image data is stored as a FITS file is not significant. Starting with IRAF V2.11, FITS files consisting of just a single primary image may be used in the same way as any other IRAF image format. The significant feature of the mosaic format is its multi-image structure. For a detailed discussion of the IRAF FITS Image Kernel and the syntax it supports for multiextension FITS files see ftp://iraf.noao.edu/iraf/docs/fits_userguide.ps.Z. With multiextension FITS files you must either use tasks which are specifically designed to operate on these files as a unit or explicitly specify the image within the file that is to be operated upon by general IRAF image processing tasks. The tasks in the \fBmscred\fR package are designed to operate on the mosaic MEF files and so in most cases you only need to specify the filename. For image tasks outside the \fBmscred\fR package you must specify the image in the MEF file using the syntax .nf filename[extension] .fi where "filename" is the name of the MEF file. The ".fits" filename extension is optional provided there is no confusion with other files with the same basename. The image "extension" is specified either using an extension name or the position of the extension in the file (where the first extension is 1). For example, the extension names in the NOAO mosaic data are "im1" through "im8" for eight CCDs. The same format applies for the sixteen dual-amplifier readouts and for the four dual-amplifier extensions in the WIYN 2-CCD mosaic. To get a listing of the extension names use the following command .nf ms> msccmd "hselect $input $I,extname yes" [filename] .fi If you forget to specify an extension to a task that expects only single images you will get the following error which is your reminder to include an extension. .nf ms> imhead obj012 1 ERROR: FXF: must specify which FITS extension (obj012) .fi Two of the most common tasks that require specifying an image extension are \fBdisplay\fR to display a single CCD image (the task \fBmscdisplay\fR is used to display all the images at once) and \fBimheader\fR to list the header of a particular CCD. So, for example, the following commands might be used. .nf ms> display obj012[im2] 1 ms> imhead obj012[3] l+ .fi Other tasks you may use this way are \fBimexam\fR and \fBimplot\fR. A common question is how to specify a list of extensions. Modification of the syntax to allow wildcard templates in the extension specification is under study. Currently you must specify each extension explicitly, though the filename itself may be a wildcard; for example the first image in a set of files can be collectively specified with .nf obj*[im1] .fi There are two methods for specifying some or all extensions in tasks that operate upon lists of images. One is to make @files. This can be done explicitly with an editor. However the \fBproto\fR task \fBimextensions\fR can expand MEF files into an @file as in the following example. .nf ms> imexten obj012,obj13 > list ms> imhead @list .fi Read the help page for further information, additional parameters, and examples. Another method is to use the special \fBmscred\fR task \fBmsccmd\fR. This task can be used on the command line or as a simple interactive command interpreter. The idea is that you use the special designations "$input" and "$output" for task parameters which allow lists of images. Then lists of MEF filenames are specified for the input and output which are expanded and substituted into the task parameters when it is executed. For example, .nf ms> msccmd "imhead $input l+" input=obj012,obj013 .fi For additional information and examples consult the help page for that task. Note that the tasks \fBimstat\fR and \fBimarith\fR are so useful and common that there are specific \fBmscred\fR tasks, \fBmscstat\fR and \fBmscarith\fR, that operate on all or a subset of image extensions. So these tasks need not be used with \fBmsccmd\fR or with @files. We conclude with a discussion of the special operations of copying, renaming, deleting, and reading and writing FITS tapes as they apply to the mosaic MEF files. To copy a mosaic file as a unit use \fBcopy\fR, making sure to explicitly specify the "fits" extension. If you use \fBimcopy\fR it will expect you to specify a particular extension and will copy only that extension. While \fBimcopy\fR is not the way to copy an complete MEF file the tasks \fBimrename\fR and \fBimdelete\fR are the commands for renaming and deleting these files; though \fBrename\fR and \fBdelete\fR will also work provided you are explicit with the extension. Finally the mosaic data should be kept as a MEF file and so the special mosaic tasks \fBmscwfits\fR and \fBmscrfits\fR should be used. The current \fBwfits\fR and \fBrfits\fR are not intended for this type of data. 2.1 Keywords The discussion above is independent of keywords apart for those required by the FITS standard for extensions. The only explicit keyword needed above is the EXTNAME keyword to specify the extension names that can be used to refer to the extensions by the IRAF software. However, the discussion that follows for using the \fBmscred\fR mosaic reduction tools requires the MEF files to have certain keywords. Some of the keywords are needed for basic display, some for basic CCD processing, and some for astrometric registration. The NOAO mosaic data includes all the necessary keywords. Other observatories provide some the keywords either in a form directly needed by the MSCRED tools or which can be converted to the appropriate form. For a discussion of how to setup the basic keywords for data which does not have it see http://iraf.noao.edu/projects/ccdmosaic/generic/generic.html. A complete description of the keywords and the mosaic data structure see http://iraf.noao.edu/projects/ccdmosaic/imagedef/imagedef.html. A case where the keyword information is not in the correct format but is present in the data is the ESO Wide-Field Imager (ESOWFI). A special IRAF add-on package is available to translate the raw data format into the form required by the MSCRED tools. This package is called ESOWFI and may be obtained from extern directory of the various IRAF mirror sites. .sh 3. Examining Mosaic Data During observing a small set of IRAF commands are commonly used to examine the data. This section describes these commands. While the discussion is oriented towards examining the data at the telescope during the course of observing, the tools described here are also used when reducing data at a later time. .sh 3.1 Displaying the Data The two commands \fBdisplay\fR and \fBmscdisplay\fR are used to display the data in a display server window. The display server is a separate process which must be running before displaying the images. The observing environment at the telescope will generally have the XIMTOOL display server already running with a window on a separate monitor. If it is not running for some reason it can be started with a menu selection. Away from the telescope you would start XIMTOOL or SAOIMAGE as you do normally. The display server must be told what size "frame buffer" to allocate for holding the display pixels. This determines how many pixels may be loaded at one time. Note that the display window may be smaller than this size and the display server allows you to move the portion viewed and zoom/unzoom any region. If the image size is larger than the frame buffer you can display a portion of the image at full resolution or the full image at a lower resolution. The frame buffer size is queried and set with the commands: .nf ms> show stdimage imt4096 ms> set stdimage=imt2048 .fi There are trade-offs in the frame buffer selection. A large frame buffer allows you to have higher resolution for the large mosaic images but it uses more memory and takes longer to load. The \fBdisplay\fR task is used to display individual images in the display server. This task is a standard IRAF task about which you are assumed to have some basic knowledge. There are many display options which are discussed in the help page. The only special factor in using this task with mosaic data is that you must specify which CCD image to display using the image extension syntax discussed previously. As an example, to display the central portion of extension im3 in the first frame and the whole image in the second frame: .nf ms> display obj123[im3] 1 fill- ms> display obj123[im3] 2 fill+ .fi The \fBmscdisplay\fR task is based on \fBdisplay\fR with a number of specialized enhancements for displaying mosaic data. It displays the entire mosaic observation in a single frame by "filling" each image in a tiled region of the frame buffer. The default filling (defined by the order parameter) subsamples the image by uniform integer steps to fit the tile and then replicates pixels to scale to the full tile size. The resolution is set by the frame buffer size. As mentioned before, trying to increase the resolution with a larger buffer size has the penalty of longer display times. An example display command is: .nf ms> mscdisplay obj123 1 .fi The default parameters for \fBmscdisplay\fR are shown below. Many of the parameters are the same as \fBdisplay\fR but there are also a few that are specific to the task of displaying a mosaic of CCD images as indicated with an asterisk. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscdisplay image = root name for image to be displayed frame = 1 frame to be written into * (mimpars= ) mosaic image parameters * (check = no) check if image is loaded * (onepass= no) load all extensions in one pass? (bpmask = BPM) bad pixel mask (bpdispl= none) bad pixel display (none|overlay|interpolate) (bpcolor= red) bad pixel colors (overlay= ) overlay mask (ocolors= green) overlay colors (erase = yes) erase frame (border_= no) erase unfilled area of window (select_= yes) display frame being loaded (repeat = no) repeat previous display parameters (fill = no) scale image to fit display window (zscale = yes) display range of greylevels near median (contras= 0.25) contrast adjustment for zscale algorithm (zrange = yes) display full image intensity range (zmask = ) sample mask * (zcombin= auto) Algorithm for combining z1 and z2 values... (nsample= 1000) maximum number of sample pixels to use (order = 0) spatial interpolator order (0=replicate,... (z1 = 0.) minimum greylevel to be displayed (z2 = 1000.) maximum greylevel to be displayed (ztrans = linear) greylevel transformation (linear|log|none|user) (lutfile= ) file containing user defined look up table .fi The mapping of the pixel values to grey levels includes the same automatic or range scaling algorithms as in \fBdisplay\fR. This is done for each image in the mosaic separately. The new parameter "zcombine" then selects whether to display each image with it's own independent display range ("none") or to combine the display ranges into a single display range based on the minimum and maximum values ("minmax"), the average of the minimum and maximum values ("average"), or the median ("median") of the minimum and maximum values. The independent scaling is most appropriate for raw data while the "minmax" scaling is recommend for processed data which are gain calibrated. The special value "auto" (the default) checks if the display data has been flat fielded, either by separate processing or with on-the-fly calibration, and if so it uses "minmax" scaling and if not it used independent scaling. The "mimpars" (mosaic image parameters) parameter is actually a reference to another set of parameters. The default with no value is to use the parameters from the parameter task \fBmimpars\fR. These parameters can be examined and set with \fBepar\fR either by typing ":e" when over this parameter in \fBmscdisplay\fR or by running \fBepar\fR directly on this task; i.e. epar mimpars. The parameters for NOAO Mosaic data are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mimpars (extname= ) extension name pattern (exttmpl= _![1-9]![1-9]![1-9].*) extension template (xgap = 72) minimum X gap between images (ygap = 36) minimum Y gap between images (process= no) do calibration processing? (oversca= yes) do line-by-line overscan subtraction? (flatfie= yes) do flat field correction? (caldir = mscdb$noao/kpno/4meter/caldir/) calibration directory (filter = !filter) filter .fi The "extname" parameter is used to select as subset of the image extensions to display. It is a pattern to match extension image names. For extensions such as im1, im2, etc. the pattern typically uses the character selection template such as "[1256]" to select anything with a 1, 2, 5, or 6 in the name. The pattern matching syntax can be found in the help for the task \fBmatch\fR. The "exttmplt" parameter is for use with non-MEF data. The gap parameters define the gap size in the display. The remaining parameters are for the on-the-fly calibration discussed below. .sh 3.1.1 On-the-Fly (OTF) Calibration Raw mosaic data can exhibit significant instrumental artifacts which may interfere with inspecting the data prior to reductions. The most significant artifact is gain variations both within each CCD image and between the CCDs. In the simplest case of constant gain variations between the CCDs the independent display scaling, "zcombine" of none or auto, may be sufficient. But when there are significant flat field patterns it may be desirable to apply a quick, approximate flat field calibration as the data are being displayed. \fBMscdisplay\fR can apply an on-the-fly (OTF) calibration to raw mosaic exposures. This does not change the actual data files and the calibration is intended to be quick and approximate. The calibration steps performed are a line-by-line bias subtraction using the overscan region of the data and a division by a flat field. If the data have been overscan corrected or flat field corrected by \fBccdproc\fR then the task will automatically skip those steps. The title of the display will indicate if the data have been calibrated by adding "[bias]" for bias subtraction and "[bias,flat=XXX]" for bias subtraction and flat fielding using an OTF flat field called XXX. The bias subtraction is performed by averaging the overscan pixels in a line and subtracting this average from all the pixels in the line. This removes the amplifier bias and line-by-line patterns. The flat field or response calibration is performed by reading special compact flat field calibration data which provides an approximate relative response for each pixel in each amplifier readout. Depending on how the calibration file is derived this will approximately correct for pixel sensitivity variations, gain variations between the amplifiers, sky illumination variations, and any pupil ghost pattern (as occurs with NOAO Mosaic data from the Mayall (KPNO 4meter) telescope). The "process" parameter in the \fBmimpars\fR parameter set shown earlier selects whether to turn on or off the OTF processing. If it is no then regardless of the "overscan" or "flatfield" parameter settings no calibration is applied. If it is yes then one or both calibration operations can be selected. Because the \fBmimpars\fR parameters can be set on the command line, it is common to leave the "process" parameter set one way, say to "no", and then override the value when displaying. For example, .nf ms> mscdisplay obj023 1 proc+ ms> mscdisplay flat022 2 proc+ flatfield- .fi The flat field calibration requires special calibration files. The "caldir" parameter defines a directory containing the calibration files. This can be a standard directory or a user directory. Note that if a directory is specified it must end with $ or /. Within the calibration directory the calibration file to apply is selected by the "filter" parameter. For automatic selection of calibrations, the calibrations can be selected by the filter string in the header (or by giving the same filter string in the "filter" parameter). To use the filter string in the header the value of the filter parameter is set to "!" where is the keyword for the filter string. Creating the a calibration directory and calibration files is done with the task \fBmscotfflat\fR. For the NOAO Mosaic a calibration directory is provided. However you can create your own as described in the help for \fBmscotfflat\fR. The "filter" parameter can be set to one of these names. .sh 3.1.2 Real-Time Display with the DCA During data acquisition the \fBmscdisplay\fR task can be used to display mosaic data as it is being written to disk by the DCA. It begins execution shortly after the readout begins and displays the portion of the recorded image which has been written to disk. It then continually displays new data which has been written by the DCA until the exposure is completely written to the display. The DCA control panel allows you to select whether to display the data during readout and how it is to be displayed. This includes selecting the OTF calibration. One toggle is equivalent to the "process" parameter. If the processing is turned on the DCA automatically selects only overscan bias subtraction for non-object exposures and selects both bias subtraction and flat field division for object exposures. The "filter" parameter is set by passing through the filter string from the data acquisition system or by overriding this and using the filter menu to select one of the available calibrations. .sh 3.2 Examining the Data The task \fBmscexamine\fR allows interactive examination of mosaic images. It is essentially the same as the standard \fBimexamine\fR task except that it translates the cursor position in a tiled mosaic display into the image coordinates of the appropriate extension image. Line and column plots also piece together the extensions at the particular line or column of the mosaic display. To enter the task after displaying an image the command is: .nf ms> mscexam .fi As with \fBimexamine\fR, one may specify the mosaic MEF filename to be examined and if it is not currently displayed it will be displayed using the current parameters of \fBmscdisplay\fR. It is important to realize that this task shares the \fBmimpars\fR parameters with \fBmscdisplay\fR. To get data values back that match what is displayed the parameters must agree with those used to display the data. In particular, if the data are display with OTF processing then \fBmscexam\fR must be told this either by explicitly setting the process flat in \fBmimpars\fR or setting it on the command line, .nf ms> mscexam proc+ .fi .sh 3.3 Examining the Headers There was discussion earlier concerning the use of generic image tasks with the NOAO Mosaic data. The tasks \fBimheader\fR and \fBhselect\fR fall into this category. The two important points to keep in mind are that you must specify either an extension name or the extension position and that the headers of an extension are the combination of the global header and the extension headers. Often one does not need to list all the headers for all the extensions. The image title and many keywords of interest are common to all the extensions. Thus one of the following commands will be sufficient to get header information about an exposure or set of exposures: .nf ms> imhead obj*[1] l- # Title listing ms> imhead obj123[1] l+ | page # Paged long listing ms> hselect obj*[1] $I,filter,exptime,obstime yes .fi If you need to list header information from all the extensions then you need to take the additional step of creating an @file or using \fBmsccmd\fR. For example to get the default read noise and gain values for each CCD: .nf ms> imextensions obj123 > list123 ms> hselect @list123 $I,rdnoise,gain yes or ms> msccmd "hselect $input $I,rdnoise,gain yes" input=obj123 .fi The \fBccdlist\fR task in the \fBmscred\fR package is specialized for the mosaic data. It provides a compact description of the name, title, pixel type, filter, amplifier, and processing flags. The "extname" parameter may be used to select a particular extension, a set of extensions, or all extensions. Because all extensions should generally be at the same state of reduction it may be desirable to list only the first extension. Like most of the CCD reduction tasks you can also select only a certain type of exposure for listing. Examples of the two modes are: .nf # Summary for all exposures ms> ccdlist *.fits extname=im1 # Summary for all object exposures ms> ccdlist *.fits extname=im1 ccdtype=object # List of all extensions. ms> ccdlist obj123 extname="" .fi .sh 3.4 Determining Best Focus Focus sequence frames can be evaluated for the best focus using \fBmscexam\fR and the 'r' or 'a' keys. However, there is a special task for measuring the sequence of focus images called \fBmscfocus\fR. This displays a focus exposure with \fBmscdisplay\fR (if needed) and then lets you select one or more bright stars to measure. This task is customized so that all you need do is mark the top image in any CCD. For NOAO Mosaic data, header information tells the task how many exposures, the spacings between the exposures, and the focus values. After the measurements are made they are displayed and analyzed graphically and written to the terminal and logfile. This task is the mosaic analog of the \fBkpnofocus\fR and \fBstarfocus\fR tasks for single CCD data. .sh 4.2.1 Calibration Data to Obtain At the Telescope Good data reductions begin with obtaining good calibration data at the telescope. This section discusses the NOAO Mosaic but the general principles will apply to other detectors, though the relative importance of different calibrations will depend on the quality of the CCDs and the stability of the camera. The standard calibration data are sequences of zero exposures and sequences of dome flat field exposures. While dark count exposures, matched to the typical object exposure times, were important for the first generation (engineering grade) NOAO Mosaic, dark counts are expected to be low in the science grade detectors. Thus dark count exposures are probably not necessary. Dome flat fields (dome flats) provide a fair basic flattening of the data to 2% or so, but sky flat fields (sky flats) are required to produce dithered data that can be combined without introducing obvious artifacts. Good sky flats can flatten the data to 0.1%. In our experience twilight exposures do not work well. Instead dark sky flat fields are derived from unregisted object exposures taken during the night or run. If your observing program consists of only large extended objects or single pointings then you should also take some dithered exposures of "blank" sky. At the Mayall telescope there is a pupil image caused by reflections off the corrector. For broadband photometry the effects of the pupil image are small but they can be reduced even further by reduction steps to remove the image. One useful calibration for this removal is a narrowband dome flat field. The idea is that the narrowband flat field has a more prominent pupil image that can be used as a template for the much fainter broadband pupil image. Lastly, good astrometry is required to register and stack the Mosaic images. The NOAO Mosaic data contains previously determined astrometry recorded in the headers of the raw exposures. This is sufficient for most purposes. However, for cameras without astrometry or to generate your own astrometry solutions, fields with a reasonable density of stars with cataloged accurate coordinates must be taken. Note that with the new generation of large astrometric catalogs and the large field of view of a mosaic, it may be that the object exposures already contain sufficient information for deriving new astrometric calibrations or corrections. Note that this guide does not yet discuss how to create the astrometric coordinate system solutions. .sh 4. Data Reductions The reduction of CCD mosaic data can be divided into two stages, the basic photometric and astrometric calibration of the individual CCDs and putting the pieces together into single images. Another way to think of this division is that in the first stage the pixels are not resampled or interpolated while in the second stage they are. The first stage is similar to reducing data from single CCD exposures except that the calibration operations are repeated for all the CCDs in the mosaic. Some operations must also be constrained to maintain the photometric and astrometric relationships between the CCDs. The details of repeating the calibrations for all CCDs and maintaining the relationships are taken care of by the software and the data format so that these operations appear similar to reducing single CCD data. The steps in this stage consists of photometrically calibrating each pixel and astrometrically calibrating the coordinate system mapping between pixel coordinates and celestial coordinates. The photometric calibration includes flat fielding as well as removal of instrumental artifacts such as amplifier crosstalk and reflections. The astrometric calibration includes determination of the basic coordinate system mapping and adjustments for telescope pointing errors, instrumental rotation, and atmospheric refraction. The second stage of data reductions is more unique to mosaic data though some aspects are similar to combining any set of dithered exposures. This stage consists of combining of the multiple CCD images and multiple exposures into a single image. Since creating a single image from a single mosaic exposure is of marginal value, the thrust of this stage of the reductions is the combining of multiple exposures which have been spatially offset or "dithered" to cover both the gaps between the individual CCDs and any defects. The steps required to produce a single deep integration from dithered mosaic exposures consist of accurately registering the exposures, mosaicing the multiple CCD images in each mosaic exposure into single images with the same spatial sampling, correcting for variable sky gradients, measuring changes in the intensity scale due to variations in transparency and sky brightness, and combining the individual mosaiced images into a single deep image with the gaps between the individual CCDs and any bad pixels removed. Some of the steps described here do not apply to all mosaic data. These are removing instrumental artifacts from the controller, the camera, and the telescope. Specifically there is discussion of removing amplifier crosstalk, pupil ghost reflections, and variable pixel scale photometric effects. These artifacts occur with the NOAO Mosaics and telescopes and the discussion will be somewhat specific to this data, though it may apply to other mosaic instruments and telescopes. If your data does not have there artifacts you can skip these steps. Combine zero exposures Combine dark exposures Combine dome flat field exposures Remove pupil ghost from the combined dome flat field Process object exposures Remove pupil ghost from object exposures Remove fringing from object exposures Apply sky flat field Calibrate coordinates Mask cosmic rays and bleed trails Create single images from the mosaic pieces Remove sky gradients Match flux scales for dithered exposures Stack dithered exposures Iterate .sh 4.1 Some Preliminaries The command \fBsetinstrument\fR is used to set default parameters for the tasks in the \fBmscred\fR package appropriate to a particular instrument. Not all instruments will have instrument setup files. When there are no setup files you simply need to review and set the \fBmscred\fR package and task parameters manually. Note that the \fBesowfi\fR add-on package, which provides an interface to the more generic \fBmscred\fR package, has its own setup command, \fBesosetinst\fR. Currently there are setup files for the NOAO Mosaics available through the NOAO "mscdb" distribution which provides various runtime files such as those used by \fBsetinstrument\fR as well as the calibration files for bad pixels, crosstalk, and coordinate system, provided by the NOAO support staff. The \fBsetinstrument\fR command shuld only be run the first time you reduce data. Subsequently you should not do this since it will reset parameters you may have later changed. To set the parameters for reducing the NOAO Mosaic data type one of the following command nf ms> setinstrument ctio 4meter Mosaic2 review- ms> setinstrument kpno 4meter CCDMosaThin1 review- ms> setinstrument kpno 36inch CCDMosaThin1 review- ms> setinstrument kpno wiyn minimosaic review- .fi where the first argument is the observatory, the second is the telescope, and the third is a camera name. If the task is run without arguments then you will be queried for each argument and a '?' may be entered to get a list of available sites, telescopes, and instruments. For some of the operations it is useful to specify lists of exposures corresponding to a dither set. The examples in this guide show using @files for dither sets. An @file is simply a list of filenames. These can be created in several ways including using a text editor. One way is with the \fBfiles\fR command to expand a file template. For example, .nf ms> files obj021,obj022,obj023,obj024,obj025 > field1 ms> dir @field1 obj021 obj002 obj003 obj004 obj005 .fi .sh 4.2 Basic CCD Calibration Basic CCD instrumental calibrations consist of correcting each CCD for amplifier crosstalk, electronic bias levels, zero length exposure patterns, dark counts, and pixel sensitivities. A cosmetic replacement of bad pixels may also be performed and saturated or non-linear pixels (determined from the original pixel values before any corrections are applied) may be added to a bad pixel mask. When multiple amplifiers are used for each CCD the extensions for amplifiers from the same CCD may be consolidated into a single extension after the basic overscan bias correction is completed. The task which provides all these operations is \fBccdproc\fR. The parameters of this task are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = ccdproc images = List of Mosaic CCD images to process (output = ) List of output processed images (bpmasks= ) List of output bad pixel masks (ccdtype= object) CCD image type to process (noproc = no) List processing steps only? (xtalkco= yes) Apply crosstalk correction? (oversca= yes) Apply overscan strip correction? (trim = yes) Trim the image? (fixpix = yes) Apply bad pixel mask correction? (zerocor= yes) Apply zero level correction? (darkcor= no) Apply dark count correction? (flatcor= yes) Apply flat field correction? (sflatco= no) Apply sky flat field correction? (merge = yes) Merge amplifiers from same CCD? (saturat= INDEF) Saturation (xtalkfi= !xtalkfil) Crosstalk file (biassec= !biassec) Overscan strip image section (trimsec= !trimsec) Trim data section (fixfile= BPM) List of bad pixel masks (zero = Zero) List of zero level calibration images (dark = Dark) List of dark count calibration images (flat = Flat*) List of flat field images (sflat = Sflat*) List of secondary flat field images (minrepl= 1.) Minimum flat field value (interac= no) Fit overscan interactively? (functio= legendre) Fitting function (order = 1) Number of polynomial terms or spline pieces (sample = *) Sample points to fit (naverag= 1) Number of sample points to combine (niterat= 1) Number of rejection iterations (low_rej= 3.) Low sigma rejection factor (high_re= 3.) High sigma rejection factor (grow = 0.) Rejection growing radius .fi The parameter values are those set by \fBsetinstrument\fR for the NOAO 8K Mosaics. The parameters for \fBccdproc\fR must be set before any processing of the data takes place. This is because the first actual processing is the preparation of the calibration data using tasks that combine sequences of zero level, dark count, and dome flat field exposures. The tasks that do these operations use \fBccdproc\fR. The remainder of this sections briefly describes each of the operations performed by \fBccdproc\fR in the order in which they occur. The next section begins Before describing the preparation of the calibration data in the following section this section o This is recommended and is currently required to avoid problems at the boundaries between the different amplifier images with the task that resamples the mosaic data into a single image. The location of bad pixels continues to be maintained in the bad pixel masks and so this step is useful for display and to avoid problems with tasks that don't use the bad pixel masks and may misbehave unless the pixel values are reasonable. .sh Amplifier Crosstalk Removal The CCD amplifiers in mosaic cameras are typically readout in parallel. It is possible that coupling in the controller electronics will introduce crosstalk resulting in the pixel values produced by one amplifier being affected by the signal in another amplifier. There are many ways this crosstalk may affect the data. The mosaic reduction software currently includes a way to correct or flag pixels based on a simple crosstalk model. In this model the signal for a pixel in one amplifier, which we call the "source", adds or subtracts a small amount to the pixel value read at the same time in another amplifier, called the "victim". The amount is either proportional to the source signal level or has a threshold effect. In the first case a correction can be obtained by multiplying the pixel value of the source image by a crosstalk coefficient and adding or subtracting from the matching pixel in the victim image. In the second case a source pixel value which is above some level affects the victim pixel in some indeterminate way and all that can be done is flag the pixel. In this case it is assumed that lower pixel values in the source do not affect the victim. Note that it is possible that a source may also be a victim and that a victim may be affected by multiple sources. In this simple model each pair of source and victim are treated independently and the source pixel values used to correct a victim are treated as unaffected by other amplifiers. For small crosstalk coefficients this is may be an acceptible approximation. The crosstalk coefficients may be estimated using the task \fBxtcoeff\fR. This requires having data with many stars per amplifier and levels up to saturation. There is a balance between having many bright stars but not so many that most victim pixels matching bright stars in one amplifier will also have stars affecting the pixel value. In order to estimate the crosstalk the ghosts of the bright stars should fall on pure sky. Currently this task only works when the victim and source images have the same readout order when match in image pixel coordinates. This means that if the data acquisition system flips different amplifiers into a standard orientation on the sky when writing the values to the image extensions then the victim and source images must come from the same CCD amplifiers. This means the task currently only works for the NOAO 8K mosaics read with one amplifier per CCD. The NOAO 8K mosaics have crosstalk that is clearly visible as ghosts of bright stars from one amplifier appearing in one or more other amplifiers. The electronic basis of this crosstalk is not currently understood. The simple model described above removes the ghosts and appears to be a satisfactory solution. The instrument support scientists recommend using this crosstalk removal method with crosstalk coefficient files they supply. While the crosstalk correction software has recently incorporated the possiblity of flagging the pixels this has not yet been added to the data reduction path described here. The WIYN MiniMosaic uses modified versions of the same controllers as the 8K mosaics. However, at this time it appears the nature of the crosstalk is more in the second case of a threshold effect. This is compounded by the fact that the gain is such that high signal levels are lost in digital saturation. The crosstalk model described here is implemented by the \fBmscred\fR task \fBxtalkcor\fR. It may be used directly before running \fBccdproc\fR or by setting the "xtalkcor" parameter in \fBccdproc\fR to yes. The crosstalk coefficient file is specified by the "xtalkfile" parameter. The NOAO mosaic data acquisition systems include the keyword XTALKFIL in the data headers with the recommended crosstalk calibration file from the mscdb calibration directory. So to use the recommended file set the "xtalkfile" parameter to "!xtalkfil" which references the file given by the keyword. If you have some data with bright stars in each amplifier you can try and measure the crosstalk coefficients yourself with the task \fBxtcoeff\fR. For NOAO 8-channel and 16-channel data use .nf ms> xtcoeff [images] myxtalkfile @vnoao8 @snoao8 interactive+ ms> xtcoeff [images] myxtalkfile @vnoao16 @snoao16 interactive+ .fi respectively. The @files include all the pairs of amplifiers which affect each other. In the interactive mode for each pair of amplifiers graphs of coefficient estimates for pairs of pixels in which the source is greater than 20000 ADU are plotted as a function of source ADU. The constant fit is the crosstalk coefficient estimate. In the interactive plots use the 's' key to set regions to include in the fit and the 't' key is used to clear the sample. The purpose of this is to avoid source pixels which contaminate victim pixels that already have an object leading. For more information read the help for the task. .sh Bad Pixel Interpolation and Saturation Flagging Bad pixels are identified by non-zero integer values in a bad pixel mask. There is a separate bad pixel mask for each CCD. When there are multiple amplifiers per CCD there need only be one mask covering the whole CCD since the portion of the mask covering each amplifier image can be determined from coordinate information in the headers. The mask for each extension is specified through the BPM keyword in the header. Because the bad pixel masks provide a record of where the bad pixels are and the values of the pixels are not scientifically useful, the values of those pixels can be changed for cosmetic purposes and to provide benign values for tasks which don't use the masks and might otherwise misbehave. The "fixpix" option in \fBccdproc\fR replaces the bad pixels, where the bad pixel masks are specified by the "fixfile" parameter with the value "BPM", by interpolation. Note that this is done on the input pixel values and not the output. Typically the bad pixel masks applied at this point are maps of the non-linear pixels in the CCDs. These are the same for all exposures. For the NOAO mosaics BPM keywords point to standard calibration masks. The fixpix/fixfile parameters define input masks. \fBCcdproc\fR can also produce output pixel masks which merge the input masks with saturated pixels added. Obviously each exposure will produce its own masks. The masks are produced if a bad pixel mask name for each processed exposure is specified with the "bpmasks" parameter. Currently subdirectories with the specified name are created into which the individual masks for each extension are written. The BPM keyword in the processed data are reset to the new masks. Saturated pixels must be identified in the raw counts before any other calibration, though the crosstalk correction may occur first but this only makes small changes to the values. ....... with unrealistic values. scientific data. The bad pixel are initially the non-linear pixels in the CCDs which are the same for all exposures. by The mask is specified in the BPM keyword in each image extension. Initiall image in pixel list format. Pixel list format is a special format that is well suited to .sh Electronic Bias Removal and Overscan Trimming Electronic bias removal is a standard CCD reduction step where overscan data is used to estimate the electron bias level. To include this step set the "overscan" parameter to yes and define the overscan bias region with the "biassec" parameter. NOAO mosaic data includes the bias region appropriate for each amplifier image in the header keyword BIASSEC. To reference this keyword value set the parameter to "!biassec". The set of parameters from "interactive" to "grow" define how the overscan region is used to estimate the bias level at each line. This is described in the help for this task. After the bias is estimated and removed the overscan region is no longer needed and it is removed by trimming the image to only the actual CCD data. The trimming can also be used to remove border pixels which might be bad. The region to be kept after trimming is specified with the "trimsec" parameter. NOAO mosaic data also includes the trim region in a keyword called TRIMSEC. To reference this keyword value set the parameter to "!trimsec". Note that in order to merge multiple amplifier readouts from the same CCD the data must be trimmed. .sh 4.2.2 Preparing Calibration Data This section describes how to prepare the basic calibration data. The steps are virtually the same as with the \fBccdred\fR package and, in fact, the command names and parameters are the same. The basic calibration data of zero level, dark count, and dome flat fields are generally taken as a sequence of identical exposures which are combined to minimize the noise. Later sections discuss correcting the flat fields for pupil ghost reflections and preparing a sky flat field calibration using the object exposures. The calibration exposures are individually reduced by \fBccdproc\fR and then combined. Thus, it is necessary to first set the \fBccdproc\fR parameters. Because this task knows which operations are appropriate for particular types of calibration exposures you can set all the parameters for object exposures. Below is a typical set of parameters. The main optional setting is whether or not to replace bad pixels by interpolation, which is purely a cosmetic correction. However, it is recommended that this be done to avoid possible arithmetic problems in the processing. The overscan correction has two methods as selected by the fitting function. A value of "legendre" (or "chebyshev" or "spline3") take all the overscan data and fit a smooth function along the column direction. The "order" value of 1 shown above fits a single constant value. This leaves to the zero level calibration to subtract any details of line-by-line structure. A value of "mean", "median", or "minmax" take the mean, median, or mean excluding the minimum and maximum values, of the overscan at each line and subtract that value from that line. The other fitting parameters are ignored. The advantage of this is that systematic line-by-line patterns are subtracted. The disadvantage is, since the sample of overscan pixels is small at each line, that this can also introduce a statistical line-by-line pattern. There is currently no recommendation for the NOAO Mosaic. The first step is generally to process and combine sequences of zero, dark, and dome flat exposures. This is done using the tasks \fBzerocombine\fR, \fBdarkcombine\fR, and \fBflatcombine\fR. The combining must be done in the following order since the processing of later calibration data requires the preceding calibration data. .nf ms> zerocombine *.fits ms> darkcombine *.fits ms> flatcombine *.fits .fi Each of these tasks search all the exposures for a particular type so it is fine to specify all files, though if the file names code the type, such as "dflatNNN", then one can use that as the wildcard to shorten the search of all the data. Also \fBflatcombine\fR has the feature that it will combine the data separately for each filter. However, you can use explicit file lists, templates, or @files to limit the input files. The output combined names have standard default values which the above settings for \fBccdproc\fR use. It is a good idea to first check that the different calibration types and filters are correctly identified by the software. This is done using the \fBccdlist\fR command .nf ms> ccdlist *.fits .fi Unless you change the parameters "mscred.backup" and "mscred.bkuproot" the original raw files will be saved in the subdirectory "Raw/". If you want to start over, delete the processed files and copy the raw files back to the working directory. If disk space is a concern and you are satisfied with the combined calibration files you can delete the individual processed calibration files. There is a parameter in the combining tasks that will delete the individual files automatically after processing and combining. .sh 4.2.3 Pupil Image Removal from Flat Fields ---- At the Mayall telescope there are reflections off the corrector that produce a visible image of the pupil. Coating of the corrector minimizes this image but it may be desirable to remove this instrumental signature which would otherwise cause a small variation of the photometric zero point as well as an unwanted visible feature. There are two sections discussing removal of this feature from the flat field data and from the object exposures. If your data is from the KPNO 0.9 meter telescope or the image is faint enough that it is not of concern then you can skip the extended discussion. ---- ---- For the Mayall telescope the pupil image due to reflections off the corrector must be removed from the flat field and object exposures. An additional calibration is required to correct for the variable pixel scale across the field of view if you intend to do photometry on the individual CCD images. ---- NOAO Mosaic data taken at the Mayall (4meter) telescope include a pupil image caused by reflections off the corrector. The magnitude of this image is a function of the filter and the state of the anti-reflection coatings on the corrector. It is also a function of the total light, including from outside the field of view, and somewhat on the location of bright stars. It might appear at first that one simply divides the object exposures by the flat field as is done for the OTF display calibration. However this is not photometrically correct because the pupil image is an additive light effect and not a detector response. Instead the pupil image must first be removed from the flat field before applying it to the object data. The object data is then corrected after flat fielding by subtracting the extra light from the pupil image. The pupil image is removed from the flat field by dividing by an estimate of the pupil image pattern. The challenge is to determine the pupil image contribution in the presence of other flat field structure. There are two current approaches to obtaining the pupil image pattern for removal from the data. One is to use data from another source where the pupil pattern is more easily separated from the flat field pattern. The second is to derive the pattern from the data assuming something about the form of the pattern. In particular, to use the difference in scales between the larger pupil pattern and the smaller flat field pattern. The first approach is preferable since it better preserves fine structure in the pupil image but the second is needed when no other data is available. .sh 4.2.3.1 Broadband Data For broadband data the recommended procedure is to obtain a narrowband flat field exposure. This narrowband exposure will have a stronger pupil image relative to the flat field pattern and, when the pupil image is scaled down to match the broadband image flat field, the errors from the flat field response will be diminished. The pupil image is extracted from the narrowband flat field using the task \fBmscpupil\fR. This task determines the background levels in a ring inside and outside the main pupil image and subtracts this background to produced the pupil image template. Outside the outer background ring the template is set to zero. In effect this is like "scrapping off" the pupil image from the exposure. The relevant parameters are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscpupil input = List of input images output = List of output images (masks = BPM) List of masks (type = data) Output type (xc = 27.) Pattern center offset (pixels) (yc = 9.) Pattern center offset (pixels) (rin = 300.) Radius of inner background ring (pixels) (drin = 20.) Width of inner background ring (pixels) (rout = 1500.) Radius of outer background ring (pixels) (drout = 20.) Width of outer background ring (pixels) (funcin =chebyshev) Inner azimuthal background fitting function (orderin= 2) Inner azimuthal background fitting order (funcout= spline3) Outer azimuthal background fitting function (orderou= 2) Outer azimuthal background fitting order * (rfuncti= spline3) Radial profile fitting function * (rorder = 40) Radial profile fitting order * (abin = 0.) Azimuthal bin (deg) * (astep = 0.) Azimuthal step (deg) (niterat= 3) Number of rejection iterations (lreject= 3.) Low rejection rms factor (hreject= 3.) High rejection rms factor (datamin= INDEF) Minimum good data value (datamax= INDEF) Maximum good data value (verbose= yes) Print information? .fi The output type is set to "data" to extract the pupil image after background subtraction. The pattern center parameters are offsets from the astrometric center and the inner and outer radii are measured from the pattern center. The default values are for the last measured Mayall pupil image. The fitting parameters marked with an asterisk are not used when extracting the pupil image directly. The pupil image template is scaled and removed from the flat field using the task \fBrmpupil\fR. The removal is done with the arithmetic operation .nf I(out) = I(in) / (scale * I(template) + 1) .fi where I(out) are the output corrected pixel values, I(in) are the input pixel values, I(template) are the pupil image template pixel values, and scale is the relative scale factor to be applied. The parameters for the pupil image removal task are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = rmpupil input = Input mosaic exposure output = Output mosaic exposure template= Template mosaic exposure (type = ratio) Type of removal (extname= [2367]) Extensions for fit (blkavg = 8) Block average factor (fudge = 1.6) Fudge factor (interac= yes) Interactive? (mscexam= no) Examine corrections with MSCEXAM? .fi The "input" is the broadband flat field, the "output" is the corrected flat field, and the "template" is the narrowband pupil image produced by \fBmscpupil\fR. The type of removal for a flat field is "ratio" as given by the equation above. Determining the optimal scaling of the template pupil image to the input pupil image is normally done interactively. The task makes a guess at scaling. If this task is used non-interactively this will be the scale used. When the task is used interactively the input and corrected mosaic exposures are displayed and then a query for a new scale is given. By repeatedly adjusting the scale factor the best visual removal can be obtained. When done the output corrected flat field is created using the last specified scale factor. Note that to quit requires entering dummy special values for the scale factor. A value of zero means to create the final output exposure with the last scale factor and a value of -1 means to quit without producing any output. Because this operation is fairly slow and iterative there are some steps that can be taken to it speed up. The "extname" parameter selects just those extensions to look at. For NOAO Mosaic data the default selects the central four extensions covered by the pupil image. The "blkavg" parameter applies a block average to the input exposure and template. This makes the display and iterative corrections faster. When the best scale factor has been determined the entire input image at full resolution is corrected by the full resolution template to create the output flat field. If one wants to use the facilities of \fBmscexam\fR to evaluate each iterative correction then the "mscexam" parameter can be set. However, the most powerful estimate for the optimal scale factor is viewing the display and possibly blinking between the uncorrected and corrected frames. .sh 4.2.3.2 Narrowband Data For narrowband data the pupil image template must be derived from the data itself. This is done by fitting the data with an axially symmetric pattern. The fitting is performed by \fBmscpupil\fR with the parameters .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscpupil input = List of input images output = List of output images (masks = BPM) List of masks (type = ratio) Output type (xc = 27.) Pattern center offset (pixels) (yc = 9.) Pattern center offset (pixels) (rin = 300.) Radius of inner background ring (pixels) (drin = 20.) Width of inner background ring (pixels) (rout = 1500.) Radius of outer background ring (pixels) (drout = 20.) Width of outer background ring (pixels) (funcin =chebyshev) Inner azimuthal background fitting function (orderin= 2) Inner azimuthal background fitting order (funcout= spline3) Outer azimuthal background fitting function (orderou= 2) Outer azimuthal background fitting order (rfuncti= spline3) Radial profile fitting function (rorder = 40) Radial profile fitting order (abin = 0.) Azimuthal bin (deg) (astep = 0.) Azimuthal step (deg) (niterat= 3) Number of rejection iterations (lreject= 3.) Low rejection rms factor (hreject= 3.) High rejection rms factor (datamin= INDEF) Minimum good data value (datamax= INDEF) Maximum good data value (verbose= yes) Print information? .fi Note that this only differs from the previously shown parameters by setting the "type" parameter to ratio. Because the template is derived from the data itself there is no need to use \fBrmpupil\fR to iteratively determine a scale factor. The "output" parameter is the corrected flat field. The corrected narrowband flat field will show some artifacts from fine structure in the pupil image. However, a large fraction of the pupil image will be removed. Later reduction steps of applying a sky flat field and combining with dithering further eliminate effects of this approximate solution to the pupil image. .sh 4.2.4 Object Exposure Reductions At this point you will have some subset of combined zero level, dark count, and flat field calibration data. The calibration data is applied to the object exposures, either in bulk or as observations are completed, using the task \fBccdproc\fR. The command is simply .nf ms> ccdproc .fi .sh 4.2.5 Pupil Image Removal from Object Data The pupil ring image in the object exposures is removed by subtraction since this is excess light. Again this is only required for data where the pupil image occurs, such as from the Mayall telescope. The tasks for modeling and removing the image are the same as for removal from the flat field except that the "type" parameter is set to "difference". .sh 4.2.5.1 Broadband Data Probably the best subtraction will be obtained by using the pupil image template from a narrowband flat field. This would be the same as used for the flat field and extracted from the narrowband flat field using \fBmscpupil\fR with "type = data". The subtraction is carried out using \fBrmpupil\fR with "type = difference". An alternative, since the pupil image is weak and the fine structure is unimportant, is to use \fBmscpupil\fR with "type = difference" to determine a smooth large scale ring pattern and subtract it from the data. The iterative sigma rejection and the "datamin" and "datamax" parameters are used to eliminate smaller scale astronomical objects in the field from affecting the background fits and the ring profile fits. For this application the "abin" parameter should be set to a value such as 30 degrees and the "astep" parameter to a smaller value such as 5 degrees. The main advantage of this method is that no iterative scaling is required since the fit is done directly to the data. The difficulty, though, is if there is a bright star or fairly extended object, particularly in the inner background ring, then the fit will be poor and the subtraction will show gross artifacts. The last alternative, and the one to use if there is no narrowband flat field for the template and the field has bright stars which affect fitting directly to the data, is to make a "sky flat" to generate the pupil image template. This is done as described in the section for creating a sky flat. Once the sky flat is created with the pupil image then \fBmscpupil\fR is used to separate the pupil image from the background and \fBrmpupil\fR is used to scale and subtract the image from the object exposures. Note that after the pupil image is subtracted then a new sky flat should be created. .sh 4.2.5.2 Narrowband Data For narrowband data the two alternatives described for the broadband data are used. The first is to fit and subtract a smooth ring model from each object exposure using \fBmscpupil\fR. This is the same as described for removing the pupil image from the flat field except the "type" parameter is set to difference. The second is to create a sky flat from disregistered exposures, extract the pupil pattern with \fBmscpupil\fR, and then subtract it from each object exposure using \fBrmpupil\fR. .sh 4.2.6 Dark Sky or Twilight Sky Flat Fields You will notice that there are two flat field corrections which can be performed by \fBccdproc\fR. The first one is for an initial flat field such as the dome flat obtained at the beginning of the night, a standard flat field from a previous night or run, or a final combined dome flat and sky flat from some other night or run. The second is for a dark sky or twilight sky flat field prepared from the object exposures after they have been calibrated with the first flat field. Sky flat fields are created by combining object exposures with objects removed by using data in each pixel that is only sky. In principle one could use exposures of the twilight sky but our experience is that these do not work well. You are welcome to take some exposures and try using them. We have found that dark sky flat fields derived from the object exposures do work quite well. Mosaic observations already typically dither a field. One will do even better by combining observations from other fields. The more data used the better the resulting sky flat will be. The main criterion for including data is to avoid observations contaminated by varying background light from the moon or scattered light from bright stars off the field. Of course, another factor that has to be considered is whether a field has a very large extended object which appears in many of the observations. These will not be useful. The sky flat field is created using the task \fBsflatcombine\fR with parameters selected to reject objects appearing above a median. We don't have much experience with creating sky flats currently so some experimentation with parameters may be required. Below is one possibly set of parameters. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = sflatcombine input = List of images to combine (output = Sflat) Output sky flat field root name (combine= average) Type of combine operation (reject = avsigclip) Type of rejection (ccdtype= object) CCD image type to combine (subsets= yes) Combine images by subset parameter? (scale = mode) Image scaling (statsec= ) Image section for computing statistics (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 6.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= rdnoise) ccdclip: CCD readout noise (electrons) (gain = gain) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (pclip = -0.5) pclip: Percentile clipping parameter (blank = 1.) Value if there are no pixels (grow = 3.) Radius (pixels) for neighbor rejection .fi This task is a combination of \fBccdproc\fR to first process the images, if they have not previously been processed, and \fBcombine\fR to combine the offset images with rejection of object pixels. A new feature of this task is the "grow" parameter which now provides a two dimensional circular rejection of pixels around pixels rejected by the rejection algorithm. Whatever rejection algorithm is used it is likely that the best results will be when the clipping sigmas are non-symmetric as shown above. Note that a very low rejection threshold or very large grow radius will make the task quite slow. After producing a good sky flat that has no evidence of objects it may be applied directly to the data by using it as the second flat field correction. .nf ms> ccdproc sflatcor=yes sflat=Sflat* .fi Note that the object exposures used in creating the sky flat will already have been processed except for the application of the sky flat so \fBccdproc\fR will only apply the sky flat field calibration. The sky flat field includes corrections at all scales from pixel-to-pixel sensitivity variations to large scale illumination differences. If the signal-to-noise is poorer than the dome flat field you might wish to apply a filtering/smoothing operation to the sky flat data thus relying on the dome flat field for the pixel-to-pixel sensitivity calibration and the sky flat field for larger scale illumination corrections. There are a number of filtering tasks in IRAF. A median is a good filter and there is the choice of a ring median or box median. To apply one of these general filtering tasks you would use \fBmsccmd\fR to run it on all the CCDs .nf ms> msccmd msccmd: median $input $output 10 10 Input files: SflatV Output files: SflatMedV msccmd: q .fi Because the object exposures are first processed with the dome flat (or other flat field) you would normally run \fBccdproc\fR again on the data using the sky flat and any observations that have not been processed at all will use both the dome flat and the sky flat. However, if you want to make a single flat field to apply to raw data, say if starting over or using it for a second night, you can combine the two flat field corrections into a single flat field to be used as the only flat field correction. This is done by multiplying the two flat fields using \fBmscarith\fR .nf ms> mscarith FlatV * SflatV FinalflatV .fi .sh 4.2.7 The Variable Pixel Scale and Zero Point Uniformity ---- Another step of the basic CCD calibration stage which has generally been ignored or forgotten with smaller single CCD formats is the variable pixel scale. The large field of view provided by a mosaic and the optics required to provide it can lead to a significant variation in the pixel scale. This effect is important with the Mayall telescope and is also present in the NOAO 0.9 meter data to a smaller degree. It is likely to be present in other telescopes as well. When the pixel scale varies significantly the standard flat field calibration operation will cause the photometric zero point to vary. A simple calibration step can be performed to remove this effect. However, if you intend to produce single images from the mosaic of CCDs this step is not necessary since the resampling operation naturally accounts for this effect. ---- A key assumption in the traditional reduction of CCD images is that the pixel scale is uniform and that a properly reduced blank sky image will have a uniform and flat appearance. Unfortunately, this is not correct when the pixel scale varies over the field. In the case of the NOAO Mosaic at the Mayall telescope, the pixel scale decreases approximately quadratically from the field center, with the pixels in the field corners being 6% smaller in the radial direction, and 8% smaller in area. Pixels in field corners thus would properly detect only 92% of the sky level seen in the field center, even with uniform sensitivity. At the same time the same number of \fItotal\fR photons would be detected from a star regardless of how many pixels the PSF would be distributed over. Forcing the sky to be uniform over the image has the deleterious effect of causing the photometric zeropoint to vary from center to field corners by 8%. Note that this effect is different from vignetting where the flux actually delivered to the image margins is less than that at the center, an effect that \fIis\fR corrected by the flat field. In practice, the photometric effect of the variable pixel scale can be ignored provided that the reduced images will be part of a dither-sequence to be stacked later on. As discussed below, prior to stacking the images they first must be re-gridded, which produces pixels of essentially constant angular scale. This is done with the \fBmscimage\fR task, which re-grids the pixels and has a "flux conservation" option that can scale the pixels photometrically by the associated area change. If this function is disabled, then "improperly" flattened images will have a uniform zero point restored. In short, the flat field adjusted (if inappropriately) for the different pixel sizes, so \fBmscimage\fR would then do no further adjustment. Stars would be too bright in the corners of the flattened images, but after re-gridding, their total fluxes would be seen to be scaled down to the appropriate values. If the mosaic CCD images are to be analyzed individually, as might be done for standard star fields, then after the flat field reductions are complete the differential scale effects must be restored. At present we are developing a routine in the \fBmscred\fR package to do this, without actually re-gridding the image. The correction process is simple; the scale at any point in the Mosaic field is already known from the astrometry so one just calculates and multiplies by the correction. The final image would appear to have a variable sky level, but would be photometrically uniform. .sh 4.3 Coordinate Calibration For some projects the basic flux calibrated CCD exposures may be all that is required. However, if you want to obtain coordinate information or combine multiple exposures which are dithered on the sky or taken with different filters, you must calibrate the celestial world coordinate system (WCS) of the data. This may be done in an absolute or relative sense; an absolute calibration ties the data coordinates to catalog coordinates while a relative calibration ties multiple exposures to the same coordinates. Determining the WCS from scratch is a complicated business and requires special observations of astrometry fields. However, for NOAO Mosaic data a standard coordinate calibration determined earlier is automatically inserted into your data by the data capture agent. The default coordinate system is sufficiently accurate for most purposes and just requires some small adjustments as described below. To piece a single exposure into a single image that does not require registration to any other data you may use the default WCS and skip the WCS calibration steps. [Need discussion of using MSCSETWCS to set WCS from a database] .sh 4.3.1 Creating or Updating a Mosaic World Coordinate System This section describe how to create or update a world coordinate system (WCS) for mosaic data using IRAF and \fBmscred\fR tools. A version of this discussion which includes example pictures may be found at http://iraf.noao.edu/projects/ccdmosaic/astrometry/astrom.html. A WCS is the header description that relates the image pixels to equatorial celestial coordinates. For a mosaic each extension requires its own WCS to account for the relative orientations of the CCDs as well as for the optical distortions from the focal plane to the sky. The unifying aspect of a mosaic WCS is that in all extensions the WCS uses the same reference point on the sky. This is normally the optical axis of the telescope and also the approximate center of the mosaic detector. The WCS for different exposures are generally the same (excluding binning and subraster readouts) except for the celestial coordinate tied to the reference point. While it is possible to derive the WCS without having any header information it helps considerably to be able to use \fBmscdisplay\fR and \fBccdproc\fR. In this discussion we assume that the headers contain the information needed to display and process the mosaic exposures. A description of how to set up this information is given in http://iraf.noao.edu/projects/ccdmosaic/generic/generic.html. In principle one would want to derive WCS for each filter. This has been done to some extent for the NOAO mosaic imagers. The data acquisition system then adds the WCS for the appropriate filter and telescope. However, there is a stage in the mosaic data reduction where the WCS is adjusted to account for zeropoint offsets, small rotations, and refraction effects and scale changes. This is done by registering the WCS to a set of coordinates, either relative to one exposure or from a catalog of star coordinates. This registration provides the small adjustments to match filters to the same coordinate system. .sh 4.3.1.1 Input Data To begin you need a calibration exposure of a field with many astrometric stars per CCD. Astrometric stars are those for which you can obtain accurate right ascension and declination in J2000 coordinates and epoch of observation (i.e. proper motion corrected coordinates). Of course you can use less accurate coordinates and then the WCS will be less accurate. In the example the calibration exposure is of USNO standard field K. The coordinates from the USNO-A2 catalog were obtain from http://www.noao.edu/gateway/catalogs/usno.html. Another source of USNO coordinates is http://cadcwww.dao.nrc.ca/cadcbin/getusno2. For the KPNO Mosaic star clusters with published astrometric coordinates were used. [Refer to MSCGETCATALOG] The required coordinate list is a simple text file of RA in hours and Dec in degrees. The IRAF routines allow values to be input in sexigesimal notation as well as in decimal format. Only the first two columns are required but the remaining columns, for USNO coordinates the red and blue magnitudes, are useful for creating subsets of stars such as by magnitude and for identification. To prepare the astrometric calibration data process it to subtract bias and trim to just the CCD data, that is trim away any prescan and overscan. Zero level, dark count, and flat fielding are generally not necssary for fields which have relatively bright stars. .sh 4.3.1.2 Creating a WCS From Scratch This section describes creating an initial, rough, WCS for data which does not have a starting one. It is much easier to update a prior WCS than it is to begin without one. If your data has even a crude WCS or one that needs to be updated, either because the mosaic detector was worked on in a way that might have moved the CCDs or because you want to redo and possibly improve the current WCS, then you can skip this section and go to section "4.3.1.3 Updating the WCS". To get an initial WCS requires you to create a text file for each CCD having lines with pixel coordinates (X and Y) and matching celestial coordinates (RA and Dec). There must be at least three coordinate pairs, usually the pixel position and celestial coordinates of stars, in the image. A finder chart is clearly useful for this. Making the text file can be accomplished in various ways including just using a text file editor. The tools you need are an image display, such as XIMTOOL, and some way to get the image pixel coordinates using the cursor. This might be as simple as looking at the coordinate readout box in the display, or use tasks such as RIMCURSOR or IMEXAMINE. While centroided positions can be used it is not really necessary for the determining an initial WCS. The initial WCS will be refined later using centroiding and more coordinates. The pixel coordinates can be recorded directly to a file or edited by hand. Similarly the celestial coordinates can be added after the pixel coordinates are determined or as the pixel coordinates are measured. Here we illustrate using \fBrimcursor\fR. This task is simply a cursor reading loop that writes the keystrokes typed in the display to the standard output, which can be redirected to a file. First display a particular CCD (or single amplifier readout) with \fBdisplay\fR (not \fBmscdisplay\fR which is for displaying all the CCDs) using the "fill" option. Remember to specify the image extension. Then run \fBrimcursor\fR with the output directed to a file. When you have matched an object in the image with an RA and Dec in your finding chart and list, position the cursor on the object and type colon followed by the RA and Dec. Below is an example of the output generated in this way. One could edit the file to remove the "101 :" but in the next step we have the option of specifying which columns are used. .nf ms> type example1.dat 300.412 1156.412 101 : 15:23:32 -0:19:07 980.436 1668.428 101 : 15:23:41 -0:16:13 1188.444 2412.452 101 : 15:23:54 -0:15:22 .fi The task that computes a WCS is \fBccmap\fR. This task is basically a fitting task that fits a transformation between pixel coordinates and celestial coordinates and records the result in both a database file and in the image header as a WCS. This task could be used directly to make a final WCS if the the input is generated with many centroided stars and celestial coordinates. This is discussed further in "4.1.3.5 CCMAP Verses MSCTPEAK and Logical Verses Physical Coordinates". Below shows the result of using this task with the example of three stars. Note that we need to change the "lngcol" and "latcol" parameters. We use an output database of "dev$null" since for now we only want to update the header. In the interactive fitting you just need to type 'q'. Later you will do more with this interactive fitting mode. You could also turn off the interactive fitting if desired. Another possiblity for doing multiple fitts in one step is to use a list of images (again given with the extension syntax) and a matching list of files with the coordinates. .nf ms> ccmap example1.dat dev$null image=example[im1] lngcol=5 latcol=6 update+ Coords File: example1.dat Image: example[im1] Database: dev$null Solution: example[im1] Refsystem: j2000 Coordinates: equatorial FK5 Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 Insystem: j2000 Coordinates: equatorial FK5 Equinox: J2000.000 Epoch: J2000.00000000 MJD: 51544.50000 Coordinate mapping status Ra/Dec or Long/Lat fit rms: 1.06E-12 6.32E-13 (arcsec arcsec) Coordinate mapping parameters Sky projection geometry: tan Reference point: 15:23:42.333 -0:16:54.00 (hours degrees) Reference point: 823.098 1745.763 (pixels pixels) X and Y scale: 0.259 0.262 (arcsec/pixel arcsec/pixel) X and Y axis rotation: 270.332 90.829 (degrees degrees) Wcs mapping status Ra/Dec or Long/Lat wcs rms: 1.06E-12 6.32E-13 (arcsec arcsec) Updating image header wcs .fi .sh 4.3.1.3 Updating the WCS Starting with an approximately correct WCS what is done is to register a list of celestial coordinates to the objects in the image, fit a WCS of an appropriate order to describe the optical distortions, and update the header and write a WCS database file to be used to apply the WCS to other images. This is done separately for each CCD though the WCS are constrained to have the same celestial reference point as noted earlier. This requires that there are RA and Dec keywords in the header (in hours and degrees respectively) for each extension which are the same and which point to the optical center of the exposure. The keywords may be added if not present with \fBhedit\fR. The task we will use is MSCTPEAK in the MSCFINDER subpackage of MSCRED. This task was derived from an older program, TFINDER, for making plate solutions using the Guide Star Catalog. The MSCFINDER version instead accepts any simple text file of RA and Dec coordinates, understands the multiextension format, and produces a database appropriate for application to other mosaic exposures. There is currently no specific help for this task but it is fairly self-guiding and the help for TFINDER can be used as a reference. The single list of coordinates includes all objects within the field of the entire mosaic and may contain objects outside the field. The task will use the starting WCS to select those stars in or near each element of the mosaic for display and for you to register to the image. The example list, part of which is shown below, is taken from the USNO catalog. As before only the first two columns are used and other columns may be present for other purposes. In this case the list has been previously sorted by red magnitude though the order does not matter for MSCTPEAK. .nf ms> head usnoextract 15:23:41.251 -0:16:17.79 8.6 11.6 15:26:00.732 0:17:46.26 8.6 9.4 15:22:58.946 0:05:55.95 10.4 13.9 15:25:54.554 -0:17:02.79 10.4 11.8 15:23:19.939 -0:08:41.78 10.6 12.2 15:25:34.787 -0:01:02.79 10.6 12.3 15:25:40.378 -0:01:11.50 10.6 11.5 15:24:57.694 -0:06:16.80 10.9 12.1 15:23:05.066 0:04:17.01 11.0 12.1 15:24:09.960 0:03:04.16 11.0 11.9 15:24:23.282 0:03:03.20 11.1 12.7 15:22:57.130 -0:20:26.01 11.3 12.8 .fi Now we look at the parameters for MSCTPEAK that will update the WCS for our example. The "extname" parameter can be used to work only on one or a subset of extensions. Otherwise if you abort the task or the task crashes you would need to go through all the extensions again. The "projection" in the example is "tnx" which is a tangent plane projection with distortion polynomials that is understood by IRAF tasks. The orders are for terms up to a power of three. This is needed for the NOAO 4meter telescopes. You should use "tan" if that is sufficient for your telescope distortions otherwise use the lowest representation you can. In future other functions might be used and will incorporate the developing FITS WCS standards. You will notice that there are some parameters you saw with CCMAP. That is because the fitting engine in this task is also CCMAP. .nf ms> epar msctpeak I R A F Image Reduction and Analysis Facility PACKAGE = mscfinder TASK = msctpeak images = example List of WCS calibrated Mosaic images coordina= usnoextract List of ra(hr), dec(deg), optional id database= example.db Database for astrometric fit (extname= ) Extensions (epoch = 2000.) Coordinate epoch (update = yes) Update image header WCS following fit? (autocen= no) Center catalog coords when entering task? (boxsize= 9) Centering box fullwidth (project= tnx) Sky projection geometry (fitgeom= general) Fitting geometry (functio= polynomial) Surface type (xxorder= 4) Order of xi fit in x (xyorder= 4) Order of xi fit in y (xxterms= half) Xi fit cross terms type (yxorder= 4) Order of eta fit in x (yyorder= 4) Order of eta fit in y (yxterms= half) Eta fit cross terms type? (reject = INDEF) Rejection limit in sigma units (interac= yes) Enter interactive image cursor loop? (frame = 1) Display frame number (marker = circle) Marker type (omarker= plus) Overlay marker type (goodcol= blue) Color of good marker (badcolo= red) Color of bad marker (fdimage= ) (fdcoord= ) (mode = q) .fi Now run the task. You must have an image display tool running. The task will display, with the "fill" option, each image extension in turn. We will only look at the first extension in this example. It will draw circles where the current WCS predicts the objects to be. If you see no circles when you expect to then there is a problem with the WCS. This might be due to not having the CRVALn keywords correct for the field or the initial WCS is not correct. The example below shows the first part of running the example. Figure 8 shows the cursor help and figure 9 shows a zoomed portion of the display. You will be prompted with the image cursor for input of various commands. The '?' command will page a list of the commands. The important keys are 'a', 'f', 'k', 'l', and 'r'. We could attempt to center all objects using one object with the 'a'+'k' command. But because of the rotation and rough nature of the initial WCS only stars in the vicinity of the reference object would be correctly centered. Instead we move around the field typing 'k' on the image of some of the stars from which we will do a first WCS fit. Note that the 'k' key will center the nearest red circle. If there is a possiblity of confusion the 'l' key is used by typing 'l' on the red circle and then 'l' again on the object to be centered. When moving around the field feel free to zoom the display. You should center a few stars in the corners and the edge, roughly 12 stars. The centered stars are shown in blue. Because the circles can't be erased except by reloading the image the red circles for the centered objects are still visible. Once some stars have been centered type 'f' to fit a new WCS. This will bring up the interactive graphical fitting of CCMAP. You can type '?' to get a reminder of the keys that can be used. The initial figure is something like an x,y plot of the positions to show the distribution of the objects to be fit. Most of the work is done by using the 'x', 'y', 'r', and 's' to display residuals as a function of x and y. In these plots you might use 'd' to delete misidentified, miscentered, or stars with large and uncorrected proper motions. After deleting stars type 'f' to redo the fit. For the first pass don't worry too much about the details. We will come back to the fit after adding in the rest of the objects. Type 'q' to go back to the image. Type 'r' to redisplay the image with the circles now at the position of the new WCS. You can now center all the objects quickly with 'a'+'k' on a star which has a blue circle, this centers without any initial offset. After this you will find most of the red cicles are blue and correctly centered on an object. In some cases the centering may fail and the circle remains red. Also if you have wrong centering you can delete a source with 'd'. Once most of the stars have been recentered you are ready to get the final WCS solution. Type 'f' again. After quitting the final fit and returning to the image displays type 'q' to quit the current extension and go on to the next one. When this is done the image header is updated and a database record is written. The final database record will look something like what is shown below. The database record name will be the same as the extension name. .nf ms> page example.db # Mon 12:25:01 02-Aug-99 begin im1 xrefmean 1044.292343750001 yrefmean 2156.800455357142 lngmean 15.39719017981151 latmean -0.2653082589285715 pixsystem physical coosystem j2000 projection tnx lngref 15.407730555556 latref -0.03330555555555601 lngunits hours latunits degrees xpixref 4244.325766925275 ypixref 4304.248081888623 geometry general function polynomial xishift -1141.614713161611 etashift -1101.716071777617 xmag 0.2639284056373001 ymag 0.2655069305191946 xrotation 269.9466255882454 yrotation 90.92663219116762 wcsxirms 0.1472868023213945 wcsetarms 0.160997703816063 xirms 0.1472868023213879 etarms 0.1609977038160636 surface1 11 3. 3. 2. 2. 2. 2. 0. 0. -23. -23. 2112. 2112. 1. 1. 4096. 4096. -1141.614713161611 -1101.716071777617 -2.458649045090564E-4 0.2639282911184323 0.2654722084256873 -0.004293798704277087 surface2 18 3. 3. 4. 4. 4. 4. 2. 2. -23. -23. 2112. 2112. 1. 1. 4096. 4096. 6.977981629782491 4.83341022221393 -0.004048419139473676 -0.005838836166964449 9.986220347252658E-7 2.009699573532316E-6 -9.720500785419318E-11 -1.103085078407953E-10 -0.00780283211407008 -0.003276602257239252 1.364528047712044E-6 1.287934476820951E-6 -1.462311976812420E-10 3.907533256511147E-11 2.333215504725742E-6 5.414511921261557E-7 9.518409839069242E-12 -1.571748447126591E-10 -2.004754169679203E-10 2.479352519503381E-11 .fi .sh 4.3.1.4 Applying a WCS Database to Other Exposures The end result of creating and updating a WCS is that the calibration image will have the right WCS in its header and a database file will be produced. To apply the WCS database to other images requires two things. First the WCS keywords must be added to the image extensions based on the extension names. Second the position of the reference point in the WCS, the CRVALn keywords, must be set to the right point on the sky. The task MSCSETWCS, whose parameters are shown in figure 14, does this. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscsetwcs images = newimage Mosaic images database= example.db WCS database (ra = ra) Right ascension keyword (hours) (dec = dec) Declination keyword (degrees) (equinox= equinox) Epoch keyword (years) (ra_offs= 0.) RA offset (arcsec) (dec_off= 0.) Dec offset (arcsec) (extlist= ) .fi The first thing the task does is apply the WCS database specified by the "database" parameter. If no database is specified then this task can be used only for the second step of updating the WCS reference coordinate based on the coordinate keywords in the header. This step consists of transforming the keywords specified by the "ra" and "dec" parameters, presumably set by the data acquisition system, to the WCS keywords "crval1" and "crval2". The keywords give the RA and Dec of the observation in hours and degrees. Ideally these fairly obvious keywords will be a pointing put into the data by the data acquisition system based on the telescope pointing. The "equinox" keyword, if specified and found in the header, will precess the header coordinates to the equinox of the J2000 equinox of the WCS. The offset parameters may be used if there is always a known offset between the RA and Dec values in the header and the WCS reference point. Currently this task and the method of updating the WCS from a database assumes that there is no rotation or only a small rotation between the WCS calibration and later observations. The small rotations, as well as scale and atmospheric refraction effects are removed later as a global adjustment to the WCS using the task MSCCMATCH. .sh 4.3.1.5 CCMAP Verses MSCTPEAK and Logical Verses Physical Coordinates MSCTPEAK is a convenient routine. However you can also do everything with other tools which produce the input to CCMAP, the list of accurate pixel and celestial coordinates, and then use CCDMAP directly. The important points to note in the context of a mosaic and MSCRED is that the "pixsystem" should be specified as "physical" and the database WCS names should be just the image extension names. This is needed to allow MSCSETWCS, see "4.3.1.4 Applying a WCS Database to Other Exposures", to update the headers of mosaic exposures which have a different pointing and possibly are untrimmed (have overscan and prescan regions), trimmed to a smaller region, binned, or the result of a subregion readout. The idea is that the WCS database describes a transformation between "physical" coordinates and celestial coordinates. Physical coordinates are coordinates tied to some fundamental system. For mosaic data this should be the unbinned CCD coordinates. The "logical" coordinate system is the pixel coordinates of the actual image raster. By determining the WCS and specifying the database WCS in physical coordinates, then when the WCS is applied to other exposures first the logical pixels of the exposure are transformed to the same physical system (unbinned CCD pixels) regardless of overscan/prescan regions, binning, and subraster readouts. Another way to think of this is that the WCS database in physical coordinates is a WCS tied to the CCD pixels. The transformation between logical and physical coordinates is specified by the LTV and LTM keywords found in the image headers. Earlier we recommended that that the calibration exposure be trimmed to the full unbinned CCD data. This means that the headers should all have LTM1_1/LTM2_2 = 1 and LTV1/LTV2 missing or zero. CCDPROC will update or create these keywords based on the CCDSEC and NSUM keywords. However, the database WCS is best applied as early as possible in the raw data. If the data have been binned then LTM1_1/LTM2_2 will be different than one and if there is an overscan on the left of the image, say 64 pixels of overscan, then the raw data should have LTV1=-64. MSCSETWCS will then apply the WCS correctly in this case. .sh 4.3.1.6 Verifying a WCS During any operation involving the WCS it is useful to be able to see if the coordinate system is correct. A picture is worth a thosand words and can help you diagnose problems. The tasks MSCZERO and MSCTVMARK are useful for this. You need to have a list of coordinates that you expect to overlay on your field. This might be easily obtained from some catalog such as the USNO-A. Then you display the image either with MSCDISPLAY or MSCZERO. The latter does MSCDISPLAY if the image is not already loaded and enters an interactive cursor loop. Then you would use MSCTVMARK or the 'm' key in MSCZERO which excutes this task. This takes the celestial coordinates, determines in which, if any, of the extensions the star falls based on the WCS and draws marks at the appropriate logical pixel coordinate. .sh 4.3.2 Global adjustments to an exisiting Mosaic World Coordinate System The WCS is a mapping from pixels in the mosaic data to celestial coordinates relative to a reference point on the sky. The reference point, or zero point, is set using the telescope pointing coordinate. The telescope pointing is generally off by a small amount, though it could be completely wrong in some hardware/software error situations. In addition, differential atmospheric refraction introduces small axis scale changes and rotations, which are significant due to the large field of view of the mosaic even during the course of single set of dithered exposured. Putting observations from different filters onto the same coordinate system also requires mapping small scale changes, since currently there is only a single standard WCS solution derived through one filter. [In the future filter dependent solutions will be made available.] The WCS calibration operations consist of adjusting the standard coordinate system calibration to a desired zero point and applying small axis scale changes and rotations. This is done using objects (usually stars) in the exposures. Unlike a full WCS calibration, which requires a high density of stars with accurate catalog coordinates, the adjustments to the default WCS calibration require only a few objects; only one objects is needed to provide a zero point correction. The WCS adjustments are determined by specifying coordinates for one or more objects in the data. The coordinates can be obtained from a reference catalog or, more commonly, by measuring coordinates from one reference exposure to which other exposures are to be "registered". A combination of using a catalog coordinate for one object in the field to set the zero point in a reference exposure and then measuring the positions of other stars in the reference image based on that zero point calibration may also be done. The two tasks you will use are \fBmsczero\fR and \fBmsccmatch\fR. \fBMsczero\fR is used to interactively set the zero point of the coordinates, register multiple exposures closely, and generate a list of coordinates in a reference exposure to which other exposures in a dither set are registered. \fBMsccmatch\fR finds objects at the positions specified by a list of coordinates and determines corrections for the zero point, axis scale change, and axis rotation. .sh 4.3.1 Setting Coordinate Zero Points and Measuring Coordinates \fBMsczero\fR is an interactive display task for mosaic exposures that allows measuring coordinates and adjusting the WCS zero point. The task parameters are shown below. The last set of parameters (starting with "ra") are for the task to query and maintain lists. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msczero images = List of mosaic exposures (nframes= 2) Number of frames to use (logfile= default) Log file for measurements ra = RA (hours) dec = DEC (degrees) update = yes Update WCS zero point? (fd1 = ) (fd2 = ) .fi The task displays each exposure in the list, in turn, and responds to cursor key commands. You can go forward and backward through the input list or quit at any point. The exposures are displayed by cycling through the specified number of frames starting with the first frame. As an aid to efficiency, if the exposure is already loaded in the appropriate frame then the display step is skipped. This task has several uses (type '?' to get the list of command options): .nf 1. Set the WCS zero point by specifying the coordinate of a star. 2. Create a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. 3. Report coordinates at the cursor position. .fi It may be that the WCS zero points, based on the telescope pointing coordinates, are accurate enough that you can use this task on only a reference exposure to generate a list of coordinates for use with \fBmsccmatch\fR and \fBmscimatch\fR. However, because it is fairly quick to explicitly check and set the zero point of all the exposures in a dither set to the same coordinate for a common reference star, it is recommended you do this first. To check and set the zero points for a set of dithered exposures run \fBmsczero\fR with a list of the exposures .nf ms> msczero @field1 .fi After the first exposure is displayed either find a reasonably bright unsaturated star which will be in all the exposures or find a star whose coordinate is known from a catalog such as the HST Guide Star Catalog. Move the cursor to the star and type 'z' (zero) to invoke a centering algorithm. Note that even though the exposure may be displayed at lower resolution the centering is done with the full resolution data. The task will then tell you what it thinks the coordinate is and ask you for a new coordinate. The first time 'z' is typed it will prompt with the measured coordinate and thereafter it will prompt with the last entered value. If you are referencing all the exposures to the first exposure in the list accept the measured coordinate (and write the value down in case you need it later) otherwise enter the desired coordinate. Note that all further measurements of the image will automatically apply the measured zero point correction but the exposure WCS is not actually updated until you type 'n' (next) or 'q' (quit). If you want to print coordinates without changing the zero point correction use the space bar or 'c' (center) to center on an object and print the centered coordinate. If you changed the WCS zero point you will be shown the zero point offsets and given the option to update the WCS in the data file when you type 'n'. Then the next exposure in the list will be displayed. Find the same star and type 'z' again. Since it will retain the last entered coordinate you should only need to accept the prompted coordinates. When you have done this for all the exposures their coordinate systems will be registered at least at that point. The WCS in the dither set may still not be registered over all the field due to refraction effects. Also the intensity scales of the dithered exposures may not be the same due to changes in transparency and sky brightness. These effects are calibrated by matching objects throughout the field in position and brightness. This requires a list of coordinates tied to one of the dithered exposures as a reference. Usually the first exposure in the set is used as the reference. \fBMsczero\fR is used to create a list from objects in the reference exposure. .nf ms> msczero obj021 .fi Select objects, usually stars, throughout the field and type 'x' for each one. This will center on the object and and record the coordinate in a logfile. The default logfile name "default" creates a log file beginning with "Coords." and followed by the name of the exposure. In the example this will be "Coords.obj021". To be useful for coordinate matching this list should have a good number of stars, say three or four from each CCD, with emphasis on the field edges but allowing for the dithering. For the intensity matching you want to have stars with a range of brightness (though not saturated or extremely faint) and which are mostly isolated so that a region around them may be used for sky. The lists for the coordinate and intensity matching do not have to be the same but it is reasonable to just create one list. .sh 4.3.2 Matching Coordinate Systems The task \fBmsccmatch\fR determines and applies a linear correction to the WCS to match objects, generally stars, in an exposure to a set of reference celestial coordinates. This correction maintains the detector geometry and optical distortions while adjusting for changes in apparent sky position such as produced by atmospheric refraction and telescope pointing errors. The linear correction consists of a zero point shift, scale changes in the right ascension and declination axes, and rotations of the axes. To use this task you need a list of reference celestial coordinates, right ascension in hours and declination in degrees, and the mosaic exposure coordinate system must be relatively close to the reference coordinate system. The default WCS plus telescope pointing may be close enough, but if not you would use \fBmsczero\fR to register the zero points at some point in the exposures. Since it is relatively simple to register a set of dithered exposures to a common star with \fBmsczero\fR this is recommended procedure before using \fBmsccmatch\fR. The reference coordinates should cover all of the mosaic field of view to be sensitive to the small rotation and scale effects. The coordinate list might be obtained from a catalog or measured from one of the exposures to which other overlapping exposures will be matched. For the purposes of making a well aligned stacked image from a set of dithered exposures one generally uses one of the exposures as the source of the reference coordinates. \fBMsccmatch\fR operates on a set of input mosaic exposures; each in turn. For an exposure it converts each input celestial coordinate to a pixel coordinate in one of the extensions using the current WCS. If the coordinate does not fall in any extension the coordinate is not used. The pixel coordinate is used as a starting point for the \fBapphot.center\fR task. If the centering fails for some reason, such as the object being too near the edge or the final position being too far from the initial position, the coordinate is not used. For those objects successfully found a fit is made between the original celestial coordinates and the measured coordinates expressed as arc seconds from the exposure tangent point. The fit is constrained to yield some combination of shift, scale change, and rotation for each of the celestial coordinate axes. These parameters are then used to update the exposure WCS so that the adjusted measured coordinates best agrees with the reference coordinates. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = msccmatch input = List of input mosaic exposures coords = Coordinate file (ra/dec) (nfit = 4) Min for fit (>0) or max not found (<=0) (rms = 2.) Maximum fit RMS to accept (arcsec) (maxshif= 5.) Maximum centering shift (arcsec) (fitgeom= rxyscale) Fitting geometry (update = yes) Update coordinate systems? (interac= yes) Interactive? (fit = yes) Interactive fitting? (verbose= yes) Verbose? accept = yes Accept solution? .fi The input is a list of mosaic exposures and a file of reference celestial coordinates. The exposures should all include a significant number of objects from the list of coordinates. The task can be run interactively or non-interactively based on the "interactive" parameter. In interactive mode you can graphically interact with the fitting (selected with the "fit" parameter) and accept or reject a fit based on the printed fit parameters. The fitting is done using the task \fBgeomap\fR and the interactive mode allows you to view the distribution of coordinates, residuals verses the input coordinates, delete bad values, and possibly change the fitting constraints (see the help for \fBgeomap\fR for more information). The linear transformation may be constrained by the "fitgeometry" parameter as described in the help for \fBgeomap\fR. This may be desirable if there are only a few coordinates or if you want to impose some physical assumption. Note that the effects of atmospheric refraction actually do cause independent scale changes and rotations in the two axes so the default "rxyscale" should be used. There are some constraints which are placed on the task. The "maxscale" parameter limits how far the objects may be found from the initial coordinates. This constraint protects against incorrect identifications and tells the centering routine how much of the image to look at. This parameter should be as small as possible consistent with the errors in the WCS. If you first zero the coordinates then the objects should be found quite close to the initial coordinates. When the "verbose" parameter is set the results of the centering will be printed consisting of the image extension name, the final pixel coordinates, the shift in pixel coordinates from the initial value, and the formal uncertainties in the pixel coordinates. If an error occurs one of the error codes from \fBapphot.center\fR will be reported such as "BigShift" for objects with too big a shift from the initial position and "EdgeImage" for objects to near the edge of the image. The "nfit" parameter requires a certain number of coordinates to be included in the fit. If specified as a negative number the parameter is interpreted as a maximum number that may be lost from the input list due to being off the exposure or failing to be centered. The "rms" parameter requires that the final RMS of the residuals about the fit for each axis be less than a certain value. .sh 4.4 Putting the Pieces Together This section tells you how to make single images from each multiextension exposure and how to combine sets of dithered images into a final deep image free from gaps and artifacts. Obtaining good results depends on having well-flattened data, a uniform sky, a dither pattern that samples the gaps and bad regions of the detectors, and accurately registered world coordinates. Most difficulties are caused by variable sky conditions or scattered light within a dither sequence or the data used to create a sky flat. .sh 4.4.1 Removing Sky Gradients Any sky level mismatches when combining dithered exposures produce artifacts in the final image. The three sources of such mismatches are sky gradients, sky level differences between the CCDs, and sky level differences between exposures. While the flat field calibration, particularly with a sky flat, should remove differences in sky levels between CCDs, in practice there may still be small errors. And the flat field will not deal with sky gradients across the large field of view. Exposure-to-exposure sky brightness variations can be dealt with at a later stage but even this is tricky. The best final result is obtained by fitting a low order surface (a plane or quadratic) to the sky and subtracting it from each CCD of each object exposure at this stage. This will force the sky to be zero for all CCDs and all exposures. Note that if one wants to preserve a sky level for statistical reasons it is possible to add a uniform constant after the subtraction to all the data (or add the constant to the final dither stacked image). To fit and subtract a sky and sky gradient the combination of \fBimsurfit\fR and \fBmsccmd\fR is used. With \fBimsurfit\fR use the option to fit to medians in large blocks to remove the effects of objects. .nf ms> msccmd msccmd: imsurfit $input $output xo=2 yo=2 type=resid xm=100 ym=100 Input files: obj* Output files: obj* msccmd: q .fi In this example the input and output are the same, replacing the original by the sky subtracted data, but one can create new output files if desired. Note that x and y orders of 2 correspond to a plane and orders of 3 correspond to a quadratic surface. .sh 4.4.2 Constructing Single Images Making a single image from a mosaic exposure is done by mapping the pixels from each extension to a single uniform grid on the sky. The WCS calibrations described in previous sections provide this. For making a single image from a single exposure the WCS calibration is not critical and the default WCS is sufficient. For combining multiple dithered exposures all the exposures must be registered to a common coordinate system, either relative to one reference exposure or to a set of catalog stars, and each exposure must be resampled to the same final coordinate system. The task that makes single images from mosaic exposures is \fBmscimage\fR. Its parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimage input = List of input mosaic exposures output = List of output images (referen= ) Reference image (pixmask= yes) Create pixel mask? (verbose= )_.verbose) Verbose output? # Resampling parameters (blank = 0.) Blank value (interpo= linear) Interpolant for data (minterp= linear) Interpolant for mask (fluxcon= no) Preserve flux per unit area? (ntrim = 7) Edge trim in each extension (nxblock= 2048) X dimension of working block size in pixels (nyblock= 1024) Y dimension of working block size in pixels # Geometric mapping parameters (interac= no) Fit mapping interactively? (nx = 10) Number of x grid points (ny = 20) Number of y grid points (fitgeom= general) Fitting geometry (functio=chebyshev) Surface type (xxorder= 4) Order of x fit in x (xyorder= 4) Order of x fit in y (xxterms= half) X fit cross terms type (yxorder= 4) Order of y fit in x (yyorder= 4) Order of y fit in y (yxterms= half) Y fit cross terms type .fi An output image is created for each input mosaic exposure. The output image is created with a coordinate system defined by the specified "reference" image. If no reference image is specified then the first input mosaic exposure is used to define a simple tangent plane coordinate system with optical distortions removed, and that coordinate system is used for all the input mosaic exposures. The important point is that for a set of dithered exposures all the output images must be created with the same coordinate system grid so that they may be combined by simple integer shifts along the image axes. The normal usage is to specify all the mosaic exposures in a dither set as the input, give a matching list of output images, and leave the reference image unspecified. If all the exposures in a dither set are not done at the same time then you must specify one of the earlier output images as the reference image to continue to create the output images on the same coordinate grid. The output images are created with a size that just covers the input data and initially filled with the specified "blank" value. This is the value that the mosaic gaps will have in the final output image. Then each extension is resampled into the appropriate part of the output image. The coordinate mapping is generated by \fBgeomap\fR using the geometric mapping parameters which you don't need to change. The resampling is done with the specified interpolation function. The small rotations in the CCDs produce edge effects in the interpolated output pieces so a small trim is required to eliminate these. [At the time this document was prepared the best value for the new science grade NOAO Mosaic had not been determined.] Linear interpolation is the fastest and most straightforward. Other interpolation functions are available. In particular sinc interpolation is now available as an add-on option (see the \fBmscred\fR installation instructions). Experience with sinc interpolation shows that it is not overly slow and does provide improved results; particularly with maintaining the statistical characteristics of the sky noise. The "minterpolant" parameter allows using a faster and more local interpolation function for the mask. This is particularly useful when using sinc interpolation of the data to allow flagging only around the actual bad pixels and not extending out as far as the sinc interpolation does. It is useful for the later combining step to make bad pixel masks that reflect the interpolation and resampling from the input data. These may be created by setting the "pixmask" parameter. If this parameter is set and the input mosaic data have bad pixel masks defined through the header BPM keywords (default bad pixel masks are provided in the NOAO Mosaic data) then the masks will be interpolated in exactly the same way as the data. The interpolated masks will appear in the working directory with names related to the output image names and with the output images containing the BPM keyword pointing to these masks. The input bad pixel masks are assumed to have zero for good data and one for bad data and the output masks have zero for good data and values between zero and ten thousand for bad data. The value is the result of interpolation and reflects the relative contribution of good and bad data. The "fluxconserve" parameter applies a pixel area correction if selected. As discussed earlier, standard flat fielding distorts the flux per unit area in pixels of different projected size by making them have the same flux per pixel. In effect this applies half of the flux conservation operation by adjusting the pixel values without adjusting the pixel sizes. \fBMscimage\fR does the second half by adjusting the pixel sizes. So for standard flat fielded data, the usual route to making a combined dithered image, the flux conservation parameter should not be used to arrive at a proper final flux per unit area in the resampled data. Flux conservation would only be used if the input mosaic data has previously been corrected back to proper flux per unit area through adjustment of the flat field or data for the variable pixel size inherent in the mosaic coordinate system. Below are two examples; one using prepared @files and one illustrating advanced usage of filename templates. .nf ms> mscimage @dither1 @outdither1 pixmask+ ms> mscimage obj02![2-5]* %obj%mos%02![2-5]* pixmask+ .fi In the second example the input template expands to obj022.fits to obj025.fits and the output template matches the input template using the first part of the %% substitution field and then replaces the "obj" with "mos" to give output images mos022.fits to mos025.fits. .sh 4.4.3 Matching Intensity Scales When stacking dithered exposures (the single images created in the previous step) to fill in the mosaic gaps and remove bad pixels and cosmic ray events it is critical that the intensity scales of the images match. Otherwise you will see artifacts from the gaps, places with bad data, and around objects as the combined intensity level jumps when data from an exposure is missing or rejected. Also the rejection algorithms require that the image intensities match both at the sky level and in the objects. There are two parameters that must be determined to match the intensity scales. One is a additive offset caused by sky brightness variations. The second is a multiplicative scale change caused by transparency and exposure time variations. Matching the intensity scales for a set of dithered exposures consists of determining values for these two scaling parameters relative to a reference exposure and setting them in the image headers. The actual adjustment of the pixels values occurs when stacking the exposures. The intensity matching values are determined by the task \fBmscimatch\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscimatch input = List of images coords = File of coordinates (scale = yes) Determine scale? (zero = no) Determine zero offset? (box1 = 21) Inner box size for statistics (box2 = 51) Outer box size for statistics (lower = 1.) Lower limit for good data (upper = INDEF) Upper limit for good data (niterat= 3) Number of sigma clipping iterations (sigma = 3.) Sigma clipping factor (interac= no) Interactive? (verbose= yes) Verbose? .fi The input is a list of images to be matched and a file of celestial coordinates (RA in hours and DEC in degrees) to use in computing the matching parameters. The input images are the single images constructed from the mosaic exposures for a set of dithered observations. The parameters "scale" and "zero" select whether to determine the multiplicative scale, the zero level offsets, or both. If the sky has been subtracted at an earlier stage (as recommended) then only the multiplicative scale difference needs to be determined. The advantage of subtracting the sky earlier is that scale determination becomes better constrained. Also determining the sky from photometry (as done by this task) is less robust than the surface fitting which uses all of the sky data. The scaling parameters are determined by measuring the mean flux in a set of matching regions between each input image. The centers of the regions are specified by their celestial coordinates. The list of coordinates should consist of the positions of objects in the field. These objects should span a range of brightness. As noted previously, you would normally use the same coordinate list as used with \fBmsccmatch\fR, which is generally obtained using \fBmsczero\fR. However, you can use any IRAF task that produces a list of celestial coordinates from images with a WCS. One possibility is to use \fBrimcursor\fR on one of the displayed single images with the "wcs" parameter set to "world" and the "wxformat" set to "%.2H" to produce right ascension values in hours instead of degrees. The now accurately aligned coordinate systems in the images are used to identify the matching pixel coordinate center in each image. The regions to be measured consist of square boxes of the specified sizes about the pixel coordinate center. There are two boxes, an inner box and an outer box which excludes the inner box. The box sizes are intended to define photometry apertures for the objects and nearby background. It is not critical that they exactly fit the objects or that the objects necessarily be stars but this is usually how they will be set. Because of possible PSF variations the inner box should be large enough include all the light from stars over the whole data set. If the inner box is not fully contained in the input or reference image that box is not used for that pair. Similarly the outer box must be fully contained in the images but if only the outer box is outside one or both images the measurement for the inner box may still be used. In order to exclude regions that include the gaps or bad data in one or both of the pair of images all pixels in a box must have values between the specified good data limits. Those regions with values outside the limits are eliminated from the intensity matching. The mean fluxes in each region are used to simultaneously fit the relations .nf mean_j = A_ij + B_ij * mean_i .fi for all i and j where i and j are any pair of images. These equations are constrained by the fact that the scaling from image i to j, followed by the scaling from image j to k, must agree with the scaling from image i to image k. The final scaling coefficients reported and stored in the image header are A_1j and B_1j, which correspond to the scalings to the first image in the input list. The task will attempt to reject photometry points which are discrepant. If the task is run interactively it will also show plots of the photometry flux in one image verses another. It does this for sequential pairs of images. Points can be deleted in these plots and they will be excluded from the data used to determine the scaling parameters. When the task is done determining the scaling factors they will be printed and a prompt issued to accept or not accept the results. If the scaling parameters are accepted then the keywords \fBmsczero\fR and \fBmscscale\fR are recorded in the input image header when the "update" parameter is set. Note that the reference image is assigned values of 0 and 1 for these header keywords. .sh 4.4.4 Making the Final Stack Image After \fBmscimage\fR produces single images of each of the dithered mosaic exposures with a common coordinate system grid, a final image is created with the task \fBmscstack\fR. The task \fBmscimatch\fR is generally used to match the intensity scales of the images before this step as described in the previous section. However, for quick reductions or for other reasons the images may be stacked either with no intensity matching or using the "scale" and "zero" options of \fBmscstack\fR. The task parameters are shown below. .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscstack input = List of images to combine output = Output image (plfile = ) List of output pixel list files (optional) (combine= median) Type of combine operation (median|average) (reject = none) Type of rejection (masktyp= none) Mask type (maskval= 0.) Mask value (blank = 0.) Value if there are no pixels (scale = !mscscale) Image scaling (zero = !msczero) Image zero point offset (weight = none) Image weights (statsec= ) Image section for computing statistics (lthresh= 1.) Lower threshold (hthresh= INDEF) Upper threshold (nlow = 1) minmax: Number of low pixels to reject (nhigh = 1) minmax: Number of high pixels to reject (nkeep = 1) Minimum to keep (pos) or maximum to reject (neg) (mclip = yes) Use median in sigma clipping algorithms? (lsigma = 3.) Lower sigma clipping factor (hsigma = 3.) Upper sigma clipping factor (rdnoise= 0.) ccdclip: CCD readout noise (electrons) (gain = 1.) ccdclip: CCD gain (electrons/DN) (snoise = 0.) ccdclip: Sensitivity noise (fraction) (sigscal= 0.1) Tolerance for sigma clipping scaling corrections (pclip = -0.5) pclip: Percentile clipping parameter (grow = 0) Radius (pixels) for 1D neighbor rejection .fi This task is a simple variant of \fBcombine\fR that registers the images using the coordinate systems and has the default threshold parameters set to ignore values below one DN based on the default "blank" value in \fBmscimage\fR for the gaps. If you have also generated bad pixel masks for the resampled images you can exclude them as well by setting "masktype" to "goodvalue". The real art in using this task is deciding how to scale and reject bad data not covered by the bad pixel masks. A "combine" of "median" is the simplest but it does not optimize the signal-to-noise for the number of images. If you "average" the data you will probably want to apply a rejection algorithm such as "avsigclip". Careful flat fielding will make each separate image have the same sky level across the different CCDs. However, the sky levels and transparency may still be varying from exposure to exposure. If you simply combine such data you will see imprints of the gaps. So it is generally a good idea to scale the images. This is done using the "scale" and "zero" parameters which can be set to header keyword values, files containing the values, or special values to compute image statistics in a particular region of the data. The recommended method for scaling is to use the intensity matching task \fBmscimatch\fR described in the previous section and use the image header keywords \fBmscscale\fR and \fBmsczero\fR produced by that task. An example of using this task to create a final image is given below. .nf ms> mscstack @field1 Field1 combine=average rej=avsigclip .fi .endhelp mscred-5.05-2018.07.09/doc/mscimage.hlp000066400000000000000000000424771332166314300170430ustar00rootroot00000000000000.help mscimage Aug97 mscred .ih NAME mscimage -- reconstruct single images from mosaic exposures .ih SYNOPSIS Multiextension mosaic exposures are resampled, based on the individual extension WCS with distortions, into a single image with a simple WCS. This may include a pixel mask identify regions of no data and pixels with contributions from bad pixels. Multiple exposures can be resampled to a common reference WCS such that the images can be registered with integer pixel shifts. This task will also work with single images to resample to a new output image on a desired coordinate grid. .ih USAGE mscimage input output .ih PARAMETERS .ls input List of input mosaic exposures to be resampled into a single images. Single images may also be used if desired. .le .ls output List of output images. The number of output images must match the number of input mosaic exposures or images. .le .ls reference = "" Reference image for defining the coordinate system. If no reference image is specified then the first input mosaic exposure or image will be used to define the output coordinate system. The purpose of a reference image is to create multiple output images with pixel sampling that allows the images to be stacked by simple integer pixel shifts. \fBThis must be a single image and not a mosaic exposure.\fR .le .ls pixmask = yes Create pixel masks for each output image? The output mask will have the same name as the output image (minus the image type extension) with the extension "_bpm.pl". The output mask name will also be recorded in the output image under the keyword BPM. The output pixel mask will identify gap pixels plus any pixels in the output image which have contributions from bad pixels associated with each input extension. The input pixel masks are specified by the BPM keyword in the extension. If there is no bad pixel mask, an empty (all good pixels) mask will be assumed. .le .ls verbose = ")_.verbose" Print verbose information? The default value points to the package \fIverbose\fR parameter. The verbose information identifies the reference image being used and gives progress information when the empty output image is first created and then as each input extension is mapped to the output image. .le .ls blank = 0. The value assigned to regions where there is no data; i.e. the gaps between mosaic pieces and edges where small rotations produce no data in the output rectangular image. .le .ls interpolant = "linear" The interpolation type used on the image data. The choices are .nf nearest - nearest pixel linear - bi-linear interpolation poly3 - bi-cubic polynomial interpolation poly5 - bi-quintic polynomial interpolation spline3 - bi-cubic spline interpolation sinc - 2D sinc interpolation lsinc - look-up table sinc interpolations drizzle - 2D drizzle resampling .fi For further information about the interpolants see \fBgeotran\fR. The interpolation type has a major effect on the speed of execution. .le .ls minterpolant = "linear" The interpolation type used on the bad pixel mask. The choices are the same as for the \fIinterpolant\fR parameter. The input bad pixel masks are interpolated to create an output bad pixel mask which includes the regions with no data such as mosaic gaps. See the DISCUSSION to details about how this is done and how the choice of an interpolant should be made. .le .ls boundary = "reflect" (nearest|constant|reflect|wrap) Boundary extension to use to interpolate the data near the boundaries. The bad pixel mask interpolation only uses constant boundary extension as explained in the DISCUSSION. The choices are .nf nearest - the nearest boundary pixel constant - the value supplied by the \fIconstant\fR parameter reflect - reflect about the boundary wrap - wrap around to the opposite side .fi To avoid ringing in the interpolation the boundary extension should not have a sharp discontinuity. The "reflect" option is recommended. The \fIntrim\fR parameter can also be used to avoid needing to interpolate beyond the image. .le .ls constant = 0. Constant value for "constant" boundary extension. .le .ls fluxconserve = no Conserve the flux per unit area? If the input exposures have been flat-fielded to yield a constant sky per pixel then flux conservation should not be used. If the input exposures have been corrected to observed flux per pixel (where the sky varies with the project size of the pixel on the sky) then flux conservation should be used. .le .ls trim = 7 Number of pixels to trim around the input image. This can be used to eliminate bad edge data. It also has the effect of avoiding interpolation problems at the image edges. The piece of the image interpolated is trimmed at the edges by the specified amount but the data in the trimmed region is still used to interpolate beyond the trimmed edge. The amount of trim will depend on the number of bad columns and lines on the edges and on the extent of the interpolant. In general the edge should be at least half of the size of the interpolatant so that for cubics it would be at least 1, for quintic 2, and for sinc half the size of the sinc kernel. .le .ls nxblock = 2048, nyblock = 1024 Working block size for the interpolation. The parameters should be set as large as possible consistent with the available memory maximize the interpolation efficiency. The x block size should typically correspond to the maximum number of columns in an input extension since the interpolation is done extension by extension. .le The following parameters deal with determining the mapping function between input and output pixels. The defaults should be adequate for all cases. See the DESCRIPTION for the meaning of the transformation and \fBgeomap\fR for more detailed information about the parameters. .ls interactive = no Fit the mapping function interactively? The selects the interactive fitting option of \fBgeomap\fR. .le .ls nx = 10, ny = 20 Number of x and y grid points to use over the input image (each piece in a mosaic) to use in determining the mapping function. The grid separation in x and y should be about equal so the default values are appropriate for input image extensions which have twice as many lines as columns. .le .ls fitgeometry = "general" (shift|xyscale|rotate|rscale|rxyscale|general) Type of fitting geometry for the mapping function. This should always be "general". See \fBgeomap\fR for a description of the choices. .le .ls function = "chebyshev" (chebyshev|legendre|polynomial) Type of mapping function to use. The choices are .nf chebyshev - Chebyshev polynomial legendre - Legendre polynomial polynomial - Power series polynomial .fi .le .ls xxorder = 4, xyorder = 4, yxorder = 4, yyorder = 4 Orders of fitting function where order means the highest power of x or y terms. .le .ls xxterms = "half", yxterms = "half" (none|half|full) Type of cross terms for x^i*y^j. The options are "none" to include only terms in which either i or j is zero, "half" to include only terms where i+j is less than the maximum for either i or j, and "full" where i and j take all values less than the maximum for each. .le .ih DESCRIPTION \fBMscimage\fR takes mosaic exposures, consisting of multiple extensions in a multiextension FITS (MEF) file, or single images and resamples them to output images with a desired coordinate grid on the sky. For mosaic exposures all the pieces are resampled to create a single output image. This is the common usage of this task. For single input images this task might be used to take images with different spatial sampling and put them on a common grid. By specifying the same output grid on the sky multiple output images from multiple input exposures can be stacked with simple integer shifts. The output is designed to be used with \fBmscstack\fR or \Bimcombine\fR with "offset=wcs". The list of input mosaic exposures or single images is specified with the \fIinput\fR parameter and a matching list of output images is specified with the \fIoutput\fR parameter. The coordinate grid for the output images is defined by specifying a \fIreference\fR image with the desired coordinate grid. The reference is a single image and not a MEF mosaic exposure. The output of \fBmscimage\fR may be used as a reference image to resample other images to the same coordinate grid. If no reference image is specified then the first input exposure is used to define the output coordinate grid. When the input is a mosaic (which assumes all the pieces have a common tangent point) the piece nearest the tangent point on the sky is used as the reference. Only the linear components of the input image coordinate system are used. In other words, the linear scales and rotation of the coordinate system at the tangent point are used along with a standard tangent plane projection for the output coordinate system. The resampling will remove any higher distortion terms. It is important to understand that resampling to a common coordinate grid does not mean the images are registered in pixel space. What it means is that if one takes the coordinate system of the reference and extends it to infinity then the output image will map to pixels in that grid and the output image will be trimmed to just include the data. Thus different images will not overlay on a display but will stack into a larger image without subpixel errors. For a set of dithered images or mosaic exposures, one common usage is to specify all the exposures in the input leaving the reference image blank. Then all the output images will automatically be resampled so that they can be easily stacked with \fBmscstack\fR. The resampling involves using the world coordinate system (WCS) of the input image or each piece of the input mosaic exposure to interpolate the pieces to the appropriate places in the output image. This task may also create a bad pixel mask, selected by the \fIpixmask\fR parameter, from the input bad pixel masks given by the "BPM" keyword in the headers. Even if there are no masks for the input images/mosaic exposures an output mask is desirable since it will still identify regions with no data such as the gaps in a mosaic and regions around the edges that don't map into the image rectangle. This is discussed further later. The resampling of the input pieces to the output image is done piece by piece where a single input image is treated as an exposure with a single piece. First an empty output image is created with all pixels having the \fIblank\fR value. The output has a size that will just include all the input data. Then each input piece is mapped to the appropriate region of the output image. The mapping function maps input pixel coordinates (xin, yin) to output pixel coordinates (xout,yout). The mapping function is used to determine which input pixels contribute to each output pixel and an interpolation is done to create the output pixel value. The mapping function is determined using the task \fBgeomap\fR and the interpolation is done using the task \fBgeotran\fR. Many of the parameters of this task are for those tasks. The mapping function for an input piece is derived as follows. A grid of points (xin,yin) covering the input piece is generated. The number of grid points in each dimension is set by the \fInx\fR and \fIny\fR parameters. The grid includes the corners. The WCS of the input piece is used to convert the grid pixel coordinates to sky coordinates (wx,wy). The WCS of the output image is used to convert the sky coordinates to matching pixel coordinates in the output image (xout,yout). The task \fBgeomap\fR is used to fit a mapping function (actually one function for each dimension) .nf xin = f1(xout,yout) yin = f2(xout,yout) .fi where the function parameters are defined by task parameters. The function should be general enough to accurately follow distortions in the mapping between the input and output pixel coordinates. The default values for this task should generally be adequate though one might adjust the number of grid points according to the ratio of the input extension dimensions. Once the mapping function is determined the task \fBgeotran\fR does the resampling of the input piece to the output image. This task requires a interpolation type, given by the \fIinterpolant\fR parameter, what to do at the boundary, given by the \fIboundary\fR and \fIconstant\fR parameters, whether to adjust the interpolated value by the ratio of the input and output pixel areas to conserve flux specified by the \fIfluxconserve\fR parameter, and some memory limits specified by \fInxblock\fR and \fInyblock\fR. Whether or not the flux conservation option should be used depends on whether the input data has been calibrated to a constant sky or not. Usually the data is calibrated using a flat-field or sky flat-field which has the effect of making the pixel values be uniform for the sky. This is done regardless of the project pixel size on the sky. If this is the case then the flux conservation option should not be used because the output WCS is defined to have uniform pixel areas on the sky and, therefore, uniform pixel values for the sky. However, the input data may be calibrated to have sky pixel values corresponding to the projected area of the pixel on the sky. This is typically done by taking the flat-fielded data and apply a pixel size correction to the data. In this case the flux conservation option should be used to make the pixel sizes from the input to the output with the associated change in pixel values. The output masks are created by taking any input masks and creating temporary masks with non-zero values (the bad pixel indication) in the input mask mapped to 10000. If there is no input mask then an empty temporary mask is created. This mask is then interpolated using the same coordinate mapping used for the data. Because the input mask jumps between zero and 10000 any interpolated value will generally be 0 where there are only good values contributing to the interpolation, 10000 if there are only bad pixels, or some value in between when there are contributions from the bad pixels. The value 10000 is used since pixel masks have integer values only so any interpolated value with 0.01% effect from a bad pixel will still be identified as a bad pixel. At the edges of the image the pixel mask interpolation uses constant value boundary extension with the value of 10000. This effectively acts as a mask for the out of bounds regions. The interpolation functions for the data and the mask can be independently selected. One might use the same function for both. However, some desirable interpolation functions, such as sinc interpolation, require a large piece of the input for each output pixel. This would effectively mask a large area about any bad pixel. In this case it is recommended that the input data have the bad pixels, including cosmic rays, replaced by interpolated data (using \fBccdproc\fR or \fBfixpix\fR for instance) to eliminate sharp features that ring in the interpolators. By smoothing over the bad pixels artificially, the effects on distant pixels from something like a sinc interpolation should be minimal and so you might only want only the pixels near the marked bad pixels to appear in the output mask. This is done by using an \fBminterpolant\fR of "linear" or "poly3" for the mask even when using a larger interpolant for the data. There is still the problem of interpolating near the edges of the input pieces. The "reflect" boundary extension will largely minimize ringing at the edges from an interpolator. But a possibly better method is to use the \fIntrim\fR parameter to mask out the edges of the input pieces. Even though the trimmed pixels are not mapped to the output (where they appear with the \fIblank\fR) they are still available for the interpolation. Thus the trim parameter should be set to excludes actual bad edges and then to trim in beyond the range of the interpolator. The value to use would be one-half of the order or extent of the interpolator. For dithered mosaic exposures the trimming widens the gaps slightly but insures that there are no edge effects to bleed through when stacking the dithers to fill in the gaps. .ih EXAMPLES 1. Create images for a set of dithered exposures to be later stacked. .nf cl> mscimage @dither1 mos//@dither1 .fi 2. Create images on a common WCS. .nf cl> mscimage obj0321 mos0321 cl> mscimage obj0322 mos0322 ref=mos0321 cl> mscimage obj0323 mos0323 ref=mos0321 .fi .ih REVISIONS .ls MSCIMAGE - V4.1: September 6, 2000 The trimming was changed from being done on the output region to being done on the input region. This better insures minimzation of edge effects since when masking on the output there is a variable amount of the input edges masked (sometimes none) depending on the distortions. The parameters "boundary" and "constant" were added to allow control over the boundary extension. Previously it was fixed to be constant boundary extension with the constant given by the "blank" parameter. Because it was a simple change the task was modified to allow single images as input as well as MEF mosaic exposures. .le .ls MSCIMAGE - V2.11 external package First release. .le .ih BUGS AND LIMITATIONS The current version requires that the circumscribed boxes containing the input extension as projected on the output image do not overlap. This means the rotations of the pieces should be small and the output coordinate system is not rotated with respected to the mean orientation of the input exposure. .ih SEE ALSO geomap, geotran .endhelp mscred-5.05-2018.07.09/doc/mscimatch.hlp000066400000000000000000000015131332166314300172100ustar00rootroot00000000000000.help mscimatch Dec97 mscred .ih NAME mscimatch -- match intensity scales in reconstructed mosaic images .ih SYNOPSIS A list of celestial coordinates is used to select square regions in images to measure. The mean values in the box and in a larger square region around the box are determined. A linear fit between the values for a reference image and a target image is computed. The zero point offset and multiplicative scale factor which match the target image intensities to the reference image intensities is recorded in the image header for later use by \fBmscstack\fR. The task can be used in various levels interactivity or non-interactively. .ih USAGE mscimatch input coords .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCIMATCH - V2.11 external package First release. .le .ih SEE ALSO msczero, mscstack .endhelp mscred-5.05-2018.07.09/doc/mscjoin.hlp000066400000000000000000000057601332166314300167120ustar00rootroot00000000000000.help mscjoin Nov99 mscred .ih NAME mscjoin -- join separate images into MEF files .ih SYNOPSIS This task joins separate images into MEF files. The input images must have names of the form rootname_N where rootname is a user specified input name and N an extension number. A primary image or global header, extension number 0, is required. The images to be joined into extensions must include the keyword "extname" containing the extension names to be created. MSCSPLIT produces this format. .ih USAGE mscjoin input .ih PARAMETERS .ls input List of input image rootnames to be joined. Each rootname will be matched against images having the form rootname_N where N is the extension number. The numbers must be sequential beginning with 0 for the primary image or global header. The images (other than the primary image) must also contain the keyword "extname" giving the extension name to be created .le .ls output = "" List of output MEF names. If no output name is given then the input rootname is used. .le .ls delete = no Delete input images after joining? .le .ls verbose = no Print processing information? .le .ih DESCRIPTION MSCJOIN takes input images with names of the form rootname_N where rootname is a user specified input name and N is the extension number. The extension numbers must be sequential beginning with 0 for the primary image or global header. The output MEF file is created with the extensions in the order given by the extension numbers. The input images must include the keyword "extname" with the desired extension name. Typically this task is used with MSCSPLIT, which creates the required format, to recreate MEF files that were split in order to perform some processing on the image extensions. The output list of MEF names may be left blank. In that case the input rootname is used as the name of the output MEF file. If the input images are not found or the output MEF files exist then a warning is printed and the task proceeds to the next input rootname. The \fIdelete\fR parameter may be used to delete the input images after joining. .ih EXAMPLES 1. Split an MEF file and delete it after splitting. Then do some operations that modify the images. Finally recreate the MEF file. .nf cl> mscsplit obj012 del+ verb+ obj012[0] -> obj012_0 obj012[im1] -> obj012_1 obj012[im2] -> obj012_2 obj012[im3] -> obj012_3 obj012[im4] -> obj012_4 obj012[im5] -> obj012_5 obj012[im6] -> obj012_6 obj012[im7] -> obj012_7 obj012[im8] -> obj012_8 cl> imedit obj012_3 "" cl> mscjoin obj012 del+ verb+ obj012_0 -> obj012 obj012_1.fits -> obj012[append,inherit] obj012_2.fits -> obj012[append,inherit] obj012_3.fits -> obj012[append,inherit] obj012_4.fits -> obj012[append,inherit] obj012_5.fits -> obj012[append,inherit] obj012_6.fits -> obj012[append,inherit] obj012_7.fits -> obj012[append,inherit] obj012_8.fits -> obj012[append,inherit] .fi .ih REVISIONS .ls MSCJOIN - V3.2 First release. .le .ih SEE ALSO mscsplit, fitsutil .endhelp mscred-5.05-2018.07.09/doc/mscotfflat.hlp000066400000000000000000000375351332166314300174170ustar00rootroot00000000000000.help mscotfflat Aug00 mscred .sp 3 .ce \fBOn-The-Fly (OTF) Calibration\fR .sh Overview MSCDISPLAY and the real-time display based on this task applies an on-the-fly (OTF) calibration to raw mosaic exposures as they are being displayed. This does not change the actual data files and the calibration is intended to be quick and approximate. The calibration steps performed are a line-by-line bias subtraction using the overscan region of the data and a division by a flat field. If the data have been overscan corrected or flat field corrected by CCDPROC then the task will automatically skip those steps. The title of the display will indicate if the data have been calibrated by adding "[bias]" for bias subtraction and "[bias,flat=XXX]" for bias subtraction and flat fielding using an OTF flat field called XXX. The bias subtraction is performed by averaging the overscan pixels in a line and subtracting this average from all the pixels in the line. This removes the amplifier bias and line-by-line patterns. The flat field or response calibration is performed by reading special flat field calibration data which provides an approximate relative response for each pixel in each amplifier readout. Depending on how the calibration file is derived this will approximately correct for pixel sensitivity variations, gain variations between the amplifiers, sky illumination variations, and any pupil ghost pattern (as occurs with NOAO Mosaic data from the KPNO 4meter telescope). Note that this is not the correct way to remove the pupil ghost but for the purposes of flattening the display in order to see faint objects this is useful. The other display related tasks, MSCEXAMINE and MSCFOCUS, must perform the same correction when the display and cursor are used to select data to measure. Currently they do not know if the data have been calibrated in the display. Instead, one must make sure to use the same parameters relating to the display in the MIMPARS parameter set. .sh Creating and Installing OTF Flat Fields at NOAO 1. Take one or more flat fields. The count levels have to be below 30000. If not divide the values by a number either before or after processing using MSCARITH. Since the OTF flats are spatially binned and digitized to reduce size it probably is not very useful to create a high quality flat from multiple exposures, a single exposure should be fine. 2. Process the flat(s). The processing should be only overscan and trim. If combining multiple flats with FLATCOMBINE set the processing as noted. The processing should save the raw exposures in the Raw subdirectory (or whatever is set for the "backup" parameter in MSCRED). 3. Run MSCOTFFLAT with the default values. The output name must be one word (that is an acceptible directory name) and should be the standard identifier for the filter. Typically this would be the first word of the filter name recorded in the header (with any characters which are not letters, numbers, or '.' replaced with '_'). The template name is one of the raw exposures. .nf ms> mscotfflat flat001 B Raw/flat001 .fi This will create a subdirectory, B in this example, with the number of pl files equal to the number of extensions. 3a. You can check if things make sense by the size of the pl files being approximately 0.6-1.6Mb. You can also display the files and compare with the original data using: .nf ms> display B/flat1 1 fill+ ... ms> display flat00[1] 2 fill+ ... .fi They should be very similar to the flat from which they were derived. 4. To use during your run with the real-time DCA display you would set the calibration directory in the DCA GUI to point to the parent directory containing the subdirectories of pl files (the directory you were in when you ran MSCOTFFLAT). This is done from the "Edit" menu, selecting "Path Params", editing the "Calibration Dir" field, and finally clicking "Apply". Also if you are going to use MSCDISPLAY with "process=yes" then go to the "mimpars" parameters and set the "caldir" directory parameter there too. Remember that directories in IRAF must end with '/' (or '$' for logical directories). If you do nothing else the software will look in the specified calibration directory for a subdirectory which matches the first word of the filter string in the image header (with any characters that are not letters, numbers, or '.' changed to '_'). If you want to translate the header filter name to some other (directory) name you can add a "cal.men" file where the first column is the filter name (quoted if there are blanks) and the second column is the directory name. This file is also used to set the override choices for the filter in the DCA GUI. The following is done to install the OTF directory for general use and requires the IRAF login. 5. Login as IRAF and go to the standard calibration directory: .nf /iraf/extern/mscdb/noao/ctio/4meter/caldir/Mosaic2A # CTIO 4m (8 A amps) /iraf/extern/mscdb/noao/ctio/4meter/caldir/Mosaic2B # CTIO 4m (8 B amps) /iraf/extern/mscdb/noao/ctio/4meter/caldir/Mosaic2 # CTIO 4m (16 amps) /iraf/extern/mscdb/noao/kpno/4meter/caldir # KPNO 4m /iraf/extern/mscdb/noao/kpno/36inch/caldir # KPNO 36inch /iraf/extern/mscdb/noao/kpno/wiyn/caldir # KPNO WIYN .fi Transfer the OTF directory to that calibration directory. One way is .nf % (cd /md1/4meter/nite1; wtar B) | rtar -xv .fi 6. Edit the cal.men file. The first column is the filter name as given in the data files under the FILTER keyword. The second name is the directory name. The order of the entries in the order in which the filters will appear in the DCA list. Note the DCA list is only used to override the automatic filter selection based on the filter keyword. 7. Remove the OTF directory in your data area. One way is with "!rm -rf ". You can also restore the original raw flats for taping by moving the files from the Raw subdirectory back to the data directory. 8. I am maintaining a master MSCDB directory that includes current OTF flats. This serves the purpose of a backup, the source to generate installation files, and the source to generate distribution files for users who might want them. So if you create OTF files please notify me. .sh OTF Flat Field Calibration Format The flat field calibration is a special, more compact format than a regular mosaic flat field. The small size is important both to save disk space in a standard calibration directory with lots of filters and to allow more efficient I/O and in-memory storage of the flat field data. For instance, the NOAO Mosaic has 14 filters and two telescopes. The compression relies on two factors. First is that pixel values can be quantized and still produce a good approximate calibration. The second is that the quantized values often have the same values over contiguous regions. These factors allow use of the IRAF pixel list format which represents integer values which are constant over segments of each line by fewer bytes than the individual values. The algorithm for creating the compressed flat field format consists of two simple steps with two parameters. The first step is to block average the original real-valued flat field specified by a block average factor. This brings neighboring values to the same value which aids the pixel list representation. Then the quantization is performed using the equation: .nf quantized integer value = int (nint (value / scale) * scale) .fi where "value" is the real flat field pixel value and "scale" is a quantization factor. The nint function takes the nearest integer value of its argument and the int function truncates its argument to an integer. The scale factor is defined by .nf scale = * resolution .fi where "" is the mean flat field value and "resolution" is a parameter of the algorithm. The resolution is then a fractional resolution of the mean flat field. For example, suppose the mean flat field value is 5001.23 and the resolution is 0.5%. The digitization quantum is then 25.006. A flat field value of 5123.45 would be quantized to 5126 and all values between 5113.8 to 5138.8 also quantize to 5126. The NOAO Mosaic has significant flat field variations, which prompted the development of the OTF calibration. The variations are on the order of 10%. The size of a full flat field exposure, reduced to real values, is 256 Mb. Applying the algorithm above with a 2x2 block average and a 0.5% resolution produces an IRAF pixel list format, OTF flat field which is ~5 Mb. Application of this OTF flat field shows virtually no artifacts. .sh MIMPARS Parameters The parameters controlling the OTF calibration are set in the MIMPARS parameter set. This parameter set is a subset of the MSCDISPLAY, MSCEXAMINE, and MSCFOCUS tasks. As such they can be edited from EPAR on these task by typing ":e" when over the "mimpars" parameter or the values can be given on the command line for those tasks. Typing "mimpars" or "epar mimpars" will also let you edit these parameters and "lpar mimpars" will display the parameters. The EPAR display looks like .nf ms> mimpars I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mimpars (extname= ) extension name pattern (exttmpl= _![1-9]![1-9]![1-9].*) extension template for ... (xgap = 72) minimum X gap between images (ygap = 36) minimum Y gap between images (process= no) do calibration processing? (oversca= yes) do line-by-line overscan subtraction? (flatfie= yes) do flat field correction? (caldir = ) calibration directory (filter = ) filter .fi The first two groups of parameters have to do with selecting data to be displayed and the gaps between the mosaic pieces added during display. It is the last set of parameters that deal with the OTF calibration. For the NOAO Mosaic, running SETINSTRUMENT or using the parameters set at the telescope will set some of these parameters appropriately to reference a calibration directory supplied by the instrument team. For example, at the Kitt Peak 4meter telescope the parameters would be .nf (caldir = mscdb$noao/kpno/4meter/caldir/) cal... (filter = !filter) filter .fi The \fIprocess\fR parameter selects whether to turn on or off the OTF processing. If it is no then regardless of the \fIoverscan\fR or \fIflatfield\fR values no calibration will be done. If it is yes then one or both calibration operations can be selected. The flat field calibration requires special calibration files. The \fIcaldir\fR parameter defines a directory containing the calibration files. This can be a standard directory or a user directory. Note that if a directory is specified it must end with $ or /. In this directory, which could include other files, the calibrations are given by some set of names. Currently these are the names of directories containing pixel list files for each amplifier. Creating these files is done with the task MSCOTFFLAT which is described below. The \fIfilter\fR parameter can be set to one of these names. For more automatic selection of calibrations, the calibrations can be selected by the filter string in the header (or by giving the same filter string in the \fIfilter\fR parameter). To use the filter string in the header the value of the filter parameter is set to "!" where is the keyword for the filter string. The filter string often contains some general description. The OTF calibration software goes through the following steps to resolve the string to a calibration file in the calibration directory. .ls 4 1. If the file "cal.men" is present in the calibration directory it is read to find translations between the filter string and the calibration name. The translations consist of two columns with the full filter string and the calibration name. If either contains spaces then it must be quoted. For example: .nf "OIII Mosaic N2" O3 .fi .le .ls 4 2. If the file is not present or a match to the filter string is not found then the first word of the filter string is used with non-alphanumeric characters replaced by '_'. For example, "OIII Mosaic N2" is mapped to OIII. .le .ls 4 3. If the name arrived at by the first two methods fails then a calibration called "default" in the calibration directory is sought. .le Note that one may use the "cal.men" file or not and one can use logical links to provide explicit mappings between filters for which a calibration has been generated and those which have not in addition to making "default" link to some particular filter calibration. .sh Real-time Display with the DCA At the telescope with the NOAO Mosaic, the data capture agent (DCA) has controls to select processing during the readout automatic display. One toggle is equivalent to the \fIprocess\fR parameter. If the processing is turned on the DCA automatically selects only overscan bias subtraction for non-object exposures and selects both bias subtraction and flat field division for object exposures. The \fIfilter\fR parameter is set by passing through the filter string from the data acquisition system or by overriding this and using the filter menu to select one of the available calibrations. .sh Creation of OTF Flat Fields Begin by reducing the flat field data. This could be from combining a sequence of dome flat exposures or it could be more ambitious super sky flat field. The reduced flat field would normally be trimmed to remove the bias. A template raw flat field exposure needs to be kept to define the final OTF flat field size and keywords. The OTF flat field needs to be the same size as the common raw exposures for efficiency since if the OTF flat field is a different size it will be adjusted to match the data being calibrated but at some computation expense. The OTF flat field is prepared from a real flat field using the task MSCOTFFLAT. The parameters are .nf I R A F Image Reduction and Analysis Facility PACKAGE = mscred TASK = mscotfflat input = Input processed mosaic flat field output = Output OTF flat field template= Template raw mosaic flat field (bin = 2) Binning size (resolut= 0.005) Resolution .fi The input is the name of the reduced flat field exposure. The output name is typically an abbreviated version of the filter name though it could be anything. The template parameter is the name of a raw exposure. Finally the two algorithm parameters described previously. An example showing the reduction of a sequence of flat field exposures to an OTF flat field for the "V Mosaic" filter follows. This assumes the MSCRED, CCDPROC, and FLATCOMBINE parameters have been set as desired ( basically the default values). .nf ms> flatcombine flat* ms> mscotfflat FlatV V Raw/flat001 ms> dir V flat1.pl flat3.pl flat5.pl flat7.pl flat2.pl flat4.pl flat6.pl flat8.pl .fi Note that the individual pixel list (pl files) can be examined using IRAF image tasks. In particular, they can be display with \fBdisplay\fR. To use this OTF flat field in the current directory .nf ms> mscdisplay obj123 1 proc+ caldir="" filter=V .fi To use a standard directory and setup the filter name translation create or move the OTF directory and contents in the desired standard directory. In that directory create a file "cal.men" which has the filter name followed by the OTF calibration directory names. To place the OTF flat field in a standard directory and setup the filter name translation .nf ms> dir home$otfdir V B cal.men ms> page home$otfdir/cal.men "V Mosaic" V "B Mosaic" B ms> mscdisplay obj123 1 proc+ caldir=home$otfdir/ filter=!filter .fi If you are creating OTF flat field for users of the NOAO Mosaic at Kitt Peak the calibration directories are mscdb$noao/kpno/4meter/caldir/ and mscdb$noao/kpno/36inch/caldir/. .endhelp mscred-5.05-2018.07.09/doc/mscrfits.hlp000066400000000000000000000133461332166314300171010ustar00rootroot00000000000000.help mscrfits Aug97 mscred .ih NAME mscrfits -- read Mosaic data from a FITS tape .ih SYNOPSIS FITS files from tape are copied to disk with a possible renaming to restore the filename the file had when written by \fBmscwfits\fR. One may also just list the contents of the tape. .ih USAGE mscrfits input [output] .ih PARAMETERS .ls input The input IRAF tape specification with no position; e.g. mta. .le .ls output The output root name for the files. Multiple files will be written with a four digit numeric extension based on the \fIoffset\fR parameter and the tape position. Once the file is written to disk the file name may be changed to the name specified by the FILENAME keyword (provided a file doesn't already exist with that name) if the \fIoriginal\fR parameter is set. If only listing the contents of the tape this parameter need not be specified. .le .ls tapefiles = "1-" A range list of tape file numbers to read or list. See the help topic "ranges" for information about the range list syntax. .le .ls listonly = no List the specified tape files only? If "yes" then no output files will be created and a short or long listing of each selected tape file will be printed to the standard output. If both \fIshortlist\fR and \fIlonglist\fR are "no" then the short listing will be produced. Note that a short listing is considerable faster than the long listing because only the first header needs to be read. .le .ls shortlist = yes List one line of information for each tape file? This includes the the tape specification with position, the output file name if reading files, the stored original filename if present, the value of the NEXTEND keyword if present, and the value of the OBJECT keyword if present. .le .ls longlist = no List the short listing information plus additional information about each FITS header? The information includes the extension index, extension type, extension name, BITPIX, and NAXIS values. .le .ls offset = 0 Offset for numbering of output disk filenames. The output file name is the output rootname with four appended digits made from adding the offset and the tape position (which starts with 1). The offset parameter is useful when not restoring the original filenames and when reading data from multiple tapes. .le .ls original = yes Restore the original filename? If a FILENAME or IRAFNAME keyword is found in the FITS file then when the file has been written to disk using the specified output name the output file is renamed to the original filename with a ".fits" extension. .le .ih DESCRIPTION The specified tape files are either copied from tape to disk or just a summary listing is printed to the standard output. The tape files are checked to make sure they appear to be FITS format (they must begin with a SIMPLE card) and then directly copied to disk without change if not simply listing. Any FITS tape file can be read including multiextension files with any extension types. When reading the files to disk (\fIlistonly\fR=no) the tape file is copied to a disk file with filename given by the output file root name, followed by a four digit number composed of the \fIoffset\fR value plus the tape file position, and then with a ".fits" extension. If the \fIoriginal\fR parameter is set and a FILENAME or IRAFNAME keyword is found the disk file is ultimately renamed to filename specified by those keywords. If the desired original filename is already in use then a warning is given and the output file is not renamed. Summary information for the selected tape files may be written to the standard output whether or not a disk file is created. A short listing includes the tape identification and the output filename (if creating an output file), the original file name if the FILENAME or IRAFNAME keyword is present, the value of the NEXTEND keyword if present, and the value of the OBJECT keyword if present. The long list includes the short listing plus information from each FITS header unit. This information consists of the extension index (0 for the primary header), and the values of the following keywords if present: XTENSION, EXTNAME, EXTVER, BITPIX, and NAXIS#. One common use of MSCRFITS is to list the contents of the tape. This is done by setting the \fIlistonly\fR parameter. This turns off creating a disk file and forces at least the short listing. Note that if just the short listing is selected the listing is most efficient since only the first header unit needs to be read. The long listing requires the entire file to be read. .ih EXAMPLES 1. Read a set of files with the default short listing. .nf cl> mscrfits mta data mta[1] -> data0001.fits: abc nextend=8 NGC ABC Rename data0001.fits -> abc.fits mta[2] -> data0002.fits: def nextend=8 NGC DEF Rename data0002.fits -> def.fits ... .fi 2. List a tape with the default short listing. .nf cl> mscrfits mta list+ mta[1]: abc nextend=8 NGC ABC mta[2]: def nextend=8 NGC DEF ... .fi 4. List a tape with the default short listing and save the listing in a file. .nf cl> mscrfits mta list+ >> fitslog .fi 4. Read a set of Mosaic files with a long listing without restoring the original names. .nf cl> mscrfits mta data tape=4,9,12 long+ original- mta[4] -> data0004.fits: abc nextend=8 NGC ABC 0 PRIMARY 1 IMAGE im1 16 2044x4096 2 IMAGE im2 16 2044x4096 3 IMAGE im3 16 2044x4096 4 IMAGE im4 16 2044x4096 5 IMAGE im5 16 2044x4096 6 IMAGE im6 16 2044x4096 7 IMAGE im7 16 2044x4096 8 IMAGE im8 16 2044x4096 mta[9] -> data0009.fits: def nextend=8 NGC DEF 0 PRIMARY 1 IMAGE im1 16 2044x4096 ... .fi .ih REVISIONS .ls MSCRFITS - V2.11 external package First release. .le .ih SEE ALSO mscwfits .endhelp mscred-5.05-2018.07.09/doc/mscshutcor.hlp000066400000000000000000000103601332166314300174320ustar00rootroot00000000000000.help mscshutcor Dec03 noao.obsutil .ih NAME mscshutcor -- shutter correction from mosaic images of varying exposure .ih SYNOPSIS MSCSHUTCOR calculate the shutter correction for a mosaic camera given a sequence of overscan corrected images of varying durations. Typically these would be flat field exposures. The shutter correction is the intercept on a plot of exposure duration versus exposure level. .ih USAGE mscshutcor images .ih PARAMETERS .ls images List of overscan corrected mosaic exposures. These would usually be flat field exposures. .le .ls extnames = "" List of extension names or patterns matching the full extension name. Each comma delimited segment is treated as a pattern so multiple patterns may be used. .le .ls section = "" The selected image section for the statistics. This should be chosen to exclude bad columns or rows, cosmic rays, and other non-linear features. Note that the section is in pixel coordinates and will be used on all the selected extensions. .le .ls center = "mode" The statistical measure of central tendency that is used to estimate the data level of each extension. This parameter can have the values: \fBmean\fR, \fBmidpt\fR, or \fBmode\fR. These are calculated using the same algorithm as the IMSTATISTICS task. When there is more than one extension the measured statistics over each extension are averaged. .le .ls nclip = 3 Number of sigma clipping iterations. If the value is zero then no clipping is performed. .le .ls lsigma = 4, usigma = 4 Lower and upper sigma clipping factors used with the mean value and standard deviation to eliminate cosmic rays. Since \fBfindgain\fR is sensitive to the statistics of the data the clipping factors should be symmetric (the same both above and below the mean). .le .ls exposure = "exptime" Keyword giving the exposure time. .le .ls verbose = yes Verbose output? .le .ih DESCRIPTION MSCSHUTCOR calculate the shutter correction for a mosaic camera given a sequence of overscan corrected exposures of varying durations. Typically these would be flat field exposures. For the selected extensions the exposure time specified in the EXPTIME keyword is extracted. A photometric measure, given by the \fIcenter\fR parameter, of the data over all the extensions is estimated. When there are multiple extensions in an exposure the statistics obtained separately in each extension are averaged. Note that this is valid even when the extensions have different gains provided all exposures have the same gains. The shutter correction is the intercept divided by the slope from a plot of the exposure time versus photometirc exposure statistic. When the \fIverbose\fR parameter is set the statistics from each exposure and the fit values are output. The first image extension in each exposure must contain the keywords OVERSCAN and EXPTIME otherwise an error will be given. A warning is given if the image contains the keyword FLATCOR. Bad pixels should be eliminated to avoid affecting the statistics. This can be done with sigma clipping and/or an image section; though when there are multiple extensions the same image section is applied to each one. The sigma clipping should not significantly affect the assumed gaussian distribution while eliminating outlyers due to cosmic rays and unmasked bad pixels. This means that clipping factors should be symmetric. This task is a similar to the task \fBobsutil.shutcor\fR except that it handles multiextension mosaic files. However, this task will also work with simple single images and so may be used for both mosaic and non-mosaic data. .ih EXAMPLES A sequence of flat fields with varying exposure times are taken and processed to subtract the overscan. .nf cl> mscshutcor flat* Shutter correction = 0.538 +/- 0.043 seconds Information about the mode versus exptime fit: intercept slope (and errors) 5.347105 9.933618 0.4288701 0.01519613 chi sqr: 0.2681 ftest: 419428. correlation: 1. nr pts: 4. std dev res: 0.422769 x(data) y(calc) y(data) sigy(data) 3. 35.148 34.6725 0. 12. 124.551 125.015 0. 27. 273.555 273.778 0. 48. 482.161 481.949 0. .fi .le .ih SEE ALSO obsutil.shutcor, imstatistics .endhelp mscred-5.05-2018.07.09/doc/mscsplit.hlp000066400000000000000000000067231332166314300171060ustar00rootroot00000000000000.help mscsplit Nov99 mscred .ih NAME mscsplit -- split MEF files into separate images .ih SYNOPSIS This task splits MEF files into separate images. The output images have names of the form rootname_N where rootname is a user specified output rootname and N is the extension number. The primary images or global headers are also created. The output of this task can be used with MSCJOIN to recreate an MEF file with the same structure and extension names. .ih USAGE mscsplit input .ih PARAMETERS .ls input List of input MEF files to be split. If the list includes image type extensions then the extension must be specified in the \fImefext\fR parameter. .le .ls output = "" List of output root names. If no output rootname is given then the input name is used as the rootname. The output split images will have the specified rootname with suffix "_N" where N is the extension number. .le .ls mefext = ".fits" MEF filename extension. This is used to identify the part of the input name to strip off to form the rootname for the output if no rootname is specified. .le .ls delete = no Delete MEF files after splitting? .le .ls verbose = no Print processing information? .le .ih DESCRIPTION MSCSPLIT takes multiextension format (MEF) files and separates them into separate images. The output is designed to be used with MSCJOIN to recreate an MEF file with the same structure and extension names. Typically this task is used to allow operating on the extension images separately after which the MEF file is recreated. A list of input MEF files is given and each file is separated into images with names of the form rootname_N where rootname is a user specified output rootname and N is the extension number. The primary image, extension number 0, is also created. The output rootname list may be left blank in which case the input MEF file name is used as the rootname. If the input MEF file is not found or the output files exist then a warning is printed and the task proceeds to the next input file. The \fIdelete\fR parameter may be used to delete the input MEF file after splitting. This is useful in conjunction with MSCJOIN to later recreate the MEF file. The output separate images may be displayed with MSCDISPLAY if the parameter \Imimpars.exttmplt\fR is of the form "_![1-9]*.*" and the rootname does not match an MEF file. Other display oriented tasks such as MSCZERO and MSCEXAM will also work with this format. .ih EXAMPLES 1. Split an MEF file and delete it after splitting. Then do some operations that modify the images. Display the separate images with MSCDISPLAY. Finally recreate the MEF file. .nf cl> mscsplit obj012 del+ verb+ obj012[0] -> obj012_0 obj012[im1] -> obj012_1 obj012[im2] -> obj012_2 obj012[im3] -> obj012_3 obj012[im4] -> obj012_4 obj012[im5] -> obj012_5 obj012[im6] -> obj012_6 obj012[im7] -> obj012_7 obj012[im8] -> obj012_8 cl> imedit obj012_3 "" cl> mscdisplay obj012 1 exttmplt="![1-9]*.*" file template: obj012_![1-9]*.* cl> mscjoin obj012 del+ verb+ obj012_0 -> obj012 obj012_1.fits -> obj012[append,inherit] obj012_2.fits -> obj012[append,inherit] obj012_3.fits -> obj012[append,inherit] obj012_4.fits -> obj012[append,inherit] obj012_5.fits -> obj012[append,inherit] obj012_6.fits -> obj012[append,inherit] obj012_7.fits -> obj012[append,inherit] obj012_8.fits -> obj012[append,inherit] .fi .ih REVISIONS .ls MSCSPLIT - V3.2 First release. .le .ih SEE ALSO mscjoin, fitsutil .endhelp mscred-5.05-2018.07.09/doc/mscstack.hlp000066400000000000000000000007351332166314300170550ustar00rootroot00000000000000.help mscstack Aug97 mscred .ih NAME mscstack -- combine multiple reconstructed mosaic images .ih SYNOPSIS This is a simple convenience routine that combines multiple reconstructed images by registering using integer shifts based on the WCS. It excludes the gaps in the individual mosaic images. .ih USAGE mscstack input output .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCSTACK - V2.11 external package First release. .le .ih SEE ALSO imcombine .endhelp mscred-5.05-2018.07.09/doc/mscstat.hlp000066400000000000000000000006621332166314300167220ustar00rootroot00000000000000.help mscstat Oct97 mscred .ih NAME mscstat -- image statistics on Mosaic files .ih SYNOPSIS This tasks computes image statistics, using \fBimstat\fR, by expanding each mosaic file into image extensions. Image sections are allowed in the mosaic filenames. .ih USAGE mscstat images .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCSTAT - V2.11 external package First release. .le .ih SEE ALSO msccmd, imstat .endhelp mscred-5.05-2018.07.09/doc/mscwcs.hlp000066400000000000000000000006371332166314300165450ustar00rootroot00000000000000.help mscwcs Aug97 mscred .ih NAME mscwcs -- set and adjust Mosaic WCS .ih SYNOPSIS The Mosaic WCS is set by assigning a plate solution database and updating the zero point with specified offsets. The offset values may be set with \fBmsczero\fR. .ih USAGE mscwcs images .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCWCS - V2.11 external package First release. .le .ih SEE ALSO msczero .endhelp mscred-5.05-2018.07.09/doc/mscwfits.hlp000066400000000000000000000111201332166314300170720ustar00rootroot00000000000000.help mscwfits Aug97 mscred .ih NAME mscwfits -- write Mosaic data to a FITS tape .ih SYNOPSIS Mosaic data, in FITS format, as well as any other FITS format files are written to a FITS tape. If a FILENAME keyword is present it is updated to the name of the disk file for use in later restoring the data with \fBmscrfits\fR. .ih USAGE mscwfits input output newtape .ih PARAMETERS .ls input List of FITS files to write to tape. This includes Mosaic multiextension FITS files as well as any other FITS format files. .le .ls output The output IRAF tape specification. This may be a simple tape name, such as "mta", or include additional specifiers. A tape file number may be specified, e.g. mta[5] or mta[EOT], to position the tape otherwise the \fInewtape\fR parameter defines the starting position. Note that specifying any position other than the next tape file number (the number of files on the tape plus one) or EOT will cause data to be clobbered if the tape file position is less than the next file or behave in an unspecified way if it is greater than the next file. However, specifying the next tape file number is the most efficient way to skip to the end of tape to begin writing. .le .ls newtape Is the tape a new or blank tape? If "yes" and no file position is specified in the output tape name the FITS files will be written starting at the beginning of the tape. If "no" and no file position is specified the task will skip to the end of the tape to write the files. Note that this parameter is queried for if not given on the command line regardless of whether it is needed or not. .le .ls shortlist = yes List one line of information for each file written? This includes the input filename, the tape specification with position, the filename stored in the FITS file for later restoration (the same as the input filename with path and extensions removed), the value of the NEXTEND keyword if present, and the value of the OBJECT keyword if present. .le .ls longlist = yes List the short listing information plus additional information about each FITS header? The information includes the extension index, extension type, extension name, BITPIX, and NAXIS values. .le .ih DESCRIPTION A list of input FITS files are copied to tape. The files are checked to make sure they appear to be FITS format (they must begin with a SIMPLE card) and then directly copied to the tape in FITS format blocking with a blocking factor of 10. The only change made to the file is that if a FILENAME or IRAFNAME keyword is found then the value of the keyword is set to the input file name with any directory and extension removed. Any FITS file can be written including multiextension files with any extension types. The files are written to the tape file position given by the output tape specification if one is given. If only the tape name is given without a position specification then the files are either written to the beginning of the tape if \fInewtape\fR = yes or after the end of tape mark if \fInewtape\fR = no. A listing of the operations may be selected. The listing information includes the input files and the tape position being written. A short listing provides one line per input file written while the long listing includes additional lines for each FITS header block. Keywords which will appear in the listing if found are NEXTEND and OBJECT in the first line and XTENSION, EXTNAME, EXTVER, BITPIX, and the NAXIS# in the long listing for each FITS header. Note that there is no attempt to check that NEXTEND matches the actual number of extensions. .ih EXAMPLES 1. Write a set of files, given by an @file, to a new tape with the default short listing. .nf cl> mscwfits @data1 mta yes abc.fits -> mta[1]: abc nextend=8 NGC ABC def.fits -> mta[EOT]: def nextend=8 NGC DEF ... .fi 2. Write a set of Mosaic files, given by a wildcard template, to the end of a tape with the long listing. .nf cl> mscwfits @data1 mta no long+ efg.fits -> mta[EOT]: efg nextend=8 NGC EFG 0 PRIMARY 1 IMAGE im1 16 2044x4096 2 IMAGE im2 16 2044x4096 3 IMAGE im3 16 2044x4096 4 IMAGE im4 16 2044x4096 5 IMAGE im5 16 2044x4096 6 IMAGE im6 16 2044x4096 7 IMAGE im7 16 2044x4096 8 IMAGE im8 16 2044x4096 hij.fits -> mta[EOT]: hij nextend=8 NGC HIJ ... .fi 3. Given that you know a tape has 40 files on it and you want to append to the file and save the listing information to a file: .nf cl> mscwfits @data2 mta[41] no >> fitslog .fi .ih REVISIONS .ls MSCWFITS - V2.11 external package First release. .le .ih SEE ALSO mscrfits .endhelp mscred-5.05-2018.07.09/doc/mscxcor.hlp000066400000000000000000000011131332166314300167120ustar00rootroot00000000000000.help mscxcor Aug97 mscred .ih NAME mscxcor -- register multiple overlapping Mosaic exposures .ih SYNOPSIS Multiple overlapping Mosaic exposures which have fairly accurate WCS have their WCS adjusted to register them to a common system. This is done by selecting regions of each extension based on the WCS and using cross-correlation to find shifts. The average of the shifts defines the WCS correction. .ih USAGE mscxcor input reference .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCXCOR - V2.11 external package First release. .le .ih SEE ALSO xregister .endhelp mscred-5.05-2018.07.09/doc/msczero.hlp000066400000000000000000000015571332166314300167320ustar00rootroot00000000000000.help msczero Aug97 mscred .ih NAME msczero -- display, measure coordinates, and set WCS zeropoint offsets .ih SYNOPSIS If the specified Mosaic exposure is not in the display it is displayed. The cursor is used to report WCS coordinates (space bar). Pointing at a star and typing 'z' applys a centering to the star data, reports the coordinate based on the current WCS, and queries for a corrected coordinate. The difference between the current and corrected coordinate is used to compute an offset to the current WCS. When 'q' is typed the last offset may be recorded in the parameters for \fBmscwcs\fR for adjusting other exposures and it can be used to update the WCS of the image. .ih USAGE msczero images .ih PARAMETERS .ih DESCRIPTION .ih EXAMPLES .ih REVISIONS .ls MSCZERO - V2.11 external package First release. .le .ih SEE ALSO mscdisplay mscexamine mscwcs .endhelp mscred-5.05-2018.07.09/doc/patfit.hlp000066400000000000000000000443431332166314300165370ustar00rootroot00000000000000.help patfit Jan02 mscred .ih NAME patfit -- fit and remove 2D pattern in images .ih PARAMETERS .ls input List of input images or multiextension files. .le .ls output List of output images or multiextension files. This parameter is ignored if \fIouttype\fR is "none". If no list is specified then the input list is used, otherwise the output list must match the input list. If an input and output file are the same the output is created in a temporary file and the input is replaced after the output is completed. .le .ls pattern List of pattern images or multiextension files. The list must either match the input list or be a single file to be used for all the input files. .le .ls weight = "" List of weight images or multiextension files. The images will be linearly interpolated to the size of the data if needed. If no weight list is specified then the pattern list is used. Otherwise the list must either match the input list or be a single file to be used for all the input files. .le .ls masks = "", patmasks = "" List of masks identifying pixels to ignore in the input or pattern data. Pixels to ignore have non-zero mask values. An empty list applies no bad pixel mask, a single mask applies to all input data, and a list is matched with the input or pattern list. A mask is specified by a filename or by reference to a filename given by the value of a header keyword in the input or pattern image. A header keyword reference is made with the syntax "!" where is the desired keyword with case ignored. For multiextension files the masks may be either a multiextension file with matching extension names or a directory of pixel list files with the extension names as the filenames. .le .ls background = "", bkgpattern = "", bkgweight = "" List of backgrounds for the input data, the patterns, and the weights. If no list is given then the mean of the data, excluding masked pixels, is used. The list may be either a single value which applies to all the input data or match the input list in number. The backgrounds may be specifed as images or constant values. Images are linearly interpolated to the size of the data images if the sizes do not match. .le .ls ncblk = 1, nlblk = 1 Moving average block size for the input, pattern, and weight images. The block average size for columns and for lines are specified separately. .le .ls extfit = "", extout = "" Extensions to use for the fit and for output when multiextension files are specified. A null string matches all extension names. Otherwise the parameters are comma separated lists of patterns which match the entire extension name. Thus, a list of extension names may be given or the pattern matching characters '?' for any character or [] for a set of characters. The set may include ranges in ascii order by using hyphens; i.e. 1-3 matches the characters 1, 2, and 3. All the extensions selected for fitting must exist for the other input files and all the selected output extensions must exist in the pattern file. .le .ls outtype = "none" Output type from the choices "none", "fit", "diff", "flat", "ratio", "pfit", "pdiff", "pratio", "pflat", "sfit", "sdiff", "sratio" and "sflat". See the DISCUSSION section for an explanation of the different output types. .le .ls logname = "PATFIT" Name to be used to identify the log output from the task. This name is also used for a keyword in the output image header so it should conform to the FITS definition for a keyword. .le .ls logfile = "" Filename for appending log information. If no name is specified then no log is written. Note that there is no need to use "STDOUT" since the same information is written when the \fIverbose\fR parameter is set. .le .ls verbose = yes If set to yes log information is written to the standard output. Note that this is the same information as written to the logfile specified by the \fIlogfile\fR parameter. .le .ih DESCRIPTION PATFIT determines the intensity scaling that minimizes the weighted mean difference between an input image and a pattern image given in equation 1. The input images, specified by the \fIinput\fR parameter, may be individual images (which includes images selected from multiextension files as explicit image extensions) or multiextension files specified by a root filename. In the latter case the image extension names selected by the \fIextfit\fR parameter are used for computing a global pattern scale for all the extensions. The output of this task may include images of the scaled pattern or pattern corrected images. files. When the input is a multiextension file the output is a multiextension file of the extensions specified by the \fIextout\fR parameter. The statistic used to compute the scale is .nf (1) <(((A - B) - s (P - Q)) (W - V))> = 0 .fi where .nf A Input image (\fIinput\fR parameter) B Input image background (\fIbackground\fR parameter) P Pattern image (\fIpattern\fR parameter) Q Pattern image background (\fIbkgpattern\fR parameter) W Weight image (\fIweight\fR parameter) V Weight image background (\fIbkgweight\fR parameter) s Scale factor .fi The solution of equation 1 is determined over all pixels in the image or extensions selected by the \fIextfit\fR parameter which are not flagged in the pixel masks specified by the \fImasks\fR and \fIpatmasks\fR parameter. For multiextension files equation 1 is also solved separately for each extension and estimates of the scale are shown in the log output (see examples 2 and 3). However, the final scale is not the average of these values but the solution over all pixels. To treat image extensions as independent images the various file lists must be explicit images rather than multiextension file rootnames (see example 4). An additional option for the input, pattern, and weight images is to smooth the images by a moving average when accumulating the statistics. The block size of the moving average is given by the parameters \fIncblk\fR and \fInlblk\fR. The smoothing feature is useful when the data has noise which is comparable in amplitude to the pattern. The effect of noise on the pattern fitting is to reduce the scaling computed. There are three types of backgrounds which may be specified. An image, a constant, and the mean value. The image may be a fully sampled image of the same size as the image to which it applies or a smaller sampled image that is interpolated to match the size of the image. The mean value is specified by a null string, "". In the common case where all of the background terms are given by mean values the fitting equation becomes .nf (2) <(((A - ) - s (P -

)) (W - ))> = 0 .fi The weight image has the same options as the background images, namely a fully sampled image, a subsampled image, or a constant in which case the weight background is ignored. If the weight image is given as the null string then the pattern image is used for the weight image. Using the pattern image for the weight image (and the pattern background for the weight background) is a common case which which leads to the fitting statistic .nf (3) <(((A - B) - s (P - Q)) (P - Q))> = 0 .fi Clearly the role of the weighting is to given greater weight to the regions where the pattern is most significant or noticible in the input data. The peaks and valleys of a pattern is what people see in weak patterns contaminating data images and so equation 1 with the weighting is designed to best eliminate this part of the pattern. In other words, the eye is very sensitive at seeing pattern correlations even in very weak contamination and this task optimally attempts to reduce these correlations. A key to obtaining the best match between the pattern and the input data is to use masks for the input and the pattern. If the input consists of a pattern with a scene superposed, such as astronomical objects, then to avoid the scene/objects biasing the scale estimate, an input image mask identifies the scene/object pixels by non-zero values. This is generally the most important factor in obtaining the best pattern fit and removal. If the pattern is localized in the input data, such as might be the case with scattered light or pupil ghosts, then a pattern mask with zero values where the pattern is located and non-zero values elsewhere should be used. The two masks can be combined into one mask but there are parameters, \fImasks\fR and \fIpatmasks\fR, to specify both separately since the pattern mask may be a fixed mask for many images while the object scene varies from input data to input data. The masks specified by the \fImasks\fR and \fIpatmasks\fR parameters may be in any of the supported masks formats. As of IRAF V2.12 this includes pixel list (.pl) files and FITS "type=mask" extensions. When the input is a multiextension file, the selected extension names are appended to the mask filename to select masks with the same extension name. If a mask file of the form "name[ext]" is not found the task will treat the filename as a directory of pixel list files and select the filename corresponding to the extension name; i.e. "name/ext.pl". In addition to excluding non-pattern data with masks, the scale determined by equation 1 depends strongly on matching the data and pattern backgrounds. In particular the input image background and the pattern background must correspond to the same feature of the pattern. So if the mean of the pattern is used as the background then the input image background must correspond to the mean of the pattern in the data. If the pattern has a zero background outside the pattern and zero is specified for the pattern background then the data background must be that unaffected by the pattern in the data. In general, if one uses masks to isolate the regions of the pattern and to exclude scene objects then the mean backgrounds are appropriate. The exception to this is if the pattern is not localized and there is a background gradient in the input data which is not part of the pattern. In that case an input background image should be specified (though externally removing the gradient is also an option) which is is based on based on fitting the gradient including the pattern. The pattern background is the pattern mean value. The output of the task is defined by the parameter \fIouttype\fR. The choices are: .nf fit s * (P - Q) + B diff A - (s * (P - Q) + B) ratio A / (s * (P - Q) + B) flat A * B' / (s * (P - Q) + B) where B'= = A / (s' * (P - Q) + B/B') where s' = s / B' pfit s * (P - Q) pdiff A - (s * (P - Q)) pratio A / (s * (P - Q)) pflat A * B' / (s * (P - Q) + B') where B'= = A / (s' * (P - Q) + 1) where s' = s / B' sfit s * P sdiff A - (s * P) sratio A / (s * P) sflat A * B' / (s * P + B') where B'= = A / (s' * P + 1) where s' = s / B' none log output only .fi In addition, log output to the terminal is produced when \fIverbose\fR is "yes" and log output to a specified file is produced by setting \fIlogfile\fR. The output is the same for both. The EXAMPLE section shows the form of the log output. The task identification, PATFIT in the examples, is set by the \fIlogname\fR parameter. The ability to set the name is available for cases where this task is used in scripts. In the examples the mean values of the pattern and weight images are used and are indicated by the values and instead of filenames or constants. Because the means are not known until the computation completes, the values are given later in the output. The final lines of the log information describe the output images created. One less obvious piece of output is the "statwt" quantity. This can be used to combine scales measured for different images or extensions in the optimal statistical way. In other words, as if all the images had be measured together. One application to be fit the pieces of a mosaic independently (typically with \fIouttype\fR = none) and then a global scale is computed using the statwt values: .nf final scale = sum [statwt(i)*scale(i)] / sum [statwt(i)] .fi If an output image is created, the keyword specified by \fIlogname\fR is written with the output operation identifying the image names, scale factor, and background is added. An example is .nf PATFIT = 'o262 - 0.80696 (fringe - 0.15538)' .fi .ih EXAMPLES 1. Fringe removal from a single image, "o262". The fringe image, "fringe", is created by combining many exposures during the night to eliminate the objects. A smooth background, averaged on scales larger than the fringe pattern, is subtracted. Note that alternatively one could specify the fringe pattern background separately in \fBpatfit\fR. Because the fringing occurs everywhere in the image no pattern mask is used. The input image is processed to produce a mask, "objmask262", of the objects and bad pixels (see nproto.objmasks) and also a low frequency sky map, "sky262", to account for gradients in the background. .nf cl> patfit o262 fo262 fringe \ >>> background=sky262 masks=objmask262 outtype=pdiff PATFIT: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262 pattern = fringe weight = fringe input background = sky262 pattern background = weight background = input mask = objmask262 output = fo262 outtype = pdiff = 0.1554 = 0.1554 statwt = 41.2831 scale = 0.807 fo262 = o262 - 0.80696 (fringe - 0.15538) .fi 2. The same fringing example but with multiextension files. In this case the object mask may either be a multiextension file of mask type extensions (V2.12 and later) or a directory "objmask262" with files im1.pl, im2.pl, etc. .nf cl> patfit o262 fo262 fringe \ >>> background=sky262 masks=objmask262 outtype=pdiff PATFIT: NOAO/IRAF V2.11EXPORT ... 15-Jan-2002 input = o262 pattern = fringe weight = fringe input background = sky262 pattern background = weight background = input mask = objmask262 output = fo262 outtype = pdiff o262[im1]: 0.8127 o262[im2]: 0.8103 o262[im3]: 0.8235 o262[im4]: 0.8177 o262[im5]: 0.8161 o262[im6]: 0.8365 o262[im7]: 0.7584 o262[im8]: 0.7979 = 0.5208 = 0.5208 statwt = 21.0841 scale = 0.8095 fo262[im1] = o262[im1] - 0.80953 (fringe[im1]... fo262[im2] = o262[im2] - 0.80953 (fringe[im2]... fo262[im3] = o262[im3] - 0.80953 (fringe[im3]... fo262[im4] = o262[im4] - 0.80953 (fringe[im4]... fo262[im5] = o262[im5] - 0.80953 (fringe[im5]... fo262[im6] = o262[im6] - 0.80953 (fringe[im6]... fo262[im7] = o262[im7] - 0.80953 (fringe[im7]... fo262[im8] = o262[im8] - 0.80953 (fringe[im8]... .fi 3. The same fringing example with multiextension files with fitting and output extensions specified. This artificial example shows fitting one set of extensions and outputing a different set. A more likely situation would be fitting a subset of extensions (for speed) but outputing all the extensions. .nf cl> patfit o262 fo262 fringe background=sky262 \ >>> masks=objmask262 outtype=pdiff extfit=im[123] extout=im[456] PATFIT: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262 pattern = fringe weight = fringe input background = sky262 pattern background = weight background = input mask = objmask262 output = fo262 outtype = pdiff o262[im1]: 0.8127 o262[im2]: 0.8103 o262[im3]: 0.8235 = 0.1554 = 0.1554 statwt = 21.0841 scale = 0.8153 fo262[im4] = o262[im4] - 0.81534 (fringe[im4]... fo262[im5] = o262[im5] - 0.81534 (fringe[im5]... fo262[im6] = o262[im6] - 0.81534 (fringe[im6]... .fi 4. The same multextension fringing example treating the extensions as independent images. Note that in this case the mask is actually objmask262/im1.pl but is referenced as objmask262[im1] (the other form could also be used). .nf cl> dpar patfit patfit.input = "o262[im1],o262[im2],o262[im3]" patfit.output = "fo262[im1],fo262[im2,append],... patfit.pattern = "fringe[im1],fringe[im2],... patfit.weight = "" patfit.masks = "objmask262[im1],objmask262[im2],objmask262[im3]" patfit.patmasks = "" patfit.background = "" patfit.bkgpattern = "" patfit.bkgweight = "" patfit.ncblk = 1 patfit.nlblk = 1 patfit.extfit = "" patfit.extout = "" patfit.outtype = "pdiff" patfit.logname = "PATFIT" patfit.logfile = "logfile" patfit.verbose = yes patfit.mode = "ql" # EOF cl> patfit List of input images (o262[im1],o262[im2],o262[im3]): List of output images (fo262[im1],fo262[im2,append],... Pattern or list of patterns (fringe[im1],... PATFIT: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im1] pattern = fringe[im1] weight = fringe[im1] input background = pattern background = weight background = input mask = objmask262[im1] output = fo262[im1] outtype = pdiff = 7340. = 0.1587 = 0.1587 statwt = 21.0841 scale = 0.8088 fo262[im1] = o262[im1] - 0.80883 (fringe[im1]... PATFIT: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im2] pattern = fringe[im2] weight = fringe[im2] input background = pattern background = weight background = input mask = objmask262[im2] output = fo262[im2,append] outtype = pdiff = 7299. = -0.3147 = -0.3147 statwt = 21.0841 scale = 0.7948 fo262[im2,append] = o262[im2] - 0.79481 (fringe[im2]... PATFIT: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im3] pattern = fringe[im3] weight = fringe[im3] input background = pattern background = weight background = input mask = objmask262[im3] output = fo262[im3,append] outtype = pdiff = 7260. = 0.634 = 0.634 statwt = 21.0841 scale = 0.8185 fo262[im3,append] = o262[im3] - 0.81849 (fringe[im3]... .fi Note that in this case an output multiextension file is built from the individual outputs by using the "append" syntax of the FITS image kernel. .ih SEE ALSO nproto.objmasks, rmfringe, rmpupil .endhelp mscred-5.05-2018.07.09/doc/rmfringe.hlp000066400000000000000000000315311332166314300170540ustar00rootroot00000000000000.help rmfringe Jan02 mscred .ih NAME rmfringe -- remove fringing from single or multiextension data .ih PARAMETERS .ls input List of input images or multiextension files. .le .ls output List of corrected output images or multiextension files. If no list is specified then the input list is used, otherwise the output list must match the input list. If an input and output file are the same the output is created in a temporary file and the input is replaced after the output is completed. .le .ls fringe List of fringe images or multiextension files. The list must either match the input list or be a single file to be used for all the input files. The fringe pattern is assumed to have a flat mean background. This is usually zero though this task will determine and ignore any constant mean in the data. .le .ls masks List of masks identifying pixels to ignore in the input data. Pixels to ignore have non-zero mask values. An empty list applies no bad pixel mask, a single mask applies to all input data, and a list is matched with the input list. A mask is specified by a filename or by reference to a filename given by the value of a header keyword in the input image. A header keyword reference is made with the syntax "!" where is the desired keyword with case ignored. For multiextension files the masks may be either a multiextension file with matching extension names or a directory of pixel list files with the extension names as the filenames. .le .ls fringemasks List of masks identifying pixels to ignore in the fringe image. This mask is primarily intended to restrict the amplitude calculation to the region of the fringe pattern. Pixels to ignore have non-zero mask values. The same options for specifying the masks apply as for the \fImasks\fR parameter. Keyword references will sought in the fringe pattern image header. .le .ls background = "" List of backgrounds for the input data. If no list is given then the mean of the data, excluding masked pixels, is used for the background. The list may be either a single value which applies to all the input data or match the input list in number. The background may be specifed as an image or constant value. Images are linearly interpolated to the size of the data images if the sizes do not match. .le .ls ncblk = 5, nlblk = 5 Moving average block sizes for the input and fringe images. The block average size for columns and for lines are specified separately. .le .ls extfit = "" Extensions to use for fitting the fringe amplitude. A null string matches all extension names. Otherwise the parameter is a comma separated list of patterns which match the entire extension name. Thus, a list of extension names may be given or the pattern matching characters '?' for any character or [] for a set of characters. The set may include ranges in ascii order by using hyphens; i.e. 1-3 matches the characters 1, 2, and 3. All the selected extensions in the input files must also exist in the fringe and mask files. .le .ls logfile = "" Filename for appending log information. If no name is specified then no log is written. Note that there is no need to use "STDOUT" since the same information is written when the \fIverbose\fR parameter is set. .le .ls verbose = yes If set to yes, log information is written to the standard output. Note that this is the same information as written to the logfile specified by the \fIlogfile\fR parameter. .le .ih DESCRIPTION RMFRINGE determines the fringe amplitude that minimizes the weighted mean difference between an input image and a fringe image given in equation 1. The input images, specified by the \fIinput\fR parameter, may be individual images (which includes images selected from multiextension files as explicit image extensions) or multiextension files specified by a root filename. In the latter case the image extension names selected by the \fIextfit\fR parameter are used for computing a global fringe amplitude for all the extensions. The output of this task are fringe corrected images or multiextension files and log information with the computed fringe amplitude. When the input is a multiextension file the output is a multiextension file with all the same extensions. Note that all extensions are used for the output regardless of which extensions are selected for fitting. The fringe correction is "A - s * (F - )" where the quantities are defined below. The statistic used to compute the scale is .nf (1) <(((A - B) - s (F - )) (F - ))> = 0 .fi where .nf A Input image (\fIinput\fR parameter) B Input image background (\fIbackground\fR parameter) F Fringe image (\fIfringe\fR parameter) s Fringe amplitude scale factor .fi The solution of equation 1 is determined over all pimels in the image or extensions selected by the \fIextfit\fR parameter which are not flagged in the pixel mask specified by the \fImasks\fR parameter. For multiextension files equation 1 is also solved separately for each extension and estimates of the fringe scale are shown in the log output (see examples 2 and 3). However, the final fringe amplitude is not the average of these values but the solution over all pixels. To treat image extensions as independent images the various file lists must be explicit images rather than multiextension file rootnames (see example 4). The fitting defined by equation 1 is improved by smoothing when the data and fringe pattern include noise, such as occurs when it is derived from observational data. The images may be smoothed by a moving block average with block sizes specified by the parameters \fIncblk\fR and \fInlblk\fR. There are three types of backgrounds, B, which may be specified. An image, a constant, and the mean value. The image may be a fully sampled image of the same size as the image to which it applies or a smaller sampled image that is interpolated to match the size of the image. If there is a background gradient in the input data it is useful to supply a background image otherwise the mean may be used by specifying a null string, "". A key to obtaining the best match between the fringe and the input data is to use masks for the input and fringe pattern. The masks will identify bad data and the objects in the input image. The task \fBnproto.objmasks\fR is recommended for creating the object masks. The masks specified by the \fBmasks\fR parameter may be in any of the supported masks formats. As of IRAF V2.12 this includes pixel list (.pl) files and FITS "type=mask" extensions. When the input is a multiextension file, the selected extension names are appended to the mask filename to select masks with the same extension name. If a mask file of the form "name[ext]" is not found the task will treat the filename as a directory of pixel list files and select the filename corresponding to the extension name; i.e. "name/ext.pl". In addition to the fringe corrected image, log output to the terminal is produced when \fIverbose\fR is "yes" and log output to a specified file is produced by setting \fIlogfile\fR. The output is the same for both. Because this task is a simple script calling the task \fBpatfit\fR the log output contains some additional information not described here. See the help page for \fBpatfit\fR for details. The output image will also contain a record of the operation performed under the keyword RMFRINGE as in the following example. .nf RMFRINGE = 'o262 - 0.80696 (fringe - 0.15538)' .fi .ih EXAMPLES 1. Fringe removal from a single image, "o262". The fringe image, "fringe", is created by combining many exposures during the night to eliminate the objects. A smooth background, averaged on scales larger than the fringe pattern, is subtracted. The input image is processed to produce a mask, "objmask262", of the objects and bad pixels (see \fBnproto.objmasks\fR) and also a low frequency sky map to account for gradients in the background. .nf cl> rmfringe o262 fo262 fringe objmask262 background=sky262 RMFRINGE: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262 pattern = fringe weight = fringe input background = sky262 pattern background = weight background = input mask = objmask262 output = fo262 outtype = pdiff = 0.1554 = 0.1554 scale = 0.807 fo262 = o262 - 0.80696 (fringe - 0.15538) .fi 2. The same fringing example but with multiextension files. In this case the object mask may either be a multiextension file of mask type extensions (V2.12 and later) or a directory "objmask262" with files im1.pl, im2.pl, etc. .nf cl> rmfringe o262 fo262 fringe objmask262 background=sky262 RMFRINGE: NOAO/IRAF V2.11EXPORT ... 15-Jan-2002 input = o262 pattern = fringe weight = fringe input background = sky262 pattern background = weight background = input mask = objmask262 output = fo262 outtype = pdiff o262[im1]: 0.8127 o262[im2]: 0.8103 o262[im3]: 0.8235 o262[im4]: 0.8177 o262[im5]: 0.8161 o262[im6]: 0.8365 o262[im7]: 0.7584 o262[im8]: 0.7979 = 0.5208 = 0.5208 scale = 0.8095 fo262[im1] = o262[im1] - 0.80953 (fringe[im1]... fo262[im2] = o262[im2] - 0.80953 (fringe[im2]... fo262[im3] = o262[im3] - 0.80953 (fringe[im3]... fo262[im4] = o262[im4] - 0.80953 (fringe[im4]... fo262[im5] = o262[im5] - 0.80953 (fringe[im5]... fo262[im6] = o262[im6] - 0.80953 (fringe[im6]... fo262[im7] = o262[im7] - 0.80953 (fringe[im7]... fo262[im8] = o262[im8] - 0.80953 (fringe[im8]... .fi 3. The same fringing example with multiextension files with fitting extensions specified. This artificial example shows fitting one set of extensions and outputing a different set. A more likely situation would be fitting a subset of extensions (for speed) but outputing all the extensions. .nf cl> rmfringe o262 fo262 fringe objmask262 background=sky262 \ >>> extfit=im[123] RMFRINGE: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262 pattern = fringe weight = fringe input background = sky262 pattern background = weight background = input mask = objmask262 output = fo262 outtype = pdiff o262[im1]: 0.8127 o262[im2]: 0.8103 o262[im3]: 0.8235 = 0.1554 = 0.1554 scale = 0.8153 fo262[im4] = o262[im4] - 0.81534 (fringe[im4]... fo262[im5] = o262[im5] - 0.81534 (fringe[im5]... fo262[im6] = o262[im6] - 0.81534 (fringe[im6]... .fi 4. The same multextension fringing example treating the extensions as independent images. Note that in this case the mask is actually objmask262/im1.pl but is referenced as objmask262[im1] (the other form could also be used). .nf cl> dpar rmfringe rmfringe.input = "o262[im1],o262[im2],o262[im3]" rmfringe.output = "fo262[im1],fo262[im2,append],... rmfringe.fringe = "fringe[im1],fringe[im2],... rmfringe.masks = "objmask262[im1],objmask262[im2],objmask262[im3]" rmfringe.background = "" rmfringe.extfit = "" rmfringe.logfile = "logfile" rmfringe.verbose = yes rmfringe.mode = "ql" # EOF cl> rmfringe List of input images (o262[im1],o262[im2],o262[im3]): List of output corrected images (fo262[im1],fo262[im2,append],... Fringe or list of fringe patterns (fringe[im1],... List of object/bad data masks (objmask262[im1],... RMFRINGE: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im1] pattern = fringe[im1] weight = fringe[im1] input background = pattern background = weight background = input mask = objmask262[im1] output = fo262[im1] outtype = pdiff = 7340. = 0.1587 = 0.1587 scale = 0.8088 fo262[im1] = o262[im1] - 0.80883 (fringe[im1]... RMFRINGE: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im2] pattern = fringe[im2] weight = fringe[im2] input background = pattern background = weight background = input mask = objmask262[im2] output = fo262[im2,append] outtype = pdiff = 7299. = -0.3147 = -0.3147 scale = 0.7948 fo262[im2,append] = o262[im2] - 0.79481 (fringe[im2]... RMFRINGE: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im3] pattern = fringe[im3] weight = fringe[im3] input background = pattern background = weight background = input mask = objmask262[im3] output = fo262[im3,append] outtype = pdiff = 7260. = 0.634 = 0.634 scale = 0.8185 fo262[im3,append] = o262[im3] - 0.81849 (fringe[im3]... .fi Note that in this case an output multiextension file is built from the individual outputs by using the "append" syntax of the FITS image kernel. .ih SEE ALSO nproto.objmasks, patfit, rmpupil, irmfringe .endhelp mscred-5.05-2018.07.09/doc/rmpupil.hlp000066400000000000000000000311721332166314300167340ustar00rootroot00000000000000.help rmpupil Jan02 mscred .ih NAME rmpupil -- remove pupil pattern from single or multiextension data .ih PARAMETERS .ls input List of input images or multiextension files. .le .ls output List of corrected output images or multiextension files. If no list is specified then the input list is used, otherwise the output list must match the input list. If an input and output file are the same the output is created in a temporary file and the input is replaced after the output is completed. .le .ls pupil List of pupil images or multiextension files. The list must either match the input list or be a single file to be used for all the input files. The pupil pattern is assumed to have a zero background. .le .ls masks List of masks identifying pixels to ignore in the input data. Pixels to ignore have non-zero mask values. An empty list applies no bad pixel mask, a single mask applies to all input data, and a list is matched with the input list. A mask is specified by a filename or by reference to a filename given by the value of a header keyword in the input image. A header keyword reference is made with the syntax "!" where is the desired keyword with case ignored. For multiextension files the masks may be either a multiextension file with matching extension names or a directory of pixel list files with the extension names as the filenames. .le .ls pupilmasks List of masks identifying pixels to ignore in the pupil image. This mask is primarily intended to restrict the amplitude calculation to the region of the pupil pattern. Pixels to ignore have non-zero mask values. The same options for specifying the masks apply as for the \fImasks\fR parameter. Keyword references will sought in the pupil pattern image header. .le .ls outtype = "sdiff" (sdiff|sflat) Output type from the choices "sdiff" and "sflat". The first one scales and subtracts the pupil pattern and the second flattens the input by the pupil pattern. .le .ls ncblk = 5, nlblk = 5 Moving average block sizes for the input and pupil images. The block average size for columns and for lines are specified separately. .le .ls extfit = "im[2367]" Extensions to use for fitting the pupil amplitude. A null string matches all extension names. Otherwise the parameter is a comma separated list of patterns which match the entire extension name. Thus, a list of extension names may be given or the pattern matching characters '?' for any character or [] for a set of characters. The set may include ranges in ascii order by using hyphens; i.e. 1-3 matches the characters 1, 2, and 3. The default value is for the KPNO Mosaic at the Mayall telescope. All the selected extensions in the input files must also exist in the pupil and mask files. .le .ls logfile = "" Filename for appending log information. If no name is specified then no log is written. Note that there is no need to use "STDOUT" since the same information is written when the \fIverbose\fR parameter is set. .le .ls verbose = yes If set to yes, log information is written to the standard output. Note that this is the same information as written to the logfile specified by the \fIlogfile\fR parameter. .le .ih DESCRIPTION RMPUPIL determines the pupil amplitude that minimizes the weighted mean difference between an input image and a fringe image given in equation 1. The input images, specified by the \fIinput\fR parameter, may be individual images (which includes images selected from multiextension files as explicit image extensions) or multiextension files specified by a root filename. In the latter case the image extension names selected by the \fIextfit\fR parameter are used for computing a global pupil amplitude for all the extensions. The output of this task are pupil corrected images or multiextension files. When the input is a multiextension file the output is a multiextension file with all the same extensions. Note that all the extensions in the input are output regardless of which extensions are selected for fitting. The statistic used to compute the scale is .nf (1) <(((A - ) - s (P -

)) (P -

))> = 0 .fi where .nf A Input image (\fIinput\fR parameter) B Input image background (\fIbackground\fR parameter) P Pupil image (\fIpupil\fR parameter) s Pupil amplitude scale factor .fi The solution of equation 1 is determined over all pixels in the image or extensions selected by the \fIextfit\fR parameter which are not flagged in the pixel masks specified by the \fImasks\fR and \fIpupilmasks\fR parameters. For multiextension files equation 1 is also solved separately for each extension and estimates of the pupil amplitude are shown in the log output (see examples 2 and 3). However, the final pupil amplitude is not the average of these values but the solution over all pixels. To treat image extensions as independent images the various file lists must be explicit images rather than multiextension file rootnames (see example 3). The fitting defined by equation 1 is improved by smoothing when the data and pupil pattern include noise, such as occurs when it is derived from observational data. The images may be smoothed by a moving block average with block sizes specified by the parameters \fIncblk\fR and \fInlblk\fR. There are two types of output from the task selected by the \fIouttype\fR parameter. When the type is "sdiff" the output is "A - s * P". When the type is "sflat" the output is "A / (f * P + 1)" where .nf (2) f = s / b = s / ( - s *

) .fi The quantity b is an estimate of the background outside the pupil pattern. The derived quantities f and b are printed in the log output under the keywords "flatscale" and "flatbkg". While the observed pupil pattern is basically a scattered (additive) light effect it must be removed in a two step process when it also appears in the flat field data. In the first step the pattern is removed from the flat field data using the "sflat" option. This separates the underlying relative responses of the pixels. After this corrected flat field is applied to the object data the pupil pattern is then removed as additive light using the "sdiff" option. Generally the pupil pattern image is derived before each step. A pupil pattern is first derived from data which has not been flat fielded, in other words from the flat field data itself. Then, after the object data has been flat fielded by the corrected flat field, a new pupil pattern is extracted from a sky flat field produced from the flat fielded object data. A key to obtaining the best match between the pupil pattern and the input data is to use masks for the input and the pattern. The mask for the input data identifies bad data and objects in the input image. The task \fBnproto.objmasks\fR is recommended for creating the masks. When removing the pattern from flat field data the mask may be absent or identify regions where the flat field response significantly distorts the pattern, such as regions of very low or non-linear response or dust patterns. The pattern mask restricts the data used to determine the pupil amplitude to where the pupil pattern is located. The two masks can be combined into one mask but it may be easier to use two separate masks since the pattern mask will often be independent of the data or even the date of observation. The masks specified by the \fImasks\fR and \fIpupilmasks\fR parameters may be in any of the supported masks formats. As of IRAF V2.12 this includes pixel list (.pl) files and FITS "type=mask" extensions. When the input is a multiextension file, the selected extension names are appended to the mask filename to select masks with the same extension name. If a mask file of the form "name[ext]" is not found the task will treat the filename as a directory of pixel list files and select the filename corresponding to the extension name; i.e. "name/ext.pl". In addition to the pupil corrected image, log output to the terminal is produced when \fIverbose\fR is "yes" and log output to a specified file is produced by setting \fIlogfile\fR. The output is the same for both. Because this task is a simple script calling the task \fBpatfit\fR the log output contains some additional information not described here. See the help page for \fBpatfit\fR for details. The output image will also contain a record of the operation performed under the keyword RMPUPIL as in the following example. .nf RMPUPIL = 'o262 - 0.80696 pupil' .fi .ih EXAMPLES 1. Pupil removal from a single image, "o262". The input image is processed to produce a mask, "objmask262", of the objects and bad pixels (see \fBnproto.objmasks\fR). A pupil mask, "pupilmask", has been created at the same time as the pupil pattern image, "pupil". .nf cl> rmpupil o262 fo262 pupil objmask262 pupilmask=pupilmask RMPUPIL: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262 pattern = pupil weight = pupil ncblk = 5 nlblk = 5 input background = pattern background = weight background = input mask = objmask262 pattern mask = pupilmask output = fo262 outtype = sdiff = 7650. = 0.1554 = 0.1554 scale = 0.807 fo262 = o262 - 0.80696 pupil .fi 2. The same example but with multiextension files. In this case the object mask may either be a multiextension file of mask type extensions (V2.12 and later) or a directory "objmask262" with files im1.pl, im2.pl, etc. This shows fitting the pupil only in the set of extensions where parts of the pupil pattern are found and then creating an output with all the extensions. .nf cl> rmpupil o262 fo262 pupil objmask262 pupilmask=pupilmask RMPUPIL: NOAO/IRAF V2.11EXPORT ... 15-Jan-2002 input = o262 pattern = pupil weight = pupil ncblk = 5 nlblk = 5 input background = pattern background = weight background = input mask = objmask262 pattern mask = pupilmask output = fo262 outtype = sdiff o262[im2]: 0.8103 o262[im3]: 0.8235 o262[im6]: 0.8365 o262[im7]: 0.7584 = 7650. = 0.5208 = 0.5208 scale = 0.8095 fo262[im1] = o262[im1] - 0.80953 pupil[im1] fo262[im2] = o262[im2] - 0.80953 pupil[im2] fo262[im3] = o262[im3] - 0.80953 pupil[im3] fo262[im4] = o262[im4] - 0.80953 pupil[im4] fo262[im5] = o262[im5] - 0.80953 pupil[im5] fo262[im6] = o262[im6] - 0.80953 pupil[im6] fo262[im7] = o262[im7] - 0.80953 pupil[im7] fo262[im8] = o262[im8] - 0.80953 pupil[im8] .fi 3. The same multextension example treating the extensions as independent images. Note that in this case the mask is actually objmask262/im1.pl but is referenced as objmask262[im1] (the other form could also be used). .nf cl> dpar rmpupil rmpupil.input = "o262[im2],o262[im3],o262[im6],o262[im7]" rmpupil.output = "fo262[im2],fo262[im3,append],... rmpupil.pupil = "pupil[im2],pupil[im3],... rmpupil.masks = "objmask262[im2],objmask262[im3],... rmpupil.patternmasks = "pupilmask[im2],pupilmask[im3],... rmpupil.outtype = "sdiff" rmpupil.ncblk = 5 rmpupil.nlblk = 5 rmpupil.extfit = "" rmpupil.logfile = "logfile" rmpupil.verbose = yes rmpupil.mode = "ql" # EOF cl> rmpupil List of input images (o262[im2],o262[im3],... List of output corrected images (fo262[im2],fo262[im3,append],... Pupil or list of pupil patterns (pupil[im2],... List of object/bad data masks (objmask262[im2],... RMPUPIL: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im2] pattern = pupil[im2] weight = pupil[im2] ncblk = 5 nlblk = 5 input background = pattern background = weight background = input mask = objmask262[im2] pattern mask = pupilmask[im2] output = fo262[im2] outtype = sdiff = 7340. = 0.1587 = 0.1587 scale = 0.8088 fo262[im2] = o262[im2] - 0.80883 pupil[im2] RMPUPIL: NOAO/IRAF V2.11EXPORT ... 18-Jan-2002 input = o262[im3] pattern = pupil[im3] weight = pupil[im3] ncblk = 5 nlblk = 5 input background = pattern background = weight background = input mask = objmask262[im3] pattern mask = pupilmask[im3] output = fo262[im3,append] outtype = sdiff = 7299. = -0.3147 = -0.3147 scale = 0.7948 fo262[im3,append] = o262[im3] - 0.79481 pupil[im3] ... .fi Note that in this case an output multiextension file is built from the individual outputs by using the "append" syntax of the FITS image kernel. .ih SEE ALSO nproto.objmasks, patfit, rmfringe, irmpupil .endhelp mscred-5.05-2018.07.09/doc/wiynoptic.hlp000066400000000000000000000212671332166314300172750ustar00rootroot00000000000000.help wiynoptic Oct03 mscred .sp 3 .ce \fBUsing MSCRED with the WIYN/Optic Camera\fR .ce Francisco Valdes .ce October 2003: Version 0 .cl .sh 1. Introduction This guide describes how to convert the raw format from the Optic camera, on loan to WIYN, to a form which can be processed by the \fBmscred\fR package. Once the package setup and format issues are taken care of the reduction of WIYN/Optic data is essentially the same as the WIYN Minimosaic and other NOAO mosaic cameras. This is the first version of the guide and associated setup files provided with the \fBmscdb\fR database. It currently does not include bad pixel masks and WCS support. This may be added in future. The raw Optic data is in a "flat" format where the amplifier outputs from the two OTCCDs are pasted into a simple image raster in a way that allows a simple display to show the mosaic in an approximation of the sky. The overscan bias information is also pasted into the image format on the right edge. The MSCRED reduction package expects a "multiextension" FITS format (also referred to as MEF format) where each amplifier, with its overscan, are separate images in a multi-image FITS format. The package also makes use of certain keywords to allow automatic display and data reduction. So the additional steps required for Optic data are to transform the flat format to the MEF format and add keywords. There is also a step of customizing the task parameters for this particular data. The MSCRED package provides the tools for the transformations and task parameter customization. All that is needed are configuration files. These configuration files are provided through a standard database (file tree) called \fBmscdb\fR. NOAO supplies a database directory tree to support all its mosaic cameras. This database has been extended to support WIYN/Optic data. .sh 2. SETINSTRUMENT The configuration of MSCRED is performed by the task \fBsetinstrument\fR. The root of the database tree for NOAO data is specified by the logical variable "mscdb$". This variable is generally defined when the MSCRED is installed. .nf ms> path mscdb$ ursa!/shared/iraf/extern/mscdb/ .fi SETINSTRUMENT may be used with command line arguments or with query prompts. The following shows the most verbose form, querying without using the menus, and on the command line. .nf ms> setinst Site (? for menu): ? Sites: kpno Kitt Peak National Observatory ctio Cerro Tololo Inter-American Observatory Site (? for menu or q to quit): kpno Telescope (? for menu): ? Telescopes: 36inch 36inch/0.9m telescope 4meter Mayall 4meter telescope wiyn WIYN telescope Telescope (? for menu or q to quit): wiyn Instrument (? for a list): ? Instruments: minimosaic WIYN MiniMosaic wttm WIYN Tip-Tilt optic1 OPTIC full format (no guide regions) Instrument (? for menu or q to quit): optic1 ms> setinst Site (? for menu): kpno Telescope (? for menu): wiyn Instrument (? for a list): optic1 ms> setinst kpno wiyn optic1 .fi The other thing SETINST does is allow you to review the parameter settings for the MSCRED package and the CCDPROC task. You can turn the review off with the "review" parameter otherwise adjust parameters and exit EPAR as usual. Note that you only need to run SETINST once even if you logout and return later. If you run it again some parameters you may have changed during the session may be reset. The only times you need to run SETINST is when you are switching between cameras. Also note that SETINST is just a script and you can manually set the "mscred.instrument" and "mkmsc.description" parameters manually to the files provided in \fBmscdb\fR: .nf mscred.instrument = "mscdb$noao/kpno/wiyn/optic1.dat" mscred.description = "mscdb$noao/kpno/wiyn/Optic/optic1.mkmsc" .fi .sh 3. MKMSC One of the primary things SETINST does is set a configuration file for the task \fBmkmsc\fR. This is the task that converts the raw Optic flat format to a raw MEF format for MSCRED. It does this with a configuration file that identifies the extensions to be created, the regions of the flat image for each extension, and other keyowrds. You can read about this task with the IRAF help topic "mkmsc". The configuration file for the full format is shown below. .nf # MKMSC description file for a basic OPTIC exposure. imageid(ccd0) 1 datasec(ccd0) [1:2048,1:2052] trimsec(ccd0) [1:2048,1:2052] biassec(ccd0) [4097:4128,1:2052] ccdsec(ccd0) [1:2048,1:2052] detsec(ccd0) [1:2048,1:2052] ccdname(ccd0) "CCD1" ampname(ccd0) "AMP1" rdnoise(ccd0) 4. gain(ccd0) !CCD0GAIN optfilt(ccd0) !FILTER filter(ccd0) !TELFILT dtv1(ccd0) 0. dtv2(ccd0) 0. dtm1_1(ccd0) 1. dtm2_2(ccd0) 1. imageid(ccd1) 2 datasec(ccd1) [1:2048,2053:4104] trimsec(ccd1) [1:2048,2053:4104] biassec(ccd1) [4097:4128,2053:4104] ccdsec(ccd1) [1:2048,2053:4104] detsec(ccd1) [1:2048,2053:4104] ccdname(ccd1) "CCD1" ampname(ccd1) "AMP2" rdnoise(ccd1) 4. gain(ccd1) !CCD1GAIN optfilt(ccd1) !FILTER filter(ccd1) !TELFILT dtv1(ccd1) 0. dtv2(ccd1) 0. dtm1_1(ccd1) 1. dtm2_2(ccd1) 1. imageid(ccd2) 3 datasec(ccd2) [2049:4096,1:2052] trimsec(ccd2) [2049:4096,1:2052] biassec(ccd2) [4129:4160,1:2052] ccdsec(ccd2) [1:2048,1:2052] detsec(ccd2) [2049:4096,1:2052] ccdname(ccd2) "CCD2" ampname(ccd2) "AMP1" rdnoise(ccd2) 4. gain(ccd2) !CCD2GAIN optfilt(ccd2) !FILTER filter(ccd2) !TELFILT dtv1(ccd2) 2048. dtv2(ccd2) 0. dtm1_1(ccd2) 1. dtm2_2(ccd2) 1. imageid(ccd3) 4 datasec(ccd3) [2049:4096,2053:4104] trimsec(ccd3) [2049:4096,2053:4104] biassec(ccd3) [4129:4160,2053:4104] ccdsec(ccd3) [1:2048,2053:4104] detsec(ccd3) [2049:4096,2053:4104] ccdname(ccd3) "CCD2" ampname(ccd3) "AMP2" rdnoise(ccd3) 4. gain(ccd3) !CCD3GAIN optfilt(ccd3) !FILTER filter(ccd3) !TELFILT dtv1(ccd3) 2048. dtv2(ccd3) 0. dtm1_1(ccd3) 1. dtm2_2(ccd3) 1. .fi Note that you can copy this file to your working area and modify it. For instance if you would rather use the extension names "im1", "im2", etc. rather than "ccd0", "ccd1", etc. you can do so. (Note you would also need to reset the parameter "ccdlist.extension".) The MKMSC task can be used to create new MEF files or to transform and replace your flat format files. I suggest that you test this on one file to a new output. When you are satisfied it is working correctly I would simply transform all the data in-place. The following two examples shows creating new MEF files for all fits files in your directory and also doing an in-place transformation. .nf ms> mkmsc *.fits mef//*.fits # New files prefixed with mef ms> mkmsc *.fits "" # Replace flat format with mef .fi The verbose option allows you to monitor the progress and also illustrates the copying of sections from the flat file to extensions in the MEF file. The two lines are for the data section and the overscan bias section. .nf ms> mkmsc obj052 "" Reading description file mscdb$noao/kpno/wiyn/Optic/optic1.mkmsc Create obj052[ccd0][2080,2052]: obj052[1:2048,1,2052] -> obj052[ccd0][1:2048,1:2052] obj052[4097:4128,1,2052] -> obj052[ccd0][2049:2080,1:2052] Create obj052[ccd1][2080,2052]: obj052[1:2048,2053,4104] -> obj052[ccd1][1:2048,1:2052] obj052[4097:4128,2053,4104] -> obj052[ccd1][2049:2080,1:2052] Create obj052[ccd2][2080,2052]: obj052[2049:4096,1,2052] -> obj052[ccd2][1:2048,1:2052] obj052[4129:4160,1,2052] -> obj052[ccd2][2049:2080,1:2052] Create obj052[ccd3][2080,2044]: obj052[2049:4096,2053,4096] -> obj052[ccd3][1:2048,1:2044] obj052[4129:4160,2053,4096] -> obj052[ccd3][2049:2080,1:2044] .fi After converting one or more files the first thing you are likely to do is use \fBmscdisplay\fR to display the data. Obviously, it should display correctly if everything worked properly. Note that the gap between the two CCDs is set by the parameter "mimpars.xgap" and is not inherently in the data header. The actual physical gap is not produced until the mosaic is reconstructed into a single image using a calibrated world coordinate solution. .nf ms> mscdisplay obj052 1 xgap=104 .fi .sh 4. Data Reductions After producing the MEF format and configuring MSCRED package the reductions proceed as described from other mosaic instruments. You will be able to combine calibrations, use \fBccdproc\fR, etc. A quick initial test that the keywords and translations are reasonable is the task \fBccdlist\fR: .nf ms> ccdlist *fits adflat152.fits[ccd0][2048,4104][real][dflat][1][V][OTZ]: aobj052.fits[ccd0][2048,4104][real][object][1][V][OTZF]: azero141.fits[ccd0][2048,4104][real][zero][1][B][OT]: obj051.fits[ccd0][2080,2052][ushort][object][1][V]: .fi The first one is from an unprocessed exposure and the others have been processed by CCDPROC. .endhelp mscred-5.05-2018.07.09/doc/xtalkcor.hlp000066400000000000000000000274701332166314300171010ustar00rootroot00000000000000.help xtalkcor Nov10 mscred .ih NAME xtalkcor -- apply crosstalk corrections to mosaic exposures. .ih SYNOPSIS XTALKCOR reads a file containing coefficients for a simple crosstalk interaction between extensions in a mosaic exposure and applies the correction. The correction takes the form .nf corrected = victim - (scale1 * source1 + scale2 * source2 + ...) .fi where the arithmetic is done on each pixel in the victim image extension with the matching pixels in the source image extensions and the scales are numerical coefficients. Alternatively or in addition, bad pixel masks may be generated flagging pixels which have corrections greater than a specified threshold or which have source pixels greater than a theshold. This task may be executed as part of \fBccdproc\fR. .ih USAGE xtalkcor input output bpmasks xtalkfiles .ih PARAMETERS .ls input List of input mosaic exposures to be corrected. Mosaic files in which the the extensions contain the keyword XTALKCOR, indicating file has been previously corrected, are silently skipped. .le .ls output List of output corrected mosaic exposures. If an empty list is specified then no output correction is produced otherwise the output list must match the input list. When \fIsplit\fR=no the output is a corrected multiextension file. If \fIsplit\fR=yes each extension in the input will be corrected to a separate single image file using the output name as the rootname and appending the extension name preceded by "_". .le .ls bpmasks List of output bad pixel masks. The same rules apply as for the \fIoutput\fR parameter except currently splitting is implied since a multiextension format is not produced. .le .ls xtalkfiles = "" List of crosstalk coefficient files or header keywords containing the file name. A header keyword reference is specified by preceding the keyword with '!'. Note that only the first extension of the input file is used to resolve the keyword reference. The list may consist of a single crosstalk file reference, in which case it applies to all the elements of the input list, of a list which matches the input list in number. The format of the file has three as explained in the DESCRIPTION section. This is the same format produced by the \fBxtcoeff\fR task. .le .ls section = "!datasec" Section value or keyword to a section value, as indicated by a leading '!', selecting the part of the image to be corrected. If no value is specified or the keyword doesn't exist then the whole image is used. This parameter is primarily needed if overscan regions to not match after flipping the data into amplifier readout order. .le .ls bpmthreshold = -10. Threshold for identifying pixels in the output bad pixel masks. A positive value flags pixels where any of the contributing source pixels exceeds the specified threshold. A negative value flags pixels where the absolute value of the correction exceeds the absolute value of the threshold. .le .ls split = no Output the corrected extension images as separate single images. Since the procedure produces single images as part of the operation this option saves the time needed to rebuild a final multiextension file. .le .ls fextn = "fits" File extension for the input and output exposure files. .le .ls noproc = no Do no processing but simply print whether the operation is to be done or not based on the presence of an XTALKCOR header keyword? This is intended for use when this task is executed as part of \fBccdproc\fR. .le The following package parameters are also used. .ls pixeltype The output pixel type for the corrected exposures. .le .ls logfile Log file to record the operations. .le .ls verbose Print processing information to the terminal. .le .ls im_bufsize File buffering size in megabytes per read or write operation. .le .ih DESCRIPTION \fBXtalkcor\fR reads a file containing coefficients for a simple crosstalk interaction between extensions in a mosaic exposure and creates a corrected copy of the input images and/or a bad pixel mask identifying pixels affected by crosstalk. The corrected images may be in a extension file or separate images depending on the \fIsplit\fR parameter. Pixel masks are always separate files in the current version. The output names may be specified as rootnames or as a full list for every output file. The crosstalk correction takes the form .nf corrected = victim - (scale1 * source1 + scale2 * source2 + ...) .fi where the arithmetic is done on each pixel in the victim image extension with the matching pixels in the source image extensions and the scales are numerical coefficients. Bad pixel masks may be generated by flagging pixels which have corrections greater than a specified threshold or which have source pixels greater than a theshold. This task may be executed as part of \fBccdproc\fR. The crosstalk occurs during the simultaneous readout of multiple amplifiers. Thus the victim and source pixels must be matched in "amplifier coordinates". This version assumes the extensions are matched by flips of lines or columns. The flips are identified by the signs of the keywords ATM1_1 for line flips and ATM2_2 for column flips. If the data contain regions, such as overscan regions, which are recorded in such a way that after flipping the data into matching amplifier order the data do not correctly match then the section keyword must be used. The common case is where data is recorded with the overscan in the same location in the image extensions though the data sections have been flipped. The crosstalk coefficient file is specified either explicitly or by reference to a header keyword containing the name of the file. To reference a keyword precede the keyword name with '!'. Note the only the first extension is used to find the referenced keyword. A crosstalk file consists of lines .nf victim source scale .fi where "victim" is an extension name for the victim image to be corrected, "source" is the extension name for a source image, and scale is the scale coefficient. When more than one source extension affects a victim extension there will be multiple lines. Any lines where the first three fields are not in this format are ignored. Also any line beginning with '#' is treated as a comment and ignored. This format is generated by the task \fBxtcoeff\fR though it can be created or modified with any text editor as well. Examples are given in the EXAMPLE section. The crosstalk corrected output images will contain the keyword XTALKCOR giving the time the correction was applied and the source extensions and coefficients used. Any extension in the input image which does not have an entry in the crosstalk file will be copied to the crosstalk corrected image without change. It will also contain the XTALKCOR keyword with the time followed by an indication that no crosstalk correction was required. In addtion to the XTALKCOR keyword, the keyword XTALKFILE is added giving the name of the crosstalk file used. A bad pixel mask is created when a file name or names is specified for the \fBbpmasks\fR parameter. Currently if only a rootname is specified separate pixel list files are produced with the extension appended; i.e. a filename of the form root_extension.pl will be produced. The crosstalk affected pixels for each victim extension are flagged either by the magnitude of the correction or by source pixel values exceeding a positive threshold. The \fIbpmthreshold\fR parameter specifies the threshold and the type of flagging. A positive value will flag any victim pixel in which any of the source pixels exceed the threshold. Note that only one source exceeding the threshold is needed in the case where there are multiple sources. A negative value of the threshold parameter compares the magnitude of the correction (computed even if no output corrected file is generated) to the absolute value of the specified threshold. Note that the bad pixel mask is not merged with to any other bad pixel mask nor is the name added to the header. This must be done separately if desired. .ih KEYWORDS .ls XTALKCOR Added to all extensions in an output crosstalk corrected file. The value includes a time stamp and the crosstalk coefficients and extensions. If this keyword is present (the value is ignored) in the input file then the file will be silently skipped by the task. To force a second round of correction would require this keyword to be manually deleted. .le .ls XTALKFILE Added to all extensions in an output crosstalk corrected file. The value is the crosstalk file used. .le .ls ATM1_1, ATM2_2 The sign of these keywords define the amplifier readout direction. .le .ih EXAMPLES 1. A crosstalk coeffient file created by \fBxtcoeff\fR is shown below. .nf ms> page xtalk.dat # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:15:45 18-Aug-2000 # Images: obj110 im1 im2 0.001546 (0.000010, 153.7) im2 im1 0.000426 (0.000006, 75.1) im3 im4 0.001613 (0.000091, 17.8) im4 im3 0.001672 (0.000014, 116.4) im5 im6 im5 0.001382 (0.000016, 86.1) im7 im8 0.000244 (0.000022, 11.2) im8 im7 0.001696 (0.000011, 161.1) .fi Note that the comments and the parts in paraenthesis will be ignored. This will cause the following operations to be performed. 2. The above crosstalk correction is applied with the following command. .nf ms> xtalkcor obj110 xtcor110 xtalkfile=xtalk.dat obj110[im1]: Aug 22 10:05 Crosstalk is 0.00155*im2 obj110[im2]: Aug 22 10:05 Crosstalk is 4.26E-4*im1 obj110[im3]: Aug 22 10:06 Crosstalk is 0.00161*im4 obj110[im4]: Aug 22 10:06 Crosstalk is 0.00167*im3 obj110[im5]: Aug 22 10:07 No crosstalk correction required obj110[im6]: Aug 22 10:07 Crosstalk is 0.00138*im5 obj110[im7]: Aug 22 10:08 Crosstalk is 2.44E-4*im8 obj110[im8]: Aug 22 10:08 Crosstalk is 0.0017*im7 .fi 3. The header information added by the previous example can be examined with the following commands. .nf ms> imhead xtcor110[im1] l+ |match XTALKCOR XTALKCOR= 'Aug 22 10:05 Crosstalk is 0.00155*im2' ms> msccmd "hselect $input xtalkcor yes" xtcor110 "Aug 22 10:05 Crosstalk is 0.00155*im2" "Aug 22 10:05 Crosstalk is 4.26E-4*im1" "Aug 22 10:06 Crosstalk is 0.00161*im4" "Aug 22 10:06 Crosstalk is 0.00167*im3" "Aug 22 10:07 No crosstalk correction required" "Aug 22 10:07 Crosstalk is 0.00138*im5" "Aug 22 10:08 Crosstalk is 2.44E-4*im8" "Aug 22 10:08 Crosstalk is 0.0017*im7" .fi Attempting to apply the crosstalk correction again will do nothing because of the presence of the XTALKCOR keywords. 4. To execute a correction using a header keyword giving the coefficient file use the following modification to example 2. .nf ms> xtalkcor obj110 xtcor110 xtalkfile=!xtalkfil .fi 5. An example of a crosstalk file where there are multiple sources is shown below. .nf ms> page xtalk.dat # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:15:45 18-Aug-2000 # Images: obj110 im1 im2 0.001546 (0.000010, 153.7) im1 im3 0.000426 (0.000006, 75.1) im1 im4 0.001613 (0.000091, 17.8) im2 im1 0.001672 (0.000014, 116.4) im2 im3 0.001382 (0.000016, 86.1) im2 im4 0.000244 (0.000022, 11.2) ... .fi The correction output would then show .nf obj614[im1]: Jan 5 9:31 Crosstalk is 0.001546*im2+0.000426*im3+0.001613*im4 obj614[im2]: Jan 5 9:31 Crosstalk is 0.001672*im1+0.001382*im3+0.000244*im4 ... .fi .ih REVISIONS .ls XTALKCOR - V5.0: November 16, 2010 The ability to use a section to restrict the correction to a part of the input image was added. This was needed for data where overscan regions do not match after flipping the data into amplifier readout order. .le .ls XTALKCOR - V4.1: January 6, 2001 Extension changes to support readouts with multiple amplifiers. The script version was replaced by a compiled task which efficiently deals with multiple sources and with different amplifier readout directions. The new version supports creation of output bad pixel masks. .le .ls XTALKCOR - V3.2: August 27, 1999 The crosstalk file can be specified through a keyword. .le .ls XTALKCOR - V3.0: April 1999 First release. .le .ih SEE ALSO xtcoeff, ccdproc .endhelp mscred-5.05-2018.07.09/doc/xtcoeff.hlp000066400000000000000000000441701332166314300167040ustar00rootroot00000000000000.help xtcoeff Aug00 mscred .ih NAME xtcoeff -- compute crosstalk coefficients .ih SYNOPSIS Crosstalk coefficients between pairs of source and victim CCDs, specified as extensions in an MEF file, are computed. The output is a file suitable for use with XTALKCOR or CCDPROC. There is an option to examine and interact with the data. .ih USAGE xtcoeff input output victim source .ih PARAMETERS .ls input List of mosaic exposures in multiextension format (MEF). The crosstalk coefficient for a pair of extensions is computed combining all the input exposures. .le .ls output Optional output crosstalk file. The format of this file is that used by \fBxtalkcor\fR or \fBccdproc\fR provided each victim extension is specified once and only once (and generally in the same order as in the input MEF file). One may include more than one source extension for each victim extension. If the \fIverbose\fR option is set the same information in the crosstalk file will also be written to the terminal. .le .ls victim = "im1,im2,im3,im4,im5,im6,im7,im8" List of victim extension names in the MEF input files. This list is matched with the list of source extension names specified by the \fIsource\fR parameter. A crosstalk coefficient will be measured for each extension specified in the list. The same extension may be specified more than once to compare with source extensions that should not contribute to the crosstalk. Large lists may be specified with an @file. If the specified @file is not found in the current directory it is sought in xtcoeff$. Use "page xtcoeff$README" for available lists. .le .ls source = "im2,im1,im4,im3,im6,im5,im8,im7" List of source extension names in the MEF input files. This list is matched with the list of victim extension names specified by the \fIvictim\fR parameter. The same extension may be specified more than once. Large lists may be specified with an @file. If the specified @file is not found in the current directory it is sought in xtcoeff$. Use "page xtcoeff$README" for available lists. .le .ls vbkg = "", sbkg = "" List of victim and source backgrounds. If not specified then a simple percentile background for each line is used. The values may be full images, "maps" which are reduced scale images typically produced by \fBace\fR or \fBobjmasks\fR, or constants. The image/map files must have the same extensions as in the input data. Note that if one file contains the backgrounds for all the extensions then the victim and source background files may be the same. A good victim background is important while the default percentile source background is normally adequate. .le .ls masks = "" List of object masks for each input image. Typically this will be produced by a task like \fBobjmasks\fR. The masks must have extensions matching the victim extensions. .le .ls smin = 20000, smax = INDEF Range of pixel values in the source extension that are used in measuring the crosstalk. These values should be those which cause a crosstalk visible above the background in the victim extension. Typically these will be values near and above saturation. The number of pixels considered has an impact on the computation speed and memory so the values should also be such as to select only a small percent of the data in the source extension. A value of INDEF for the maximum selects all source pixels above the minimum value. The minimum value should be explicitly specified but a value of INDEF defaults to 10000. .le .ls medfactor = 0.5 Median factor for defining the backgrounds when background images/maps/constants are not specified. The background for each pair of source and victim pixels is computed by taking the Nth brightest pixel in the same line. N is computed as the \fImedfactor\fR parameter times the number of pixels in the line. A value of 0.5 selects the standard median (half the pixel values are above and half below). This factor may be adjusted from 0.5 to account for biases from objects by considering pairs of extensions where no crosstalk is expected and adjusting this factor to make the crosstalk coefficients scatter around zero. .le .ls maxcoeff = 0.01 A coefficient estimate is computed for each pair of source and victim pixels as (victim-background)/source. To reject victim pixels which have contaminating objects other than the crosstalk ghosts at that position, all estimates above this value are rejected immediately. Note that computation of the final coefficient from all the individual estimates uses iterative rejection. However, grossly invalid values will adversely affect the iterative rejection. This parameter value need only be set approximately. .le .ls niterate = 3, low = 3., high = 3. The number of rejection fitting iterations and the lower and upper sigma thresholds used when combining the individual pixel coefficient estimates into a final estimate. These parameters are from \fBicfit\fR. .le .ls interactive = no The determination of a single coefficient from all the estimates of the individual pixels consists of fitting a constant function (effectively an average) with iterative rejection. When this parameter is yes the pixel coefficient estimates are plotted against the source pixel values and the \fBicfit\fR interactive fitting routine is entered. This allows interactive examination of the data, rejection of points, and selection of sample regions. When this parameter is no the same fitting routine is used in non-interactive mode. .le .ls verbose = yes Print the measurement results to the terminal? .le .ls clobber This is a query parameter which is typically not set before hand. It is used only when the specified output crosstalk file already exists. If it is not specified on the command line then a query will occur if the output crosstalk file exists. To avoid a query and force a specific action specify the parameter on the command line. .le .ih DESCRIPTION XTCOEFF measures crosstalk coefficients relating the signals from pairs of extensions in multiextension format (typically pairs of CCDs in raw mosaic exposures). The coefficient is defined by the relation .nf <(V - V_b) / (S - S_b)> .fi where V is the victim image, V_b is the background in the victim image, S is the source image, and S_b is the background in the source image. The average is computed over the source pixels between \fIsmin\fR and \fIsmax\fR and the victim pixels not in an object \fImask\fR (if one is specified). The pairs of extensions are specified by the parameters \fIvictim\fR and \fIsource\fR. The lists may be comma separate extension names (note that extension positions may also be used) or an @file. When the \fBmscred\fR package is loaded the logical directory xtcoeff$ is defined. This may be reset by the user if desired. If a specified @file is not found the directory prefix xtcoeff$ is added. This allows using a library of @files without having to use the directory path. To check the contents use .nf ms> dir xtcoeff ms> page xtcoeff$README .fi The second command depends on there being a descriptive file in the directory. Each combination of extension names is applied to the \fIinput\fR, \fIvbkg\fR, \fIsbkg\fR, and \fImasks\fR files. The last three are optional. the victim and source backgrounds may be in the same multiextension file. The object masks, if specified, will also usually be multiextension files of "pixel mask" extensions. The backgrounds and object masks are typically produced by the task \fBobjmasks\fR. The coefficient for a particular pair of extensions is estimated by collecting measurements of .nf (V - V_b) / (S - S_b) .fi for all source values within the range specified by \fIsmin\fR and \fIsmax\fR and victim values not in the object mask (if specified). Contaminating objects in the victim are also roughly excluded by requiring that a measurement by below the value specified by \fImaxcoeff\fR. An iterative rejection of outliers also minimizes the effects of contaminating objects. If no background file or constant is specified by the \fIvbkg\fR or \fIsbkg\R parameters a background estimate is computed for each line by taking the Nth brightest value. N is computed by taking the specified \fImedfactor\fR value times the number of pixels in the line. A value of 0.5 for the factor is the classical median but the value may be adjusted to compensate for biases from objects. This can be done by using source extensions which are known not to contribute crosstalk and running this task with adjustments to the factor until the coefficient values are zero within the uncertainties of the calculation. A good victim background is very important in computing the crosstalk coefficients. Therefore, it is strongly recommended that a background be determined externally. The source background is not very critical and the line median is adequate, though computing a background normally is done over all extensions so a source background will generally be available if the victim background is determined. The set of coefficients from individual pairs of pixels are combined into a single coefficient estimate by fitting a constant to the coefficients verses the source pixel value. This is equivalent to computing the average. However, a fitting algorithm is used to allow examining the data graphically to check for trends away from the assumed crosstalk relation given earlier. The fitting approach also allows using the standard ICFIT routines for examining the data interactively if the \fIinteractive\fR parameter is set. During interactive fitting, points may be explicitly deleted and sample regions in the source intensity axes may be defined. The fitting, both interactive and non-interactive, includes iterative rejection of outlyers. The iterative rejection is is controled by the parameters \fIniterate\fR, \fIlow\fR, and \fIhigh\fR which are the number of iterations and the sigma clipping factors. The output of this program includes a banner with the input used and a table with the victim extension, the source extension, the estimated coefficient value, the estimated uncertainty in the coefficient, and the number of sigma from zero (the absolute value of the ratio of the coefficient and the uncertainty). The latter two values are in parentheses and will be ignored by the calibration tasks that uses the crosstalk file. The output is may be written to a specified file, if one is given with the \fIoutput\fR parameter, and to the terminal, if the \fIverbose\fR parameter is set to yes. If the specified file exists you are given the option to clobber the file or exit the program. The output is in a format which may be used by the calibration tasks \fIxtalkcor\fR or \fIccdproc\fR. Normally CCDPROC is used and it calls XTALKCOR if the correction is selected and it has not been done yet. It is applied before any other calibration. Note that the crosstalk calibration file must consist of each extension in the MEF file given only once and in the order in the file. The second column is the extension to be scaled and subtracted, followed by the crosstalk coefficient. If only the input extension is given it will be copied to the output calibrated exposure without a crosstalk correction. See the help for \fBxtalkcor\fR for more. .ih EXAMPLES The following examples use some data (not taken specifically for this purpose) from the NOAO Mosaic2 camera. Pairs of CCDs are controlled by a single box of electronics. Unfortunately there is crosstalk from those pairs in this data. One would probably want to have several exposures to combine and then the list of exposures would include them all. There are some standard extension lists in the xtcoeff$ logical directory. .nf ms> show xtcoeff mscred$lib/xtcoeff/ ms> dir xtcoeff README snoao16ref snoao8ref vnoao16ref vnoao8ref snoao16 snoao8 vnoao16 vnoao8 ms> type xtcoeff$README This directory contains extension lists for use with the XTCOEFF task. The lists are paired with the 'v' files being for the victim and the 's' files being for the source. vnoao8/snoao8 NOAO Mosaics with 8 amplifiers All pairs sharing the same Arcon box vnoao8ref/snoao8ref NOAO Mosaics with 8 amplifiers All pairs not sharing the same Arcon box vnoao16/snoao16 NOAO Mosaics with 16 amplifiers All pairs sharing the same Arcon box vnoao16ref/snoao16ref NOAO Mosaics with 16 amplifiers All pairs not sharing the same Arcon box .fi 1. Check coefficients when there is no crosstalk by pairing the extensions where no crosstalk is expected. The @files used in this example contain all combinations which are not expected to have crosstalk. The @files are just the two columns of extensions shown in the output. No output crosstalk file is specified. .nf ms> xtcoeff List of mosaic exposures: obj110 Output crosstalk file: List of victim extensions (im1,im2,im3,im4,im5,im6,im7,im8): @vnoao8ref List of source extensions (im2,im1,im4,im3,im6,im5,im8,im7): @snoao8ref # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:06:12 18-Aug-2000 # Images: obj110 im1 im3 -0.000007 (0.000010, 0.6) im1 im4 0.001422 (0.000295, 4.8) im1 im5 -0.000014 (0.000014, 1.0) im1 im6 0.000017 (0.000013, 1.3) im1 im7 0.000031 (0.000012, 2.5) im1 im8 0.000006 (0.000018, 0.4) im2 im3 -0.000014 (0.000010, 1.4) im2 im4 0.000128 (0.000072, 1.8) im2 im5 -0.000010 (0.000015, 0.7) im2 im6 0.000008 (0.000012, 0.6) im2 im7 -0.000005 (0.000013, 0.4) im2 im8 0.000026 (0.000020, 1.4) im3 im1 0.000005 (0.000006, 0.8) im3 im2 0.000065 (0.000013, 5.1) im3 im5 0.000085 (0.000015, 5.6) im3 im6 -0.000041 (0.000015, 2.7) im3 im7 0.000136 (0.000015, 9.1) im3 im8 0.000013 (0.000022, 0.6) im4 im1 0.000008 (0.000006, 1.3) im4 im2 0.000013 (0.000013, 1.0) im4 im5 0.000048 (0.000014, 3.4) im4 im6 -0.000018 (0.000018, 1.0) im4 im7 0.000036 (0.000013, 2.7) im4 im8 -0.000018 (0.000021, 0.9) im5 im1 0.000012 (0.000005, 2.2) im5 im2 0.000019 (0.000011, 1.8) im5 im3 0.000007 (0.000011, 0.6) im5 im4 0.002339 (0.000709, 3.3) im5 im7 -0.000006 (0.000010, 0.5) im5 im8 0.000027 (0.000020, 1.3) im6 im1 -0.000020 (0.000006, 3.1) im6 im2 -0.000023 (0.000013, 1.8) im6 im3 0.000015 (0.000013, 1.2) im6 im4 0.000038 (0.000057, 0.7) im6 im7 -0.000014 (0.000014, 1.0) im6 im8 0.000024 (0.000024, 1.0) im7 im1 0.000000 (0.000006, 0.1) im7 im2 0.000005 (0.000014, 0.4) im7 im3 0.000008 (0.000012, 0.7) im7 im4 -0.000017 (0.000064, 0.3) im7 im5 0.000023 (0.000014, 1.7) im7 im6 -0.000015 (0.000012, 1.2) im8 im1 -0.000002 (0.000005, 0.4) im8 im2 -0.000020 (0.000012, 1.7) im8 im3 -0.000030 (0.000011, 2.7) im8 im4 -0.000030 (0.000057, 0.5) im8 im5 0.000002 (0.000014, 0.2) im8 im6 -0.000022 (0.000014, 1.5) .fi 2. In the above example we want to examine the 9.9 sigma case interactively. .nf ms> xtcoeff interactive+ List of mosaic exposures (obj110): Output crosstalk file (xtalk.dat): "" List of victim extensions (@vnoao8ref): im3 List of source extensions (@snoao8ref): im7 # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:21:55 18-Aug-2000 # Images: obj110 .fi An ICFIT graph is shown. It is likely most of the power is coming from one saturated source star where the victim has a faint object. Set a sample region (with the 's' key) to exclude the clump of points at high source values and refit with 'f'. The fit is still above zero but with high scatter. Finish with 'q'. .nf im3 im7 0.000104 (0.000031, 3.4) .fi The 3.4 sigma is probably not significant compared to the real crosstalk shown in the next example. 3. Now pair the extensions where crosstalk is expected and record the results to a crosstalk file. The xtalk.dat file already exists so this example illustrates the clobber parameter. .nf ms> unlearn xtcoeff ms> xtcoeff List of mosaic exposures: obj110 Output crosstalk file: xtalk.dat List of victim extensions (im1,im2,im3,im4,im5,im6,im7,im8): @vnoao8 List of source extensions (im2,im1,im4,im3,im6,im5,im8,im7): @snoao8 Warning: Operation would overwrite existing file (xtalk.dat) Clobber existing crosstalk file? (no): yes # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:15:45 18-Aug-2000 # Images: obj110 im1 im2 0.001546 (0.000010, 153.7) im2 im1 0.000426 (0.000006, 75.1) im3 im4 0.001613 (0.000091, 17.8) im4 im3 0.001672 (0.000014, 116.4) im5 im6 0.000098 (0.000015, 6.6) im6 im5 0.001382 (0.000016, 86.1) im7 im8 0.000244 (0.000022, 11.2) im8 im7 0.001696 (0.000011, 161.1) .fi Most of the coefficients are highly significant. If one wanted to assume there was no crosstalk in some of the pairs, which speeds applying the calibration step, the file could be edited to one of the following forms. .nf # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:15:45 18-Aug-2000 # Images: obj110 im1 im2 0.001546 (0.000010, 153.7) im2 im1 0.000426 (0.000006, 75.1) im3 im4 0.001613 (0.000091, 17.8) im4 im3 0.001672 (0.000014, 116.4) im5 im6 im5 0.001382 (0.000016, 86.1) im7 im8 im7 0.001696 (0.000011, 161.1) .fi or .nf # XTCOEFF: NOAO/IRAF V2.11.3EXPORT valdes@puppis Fri 10:15:45 18-Aug-2000 # Images: obj110 im1 im2 0.001546 (0.000010, 153.7) im2 im1 0.000426 (0.000006, 75.1) im3 im4 0.001613 (0.000091, 17.8) im4 im3 0.001672 (0.000014, 116.4) im5 im6 0 # 0.000098 (0.000015, 6.6) im6 im5 0.001382 (0.000016, 86.1) im7 im8 0 # 0.000244 (0.000022, 11.2) im8 im7 0.001696 (0.000011, 161.1) .fi .ih REVISIONS .ls XTCOEFF - MSCRED V4.8: September 3, 2002 The previous version underestimated the crosstalk coefficients because of using a crude victim background and no source background. The new versions provides for input of backgrounds as well as object masks. .le .ls XTCOEFF - MSCRED V4.0: August 22, 2000 First release. .le .ih SEE ALSO xtalkcor, ccdproc, icfit .endhelp mscred-5.05-2018.07.09/lib/000077500000000000000000000000001332166314300145345ustar00rootroot00000000000000mscred-5.05-2018.07.09/lib/_package.hd000066400000000000000000000003631332166314300166050ustar00rootroot00000000000000# Help definitions for the package. mscred men = mscred.men, hlp = .., sys = mscguide.hlp, pkg = mscred.hd, src = mscred.cl multampccd men = multampccd.men, hlp = .., sys = mscguide.hlp, pkg = mscred.hd, src = multampccd.cl mscred-5.05-2018.07.09/lib/helpdb.mip000066400000000000000000000175741332166314300165170ustar00rootroot00000000000000D-n±S ª ìÞ%B;B! rootdefdir=mscred$lib/_mscredmscred$lib/rootpackage.hdÞmHò H 9Kp_'¢¸ÝÌŒ rootpackagedefdir=mscred$lib/mscredmscred$mscred.menmscred$mscred.menmscred$mscguide.hlpmscred$mscred.hdmscred$mscred.clmultampccdmscred$multampccd.menmscred$multampccd.menmscred$mscguide.hlpmscred$mscred.hdmscred$multampccd.clßm¯%%"\dDLtzˆ™¢³ÆÐâö(9BS^q|™«·Ëáêû 7@QZk~ˆš¢²ÄÏâ 4=NYl‹¦·ÊÓä÷ÿ!+=QXgx’šª¼ÃÒ0:(äìü;EW`q„Œœ mscreddefdir=mscred$doc=./doc/mscsrc=./src/revisionsRevisionsccdprocdoc$ccdproc.hlpccdlistdoc$ccdlist.hlpmkmscdoc$mkmsc.hlpmscsrc$t_mkmsc.xmscarithdoc$mscarith.hlpmscsrc$mscarith.clmscblkavgdoc$mscblkavg.hlpmscsrc$mscblkavg.clmsccmatchdoc$msccmatch.hlpmsccmddoc$msccmd.hlpmscsrc$msccmd.clmscctrandoc$mscctran.hlpmscdisplaydoc$mscdisplay.hlpmscexaminedoc$mscexamine.hlpmscfinderdoc$mscfinder.hlpmscfindgaindoc$mscfindgain.hlpmscsrc$mscfindgain.clmscfocusdoc$mscfocus.hlpmscgetcatalogdoc$mscgetcatalog.hlpmscsrc$mscgetcatalog.clmscguidedoc$mscguide.hlpmscimagedoc$mscimage.hlpmscsrc$mscimage.clmscimatchdoc$mscimatch.hlpmscjoindoc$mscjoin.hlpmscsrc$mscjoin.clmscotfflatdoc$mscotfflat.hlpmscsrc$mscdisplay/mscotfflat.clmscpixareadoc$mscpixarea.clmscsrc$mscpixarea.clmscrfitsdoc$mscrfits.hlpmscshutcordoc$mscshutcor.hlpmscsrc$mscshutcor.clmscskysubdoc$mscskysub.hlpmscsplitdoc$mscsplit.hlpmscsrc$mscsplit.clmscstackdoc$mscstack.hlpmscsrc$mscstack.clmscstatdoc$mscstat.hlpmscsrc$mscstat.clmsctvmarkdoc$msctvmark.hlpmscsrc$msctvmark.clmscwcsdoc$mscwcs.hlpmscsrc$mscwcs.clmscwfitsdoc$mscwfits.hlpmsczerodoc$msczero.hlpmscsrc$msczero.clpatfitdoc$patfit.hlpmscsrc$t_patfit.xrmpupildoc$rmpupil.hlpmscsrc$rmpupil.clrmfringedoc$rmfringe.hlpmscsrc$rmfringe.clwiynopticdoc$wiynoptic.hlpxtalkcordoc$xtalkcor.hlpmscsrc$xtalkcor.clxtcoeffdoc$xtcoeff.hlpmscsrc$t_xtcoeff.xßm¯%%"\dDLtzˆ™¢³ÆÐâö(9BS^q|™«·Ëáêû 7@QZk~ˆš¢²ÄÏâ 4=NYl‹¦·ÊÓä÷ÿ!+=QXgx’šª¼ÃÒ0:(äìü;EW`q„Œœ mscreddefdir=mscred$doc=./doc/mscsrc=./src/revisionsRevisionsccdprocdoc$ccdproc.hlpccdlistdoc$ccdlist.hlpmkmscdoc$mkmsc.hlpmscsrc$t_mkmsc.xmscarithdoc$mscarith.hlpmscsrc$mscarith.clmscblkavgdoc$mscblkavg.hlpmscsrc$mscblkavg.clmsccmatchdoc$msccmatch.hlpmsccmddoc$msccmd.hlpmscsrc$msccmd.clmscctrandoc$mscctran.hlpmscdisplaydoc$mscdisplay.hlpmscexaminedoc$mscexamine.hlpmscfinderdoc$mscfinder.hlpmscfindgaindoc$mscfindgain.hlpmscsrc$mscfindgain.clmscfocusdoc$mscfocus.hlpmscgetcatalogdoc$mscgetcatalog.hlpmscsrc$mscgetcatalog.clmscguidedoc$mscguide.hlpmscimagedoc$mscimage.hlpmscsrc$mscimage.clmscimatchdoc$mscimatch.hlpmscjoindoc$mscjoin.hlpmscsrc$mscjoin.clmscotfflatdoc$mscotfflat.hlpmscsrc$mscdisplay/mscotfflat.clmscpixareadoc$mscpixarea.clmscsrc$mscpixarea.clmscrfitsdoc$mscrfits.hlpmscshutcordoc$mscshutcor.hlpmscsrc$mscshutcor.clmscskysubdoc$mscskysub.hlpmscsplitdoc$mscsplit.hlpmscsrc$mscsplit.clmscstackdoc$mscstack.hlpmscsrc$mscstack.clmscstatdoc$mscstat.hlpmscsrc$mscstat.clmsctvmarkdoc$msctvmark.hlpmscsrc$msctvmark.clmscwcsdoc$mscwcs.hlpmscsrc$mscwcs.clmscwfitsdoc$mscwfits.hlpmsczerodoc$msczero.hlpmscsrc$msczero.clpatfitdoc$patfit.hlpmscsrc$t_patfit.xrmpupildoc$rmpupil.hlpmscsrc$rmpupil.clrmfringedoc$rmfringe.hlpmscsrc$rmfringe.clwiynopticdoc$wiynoptic.hlpxtalkcordoc$xtalkcor.hlpmscsrc$xtalkcor.clxtcoeffdoc$xtcoeff.hlpmscsrc$t_xtcoeff.xë``"<CUiz‹¨¾Òçø<CUiz‹¨¾Òçø _rootmscred$lib/root.hd_mscredmscred$lib/rootpackage.hdmscredmscred$mscred.menmscred$mscguide.hlpmscred$mscred.clmscred$mscred.hdmscred$mscred.menmultampccdmscred$multampccd.menmscred$mscguide.hlpmscred$multampccd.clmscred$mscred.hdmscred$multampccd.men_index -n±mscred$lib/root.hd$ÌÁmscred$lib/rootpackage.hd`#ŒŸmscred$mscred.hd!-nzmscred$mscred.hd-nzmscred-5.05-2018.07.09/lib/mkmsc/000077500000000000000000000000001332166314300156465ustar00rootroot00000000000000mscred-5.05-2018.07.09/lib/mkmsc/fors.dat000066400000000000000000000012131332166314300173060ustar00rootroot00000000000000imageid(im1) 1 ampid(im1) A datasec(im1) !DSECA biassec(im1) !BSECA trimsec(im1) !TSECA ccdsec(im1) !CSECA detsec(im1) !CSECA ccdname(im1) FORS ampname(im1) AmpA imageid(im2) 2 ampid(im2) B datasec(im2) !DSECB biassec(im2) !BSECB trimsec(im2) !TSECB ccdsec(im2) !CSECB detsec(im2) !CSECB ccdname(im2) FORS ampname(im2) AmpB imageid(im3) 3 ampid(im3) C datasec(im3) !DSECC biassec(im3) !BSECC trimsec(im3) !TSECC ccdsec(im3) !CSECC detsec(im3) !CSECC ccdname(im3) FORS ampname(im3) AmpC imageid(im4) 4 ampid(im4) D datasec(im4) !DSECD biassec(im4) !BSECD trimsec(im4) !TSECD ccdsec(im4) !CSECD detsec(im4) !CSECD ccdname(im4) FORS ampname(im4) AmpD mscred-5.05-2018.07.09/lib/mkmsc/keck.dat000066400000000000000000000013151332166314300172550ustar00rootroot00000000000000ampid(im1) 1 datasec(im1) [205:1228,1:4096] biassec(im1) [4301:4380,1:4096] ccdsec(im1) [1:1024,1:4096] detsec(im1) [1:1024,1:4096] ccdname(im1) "CCD 1" ampname(im1) "AMP 1" ampid(im2) 2 datasec(im2) [1229:2252,1:4096] biassec(im2) [4381:4460,1:4096] ccdsec(im2) [1025:2048,1:4096] detsec(im2) [1025:2048,1:4096] ccdname(im2) "CCD 1" ampname(im2) "AMP 2" ampid(im3) 3 datasec(im3) [2253:3276,1:4096] biassec(im3) [4461:4540,1:4096] ccdsec(im3) [1:1024,1:4096] detsec(im3) [2049:3072,1:4096] ccdname(im3) "CCD 2" ampname(im3) "AMP 1" ampid(im4) 4 datasec(im4) [3277:4300,1:4096] biassec(im4) [4541:4620,1:4096] ccdsec(im4) [1024:2048,1:4096] detsec(im4) [3073:4096,1:4096] ccdname(im4) "CCD 2" ampname(im4) "AMP 2" mscred-5.05-2018.07.09/lib/mkmsc/quad.dat000066400000000000000000000015431332166314300172750ustar00rootroot00000000000000imageid(im1) 1 ampid(im1) 11 datasec(im1) !DSEC11 biassec(im1) !BSEC11 trimsec(im1) !TSEC11 ccdsec(im1) !CSEC11 detsec(im1) !CSEC11 ccdname(im1) !DETECTOR ampname(im1) Amp11 rdnoise(im1) !GTRON11 gain(im1) !GTGAIN11 imageid(im2) 2 ampid(im2) 12 datasec(im2) !DSEC12 biassec(im2) !BSEC12 trimsec(im2) !TSEC12 ccdsec(im2) !CSEC12 detsec(im2) !CSEC12 ccdname(im2) !DETECTOR ampname(im2) Amp12 rdnoise(im2) !GTRON12 gain(im2) !GTGAIN12 imageid(im3) 3 ampid(im3) 21 datasec(im3) !DSEC21 biassec(im3) !BSEC21 trimsec(im3) !TSEC21 ccdsec(im3) !CSEC21 detsec(im3) !CSEC21 ccdname(im3) !DETECTOR ampname(im3) Amp21 rdnoise(im3) !GTRON21 gain(im3) !GTGAIN21 imageid(im4) 4 ampid(im4) 22 datasec(im4) !DSEC22 biassec(im4) !BSEC22 trimsec(im4) !TSEC22 ccdsec(im4) !CSEC22 detsec(im4) !CSEC22 ccdname(im4) !DETECTOR ampname(im4) Amp22 rdnoise(im4) !GTRON22 gain(im4) !GTGAIN22 mscred-5.05-2018.07.09/lib/mkpkg.inc000066400000000000000000000005661332166314300163470ustar00rootroot00000000000000# Global MKPKG definitions for the package. $set XFLAGS = "$(XFLAGS) -p mscred" $set XVFLAGS = "$(XVFLAGS) -p mscred" $set LFLAGS = "$(LFLAGS) -p mscred" $ifeq (MACH, ssun) then $include "mscred$lib/mkpkg.sf.SSUN" #$else $ifeq (MACH, redhat) then # $include "mscred$lib/mkpkg.sf.REDHAT" #$else $ifeq (MACH, sparc) then # $include "mscred$lib/mkpkg.sf.SUN4" $end mscred-5.05-2018.07.09/lib/mkpkg.sf.SSUN000066400000000000000000000004621332166314300167700ustar00rootroot00000000000000# Mkpkg special file list for SUN/IRAF, Solaris # The following need to be linked nonshared to avoid the 268 MB memory limit # in the shared Sun/IRAF library implementation. $set NONSHARE = '& "LFLAGS = -z -/Bstatic -p mscred"' $special "mscred$src/ccdred/src/combine/": xx_combine.e $(NONSHARE) ; mscred-5.05-2018.07.09/lib/mosaic.dat000066400000000000000000000027571332166314300165140ustar00rootroot00000000000000# MSCRED asks for the keyword given in the first column. The second column # is the keyword sought in your image headers. Edit the second column to # change the default translation. Note that when there is no translation # the entry need not be in the translation file. imagetyp obstype amp imageid subset filter biassec biassec ccdmean ccdmean ccdmeant ccdmeant ccdname ccdname ccdsec ccdsec ccdsum ccdsum darktime darktime datasec datasec dec dec detsec detsec exptime exptime fringscl fringscl mkillum mkillum ncombine ncombine nscanrow nscanrow ra ra trimsec trimsec darkcor darkcor fixpix fixpix flatcor flatcor fringecor fringecor illumcor illumcor illumflt illumflt overscan overscan readcor readcor scancor scancor sflatcor sflatcor trim trim zerocor zerocor # Image type keyword value translations. # The value of the "imagetyp" keyword will be translated from the first # column to the second column which is what MSCRED recognizes. Edit the # first column with the keyword values in your data. It is case sensitive # and if the keyword value contains spaces it must be quoted. comp comp dark dark flat flat fringe fringe illum illum mask mask object object other other skyflat skyflat zero zero # Read the following help topics for more information. # instruments - Instrument specific data files # ccdgeometry - Discussion of CCD coordinate/geometry keywords # ccdtypes - Description of the CCD image types # subsets - Description of CCD subsets mscred-5.05-2018.07.09/lib/root.hd000066400000000000000000000004021332166314300160300ustar00rootroot00000000000000# Root help directory for the package. This dummy package is # necessary in order to have `package' appear as a module in some package, # so that the user can type "help " (with `package' given as a task). _mscred pkg = mscred$lib/rootpackage.hd mscred-5.05-2018.07.09/lib/rootpackage.hd000066400000000000000000000006521332166314300173530ustar00rootroot00000000000000# Root task entry for the package help tree. Defines `' # as both a task and a package in the help database. mscred men = mscred$mscred.men, hlp = mscred$mscred.men, sys = mscred$mscguide.hlp, pkg = mscred$mscred.hd, src = mscred$mscred.cl multampccd men = mscred$multampccd.men, hlp = mscred$multampccd.men, sys = mscred$mscguide.hlp, pkg = mscred$mscred.hd, src = mscred$multampccd.cl mscred-5.05-2018.07.09/lib/strip000066400000000000000000000011601332166314300156160ustar00rootroot00000000000000# STRIP -- Rmfiles command script, used to strip the MSCRED directories # of all files not required for ordinary runtime use of the system. src -allbut .hlp .hd .men .cl .par .key .dat .mip .fits -file bin.f68881/OBJS.arc.Z -file bin.ffpa/OBJS.arc.Z -file bin.sparc/OBJS.arc.Z -file bin.i386/OBJS.arc.Z -file bin.linux/OBJS.arc.Z -file bin.ssol/OBJS.arc.Z -file bin.alpha/OBJS.arc.Z -file bin.sf2c/OBJS.arc.Z -file bin.ddec/OBJS.arc.Z -file bin.rs6000/OBJS.arc.Z -file bin.mips/OBJS.arc.Z -file bin.f2c/OBJS.arc.Z -file bin.irix/OBJS.arc.Z -file bin.hp300/OBJS.arc.Z -file bin.hp700/OBJS.arc.Z -file bin.hp800/OBJS.arc.Z mscred-5.05-2018.07.09/lib/xtcoeff/000077500000000000000000000000001332166314300161725ustar00rootroot00000000000000mscred-5.05-2018.07.09/lib/xtcoeff/README000066400000000000000000000010401332166314300170450ustar00rootroot00000000000000This directory contains extension lists for use with the XTCOEFF task. The lists are paired with the 'v' files being for the victim and the 's' files being for the source. vnoao8/snoao8 NOAO Mosaics with 8 amplifiers All pairs sharing the same Arcon box vnoao8ref/snoao8ref NOAO Mosaics with 8 amplifiers All pairs not sharing the same Arcon box vnoao16/snoao16 NOAO Mosaics with 16 amplifiers All pairs sharing the same Arcon box vnoao16ref/snoao16ref NOAO Mosaics with 16 amplifiers All pairs not sharing the same Arcon box mscred-5.05-2018.07.09/lib/xtcoeff/snoao16000066400000000000000000000003251332166314300174030ustar00rootroot00000000000000im2 im3 im4 im1 im3 im4 im1 im2 im4 im1 im2 im3 im6 im7 im8 im5 im7 im8 im5 im6 im8 im5 im6 im7 im10 im11 im12 im9 im11 im12 im9 im10 im12 im9 im10 im11 im14 im15 im16 im13 im15 im16 im13 im14 im16 im13 im14 im15 mscred-5.05-2018.07.09/lib/xtcoeff/snoao16ref000066400000000000000000000015241332166314300201020ustar00rootroot00000000000000im5 im6 im7 im8 im9 im10 im11 im12 im13 im14 im15 im16 im5 im6 im7 im8 im9 im10 im11 im12 im13 im14 im15 im16 im5 im6 im7 im8 im9 im10 im11 im12 im13 im14 im15 im16 im5 im6 im7 im8 im9 im10 im11 im12 im13 im14 im15 im16 im1 im2 im3 im4 im9 im10 im11 im12 im13 im14 im15 im16 im1 im2 im3 im4 im9 im10 im11 im12 im13 im14 im15 im16 im1 im2 im3 im4 im9 im10 im11 im12 im13 im14 im15 im16 im1 im2 im3 im4 im9 im10 im11 im12 im13 im14 im15 im16 im1 im2 im3 im4 im5 im6 im7 im8 im13 im14 im15 im16 im1 im2 im3 im4 im5 im6 im7 im8 im13 im14 im15 im16 im1 im2 im3 im4 im5 im6 im7 im8 im13 im14 im15 im16 im1 im2 im3 im4 im5 im6 im7 im8 im13 im14 im15 im16 im1 im2 im3 im4 im5 im6 im7 im8 im9 im10 im11 im12 im1 im2 im3 im4 im5 im6 im7 im8 im9 im10 im11 im12 im1 im2 im3 im4 im5 im6 im7 im8 im9 im10 im11 im12 im1 im2 im3 im4 im5 im6 im7 im8 im9 im10 im11 im12 mscred-5.05-2018.07.09/lib/xtcoeff/snoao8000066400000000000000000000000401332166314300173160ustar00rootroot00000000000000im2 im1 im4 im3 im6 im5 im8 im7 mscred-5.05-2018.07.09/lib/xtcoeff/snoao8ref000066400000000000000000000003001332166314300200120ustar00rootroot00000000000000im3 im4 im5 im6 im7 im8 im3 im4 im5 im6 im7 im8 im1 im2 im5 im6 im7 im8 im1 im2 im5 im6 im7 im8 im1 im2 im3 im4 im7 im8 im1 im2 im3 im4 im7 im8 im1 im2 im3 im4 im5 im6 im1 im2 im3 im4 im5 im6 mscred-5.05-2018.07.09/lib/xtcoeff/vnoao16000066400000000000000000000003251332166314300174060ustar00rootroot00000000000000im1 im1 im1 im2 im2 im2 im3 im3 im3 im4 im4 im4 im5 im5 im5 im6 im6 im6 im7 im7 im7 im8 im8 im8 im9 im9 im9 im10 im10 im10 im11 im11 im11 im12 im12 im12 im13 im13 im13 im14 im14 im14 im15 im15 im15 im16 im16 im16 mscred-5.05-2018.07.09/lib/xtcoeff/vnoao16ref000066400000000000000000000015241332166314300201050ustar00rootroot00000000000000im1 im1 im1 im1 im1 im1 im1 im1 im1 im1 im1 im1 im2 im2 im2 im2 im2 im2 im2 im2 im2 im2 im2 im2 im3 im3 im3 im3 im3 im3 im3 im3 im3 im3 im3 im3 im4 im4 im4 im4 im4 im4 im4 im4 im4 im4 im4 im4 im5 im5 im5 im5 im5 im5 im5 im5 im5 im5 im5 im5 im6 im6 im6 im6 im6 im6 im6 im6 im6 im6 im6 im6 im7 im7 im7 im7 im7 im7 im7 im7 im7 im7 im7 im7 im8 im8 im8 im8 im8 im8 im8 im8 im8 im8 im8 im8 im9 im9 im9 im9 im9 im9 im9 im9 im9 im9 im9 im9 im10 im10 im10 im10 im10 im10 im10 im10 im10 im10 im10 im10 im11 im11 im11 im11 im11 im11 im11 im11 im11 im11 im11 im11 im12 im12 im12 im12 im12 im12 im12 im12 im12 im12 im12 im12 im13 im13 im13 im13 im13 im13 im13 im13 im13 im13 im13 im13 im14 im14 im14 im14 im14 im14 im14 im14 im14 im14 im14 im14 im15 im15 im15 im15 im15 im15 im15 im15 im15 im15 im15 im15 im16 im16 im16 im16 im16 im16 im16 im16 im16 im16 im16 im16 mscred-5.05-2018.07.09/lib/xtcoeff/vnoao8000066400000000000000000000000401332166314300173210ustar00rootroot00000000000000im1 im2 im3 im4 im5 im6 im7 im8 mscred-5.05-2018.07.09/lib/xtcoeff/vnoao8ref000066400000000000000000000003001332166314300200150ustar00rootroot00000000000000im1 im1 im1 im1 im1 im1 im2 im2 im2 im2 im2 im2 im3 im3 im3 im3 im3 im3 im4 im4 im4 im4 im4 im4 im5 im5 im5 im5 im5 im5 im6 im6 im6 im6 im6 im6 im7 im7 im7 im7 im7 im7 im8 im8 im8 im8 im8 im8 mscred-5.05-2018.07.09/lib/zzsetenv.def000066400000000000000000000003261332166314300171050ustar00rootroot00000000000000# Global environment definitions for the package. reset mscbin = "mscred$bin(arch)/" reset mscsrc = "mscred$src/" reset msclib = "mscred$lib/" reset pkglibs = "mscbin$,tables$bin(arch)/,tables$lib/" keep mscred-5.05-2018.07.09/mkpkg000066400000000000000000000056621332166314300150330ustar00rootroot00000000000000# Make the package. update: $call lmscred@src $call lccdred@src $call lcombine@src $call lmscdisp@src $call limexam@src $call lsf@src $call lfinder@src $call update@src ; # STRIP -- Strip the package directories of all sources and other files # not required to run the system, or for user programming. strip: !rmfiles -f lib/strip ; # SUMMARY -- [UNIX] mkpkg summary: output a summary of the spooled mkpkg # output, omitting most of the mundane chatter. Used to scan large spool # files for errors. summary: $ifeq (HOSTID, unix) $ifndef (spool) $set spool = spool $endif ! grep -v ':$$' spool | grep -v '^xc' | grep -v '^ar'\ | grep -v '^check file' $else $echo "mkpkg summary only available on a UNIX system" $endif ; # IRAF multiple architecture support. # ---------------------------------------- arch: # show current float option showfloat: $verbose off !$(hlib)/mkfloat.csh ; generic: # generic installation (no bin) $ifnfile (bin.generic) !mkdir bin.generic $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh generic -d $(DIRS) ; freebsd: # install FreeBSD binaries $ifnfile (bin.freebsd) !mkdir bin.freebsd $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh freebsd -d $(DIRS) ; linux: # install Linux 32-bit binaries $ifnfile (bin.linux) !mkdir bin.linux $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh linux -d $(DIRS) ; linux64: # install Linux 64-bit binaries $ifnfile (bin.linux64) !mkdir bin.linux64 $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh linux64 -d $(DIRS) ; macosx: # install Mac OS X (PPC) binaries $ifnfile (bin.macosx) !mkdir bin.macosx $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh macosx -d $(DIRS) ; macintel: # install Mac OS X (Intel) binaries $ifnfile (bin.macintel) !mkdir bin.macintel $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh macintel -d $(DIRS) ; cygwin: # install Cygwin binaries $ifnfile (bin.macintel) !mkdir bin.macintel $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh macintel -d $(DIRS) ; redhat: # install Redhat Linux binaries $ifnfile (bin.redhat) !mkdir bin.redhat $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh redhat -d $(DIRS) ; sparc: # install sparc binaries $ifnfile (bin.sparc) !mkdir bin.sparc $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh sparc -d $(DIRS) ; ssun: # install Sun/Solaris binaries $ifnfile (bin.ssun) !mkdir bin.ssun $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh ssun -d $(DIRS) ; sunos: # install SunOS (Solaris x86) binaries $ifnfile (bin.sunos) !mkdir bin.sunos $endif $verbose off $set DIRS = "lib src" !$(hlib)/mkfloat.csh sunos -d $(DIRS) ; noP2R: !find . -type f -name '*[xh]' -exec grep -q P2R {} \; -exec sed -i -e 's+P2R++g' {} \; ; mscred-5.05-2018.07.09/mscred.cl000066400000000000000000000120031332166314300155570ustar00rootroot00000000000000#{ MSCRED -- Mosaic CCD Reduction Package # Load dependent packages. if (deftask ("fitsutil")) fitsutil else ; nproto astutil digiphot apphot photcal if (deftask ("astcat")) astcat else ; # This package requires FITS image type and various kernel parameters. reset imtype = "fits" if (defvar ("fkinit")) set fkinit = envget ("fkinit") // ",append,padlines=10,cachesize=60" else set fkinit = "append,padlines=10,cachesize=60" cl < "mscred$lib/zzsetenv.def" package mscred, bin = mscbin$ # Logical directories. set xtcoeff = "mscred$lib/xtcoeff/" set mccdred = "mscsrc$ccdred/" set combine = "mscsrc$ccdred/src/combine/" # Tasks. task mscmedian = mscsrc$mscmedian.cl task msctmp1 = mscsrc$msctmp1.cl task mscfindgain = mscsrc$mscfindgain.cl task mscsplit = mscsrc$mscsplit.cl task mscjoin = mscsrc$mscjoin.cl task mscwfits = mscsrc$mscwfits.cl task mscrfits = mscsrc$mscrfits.cl task msctoshort = mscsrc$msctoshort.cl task dispsnap = mscsrc$dispsnap.cl task ccdproc = mscsrc$ccdproc.cl task calproc = mscsrc$calproc.cl task ccdhedit = mscsrc$ccdhedit.cl task ccdlist = mscsrc$ccdlist.cl task setinstrument = mscsrc$setinstrument.cl task _ccdhedit, _ccdlist, _ccdtool = mscsrc$x_ccdred.e task ccddelete, ccdgroups = mccdred$x_ccdred.e hidetask ccddelete, ccdgroups task combine, coutput, mergeamps = combine$x_combine.e hidetask coutput, mergeamps task darkcombine = mccdred$darkcombine.cl task flatcombine = mccdred$flatcombine.cl task sflatcombine = mscsrc$sflatcombine.cl task zerocombine = mccdred$zerocombine.cl task mscgetcatalog = mscsrc$mscgetcatalog.cl task mscagetcat = mscsrc$mscagetcat.cl task mscsetwcs = mscsrc$mscsetwcs.cl task msczero = mscsrc$msczero.cl task mscxreg = mscsrc$mscxreg.cl task mscimage = mscsrc$mscimage.cl task mscoimage = mscsrc$mscoimage.cl task mscstack = mscsrc$mscstack.cl #task mscdither = mscsrc$mscdither.cl task msccmd = mscsrc$msccmd.cl task mscarith = mscsrc$mscarith.cl task mscstat = mscsrc$mscstat.cl #task mscimatch = mscsrc$mscimatch.cl #task ffpupilcor = mscsrc$ffpupilcor.cl task rmfringe = mscsrc$rmfringe.cl task rmpupil = mscsrc$rmpupil.cl task irmfringe = mscsrc$irmfringe.cl task irmpupil = mscsrc$irmpupil.cl task mscpupil = mscsrc$mscpupil.cl task mscblkavg = mscsrc$mscblkavg.cl task mscpixarea = mscsrc$mscpixarea.cl #task xtalkcor = mscsrc$xtalkcor.cl task mscqphot = mscsrc$mscqphot.cl task msccntr = mscsrc$msccntr.cl task mscshutcor = mscsrc$mscshutcor.cl task mscselect = mscsrc$mscselect.cl task addkey, fitscopy, getcatalog, joinlists, mkmsc, msccmatch, mscctran, mscextensions, mscgmask, mscimatch, mscpmask, mscskysub, msctemplate, mscwtemplate, mscwcs, mscuniq, patfit, pixarea, pupilfit, toshort, ximstat, xlog, xtalkcor, xtcoeff = mscsrc$x_mscred.e # Photometry parameters. #task msccpars = mscsrc$msccpars.par #task mscdpars = mscsrc$mscdpars.par #task mscppars = mscsrc$mscppars.par #task mscspars = mscsrc$mscspars.par hidetask ximstat, joinlists, mscoimage, msccntr hidetask addkey, fitscopy, calproc, getcatalog hidetask mscgmask, mscpmask, msctemplate, mscwtemplate hidetask mscxreg, mscuniq, mscextensions hidetask patfit, pupilfit, toshort, xlog #hidetask msccpars, mscdpars, mscppars, mscspars hidetask dispsnap, mscqphot, pixarea, msctmp1 # Special version of utilities.curfit task msccurfit = "mscsrc$curfit/x_mscred.e" hidetask msccurfit # Display stuff. #task newdisplay = "mscsrc$display/x_display.e" task msctvmark = "mscsrc$msctvmark.cl" task mscztvmark = "mscsrc$mscztvmark.cl" set mscdisplay = "mscsrc$mscdisplay/" set mosexam = "mscdisplay$src/imexam/" set starfocus = "mscdisplay$src/starfocus/" task mscstarfocus = starfocus$x_mscdisplay.e; hidetask mscstarfocus task mscfocus = starfocus$mscfocus.cl task mscdisplay, mscrtdisplay = mscdisplay$x_mscdisplay.e task mimpars = mscdisplay$mimpars.par hidetask mscrtdisplay, mscztvmark task mscexamine = "mosexam$x_mscexam.e" task cimexam2 = mosexam$cimexam2.par; hidetask cimexam2 task eimexam2 = mosexam$eimexam2.par; hidetask eimexam2 task himexam2 = mosexam$himexam2.par; hidetask himexam2 task jimexam2 = mosexam$jimexam2.par; hidetask jimexam2 task kimexam2 = mosexam$kimexam2.par; hidetask kimexam2 task limexam2 = mosexam$limexam2.par; hidetask limexam2 task rimexam2 = mosexam$rimexam2.par; hidetask rimexam2 task simexam2 = mosexam$simexam2.par; hidetask simexam2 task vimexam2 = mosexam$vimexam2.par; hidetask vimexam2 task mscotfflat = "mscdisplay$mscotfflat.cl" task flatcompress = "mscdisplay$flatcompress.cl" hidetask flatcompress # Stuff for PICREAD data. #task mkfits = mscsrc$picread/mkfits.cl #task mosfocus = mscsrc$picread/mosfocus.cl # Subpackages set mscfinder = "mscsrc$mscfinder/" task $mscfinder = mscfinder$mscfinder.cl set mscpipeline = "mscsrc$mscpipeline/" task mscpipeline = mscpipeline$mscpipeline.cl hidetask mscpipeline set msctest = "mscsrc$msctest/" task $msctest = msctest$msctest.cl; hidetask msctest set msctools = "mscsrc$msctools/" #task $msctools = msctools$msctools.cl clbye() mscred-5.05-2018.07.09/mscred.hd000066400000000000000000000033601332166314300155620ustar00rootroot00000000000000# Help directory for the MSCRED package. $doc = "./doc/" $mscsrc = "./src/" revisions sys=Revisions ccdproc hlp=doc$ccdproc.hlp ccdlist hlp=doc$ccdlist.hlp mkmsc hlp=doc$mkmsc.hlp, src=mscsrc$t_mkmsc.x mscarith hlp=doc$mscarith.hlp, src=mscsrc$mscarith.cl mscblkavg hlp=doc$mscblkavg.hlp, src=mscsrc$mscblkavg.cl msccmatch hlp=doc$msccmatch.hlp msccmd hlp=doc$msccmd.hlp, src=mscsrc$msccmd.cl mscctran hlp=doc$mscctran.hlp mscdisplay hlp=doc$mscdisplay.hlp mscexamine hlp=doc$mscexamine.hlp mscfinder hlp=doc$mscfinder.hlp mscfindgain hlp=doc$mscfindgain.hlp, src=mscsrc$mscfindgain.cl mscfocus hlp=doc$mscfocus.hlp mscgetcatalog hlp=doc$mscgetcatalog.hlp, src=mscsrc$mscgetcatalog.cl mscguide hlp=doc$mscguide.hlp mscimage hlp=doc$mscimage.hlp, src=mscsrc$mscimage.cl mscimatch hlp=doc$mscimatch.hlp mscjoin hlp=doc$mscjoin.hlp, src=mscsrc$mscjoin.cl mscotfflat hlp=doc$mscotfflat.hlp, src=mscsrc$mscdisplay/mscotfflat.cl mscpixarea hlp=doc$mscpixarea.cl, src=mscsrc$mscpixarea.cl mscrfits hlp=doc$mscrfits.hlp mscshutcor hlp=doc$mscshutcor.hlp, src=mscsrc$mscshutcor.cl mscskysub hlp=doc$mscskysub.hlp mscsplit hlp=doc$mscsplit.hlp, src=mscsrc$mscsplit.cl mscstack hlp=doc$mscstack.hlp, src=mscsrc$mscstack.cl mscstat hlp=doc$mscstat.hlp, src=mscsrc$mscstat.cl msctvmark hlp=doc$msctvmark.hlp, src=mscsrc$msctvmark.cl mscwcs hlp=doc$mscwcs.hlp, src=mscsrc$mscwcs.cl mscwfits hlp=doc$mscwfits.hlp msczero hlp=doc$msczero.hlp, src=mscsrc$msczero.cl patfit hlp=doc$patfit.hlp, src=mscsrc$t_patfit.x rmpupil hlp=doc$rmpupil.hlp, src=mscsrc$rmpupil.cl rmfringe hlp=doc$rmfringe.hlp, src=mscsrc$rmfringe.cl wiynoptic hlp=doc$wiynoptic.hlp xtalkcor hlp=doc$xtalkcor.hlp, src=mscsrc$xtalkcor.cl xtcoeff hlp=doc$xtcoeff.hlp, src=mscsrc$t_xtcoeff.x mscred-5.05-2018.07.09/mscred.men000066400000000000000000000055071332166314300157530ustar00rootroot00000000000000 ccdhedit - Mosaic header editor ccdlist - List mosaic processing information ccdproc - Process mosaic exposures combine - Combine mosaic exposures darkcombine - Combine and process mosaic dark count exposures flatcombine - Combine and process mosaic flat field exposures setinstrument - Set instrument parameters sflatcombine - Combine and process mosaic sky flat field exposures zerocombine - Combine and process mosaic zero level exposures irmfringe - Remove fringe pattern, possibly interactively, by scaling irmpupil - Remove pupil image, possibly interactively, by scaling mimpars - Mosaic image parameters for display mkmsc - Make multiextension mosaic format from flat formats mscarith - Image arithmetic mosaic exposures mscblkavg - Block average mosaic exposures with header keyword updating msccmatch - Match coordinates from list by adjusting WCS msccmd - Execute general command with image extension expansion mscctran - Celestial coordinate transformation using plate solution mscdisplay - Display mosaic exposures in single frames mscexamine - Examine mosaic exposures displayed as single frames mscfinder - Package to do astrometry on mosaic data mscfindgain - Calculate the gain and readout noise of a mosaic of CCD mscmedian - Median filter mosaic exposures mscfocus - Measure focus from mosaic focus exposures mscgetcatalog - Get coordinates from a Web server covering mosaic exposures mscimage - Reconstruct single images from a mosaic exposures mscimatch - Match intensity scales in reconstructed mosaic images mscjoin - Join separate images into MEF files mscotfflat - Built on-the-fly flat field calibrations mscpixarea - Compute and apply pixel area correction using WCS mscpupil - Fit and remove pupil ghost from mosaic images mscrfits - Read mosaic data from a FITS tape mscsetwcs - Reset WCS using astrometry database and/or RA/DEC keywords mscshutcor - Compute shutter correction from a set of mosaic exposures mscskysub - Fit a sky surface and subtract all but the mean mscsplit - Split MEF files into separate images mscstack - Combine multiple reconstructed mosaic images mscstat - Image statistics on mosaic image extensions msctvmark - Mark coordinates from file on previous MSCDISPLAY mscwcs - Set and adjust mosaic WCS mscwfits - Write mosaic data to a FITS tape msczero - Display, measure coordinates, set WCS zeropoint offsets rmfringe - Remove fringe pattern rmpupil - Remove pupil image xtalkcor - Apply crosstalk corrections xtcoeff - Compute crosstalk coefficients ADDITIONAL HELP TOPICS mscguide - Introductory guide to using the MSCRED package mscred-5.05-2018.07.09/mscred.par000066400000000000000000000013211332166314300157440ustar00rootroot00000000000000# MSCRED package parameter file pixeltype,s,h,"real real",,,Output and calculation pixel datatypes verbose,b,h,no,,,Print log information to the standard output? logfile,f,h,"logfile",,,Text log file plotfile,f,h,"",,,Log metacode plot file backup,s,h,"once","none|once|all",,Backup data (none|once|all)? bkuproot,s,h,"Raw/",,,Backup root (directory or prefix) instrument,s,h,"mscred$lib/mosaic.dat",,,CCD instrument file ampfile,s,h,"amps",,,Amplifier translation file ssfile,s,h,"subsets",,,Subset translation file im_bufsize,r,h,0.065536,0.001024,,Image I/O buffer size (in Mbytes) graphics,s,h,"stdgraph",,,Interactive graphics output device cursor,*gcur,h,"",,,Graphics cursor input version,s,h,"V5.05: 2018.07.09" mscred-5.05-2018.07.09/multampccd.cl000066400000000000000000000042741332166314300164460ustar00rootroot00000000000000#{ MULTAMPCCD -- Multiamp CCD Reduction Package # This package requires FITS image type and various kernel parameters. reset imtype = "fits" if (defvar ("fkinit")) set fkinit = envget ("fkinit") // ",append,padlines=10" else set fkinit = "append,padlines=10" cl < "mscred$lib/zzsetenv.def" package multampccd, bin = mscbin$ set ccdred = "mscsrc$ccdred/" task mscwfits = mscsrc$mscwfits.cl task mscrfits = mscsrc$mscrfits.cl task ccdproc = mscsrc$ccdproc.cl task calproc = mscsrc$calproc.cl task ccdhedit = mscsrc$ccdhedit.cl task ccdlist = mscsrc$ccdlist.cl task setinstrument = mscsrc$setinstrument.cl task _ccdhedit, _ccdlist, _ccdtool = mscsrc$x_ccdred.e task ccddelete, ccdgroups, combine, coutput, mergeamps = ccdred$x_ccdred.e hidetask ccddelete, ccdgroups, coutput, mergeamps task darkcombine = ccdred$darkcombine.cl task flatcombine = ccdred$flatcombine.cl task sflatcombine = mscsrc$sflatcombine.cl task zerocombine = ccdred$zerocombine.cl task msccmd = mscsrc$msccmd.cl task mscarith = mscsrc$mscarith.cl task mscstat = mscsrc$mscstat.cl task mscblkavg = mscsrc$mscblkavg.cl task fitscopy, mscuniq = mscsrc$x_mscred.e hidetask fitscopy, calproc, mscuniq # Display stuff. set mscdisplay = "mscsrc$mscdisplay/" set mosexam = "mscdisplay$src/imexam/" set starfocus = "mscdisplay$src/starfocus/" task mscstarfocus = starfocus$x_mscdisplay.e; hidetask mscstarfocus task mscfocus = starfocus$mscfocus.cl task mscdisplay, mscrtdisplay = mscdisplay$x_mscdisplay.e task mimpars = mscdisplay$mimpars.par hidetask mscrtdisplay task mscexamine = "mosexam$x_mscexam.e" task cimexam2 = mosexam$cimexam2.par; hidetask cimexam2 task eimexam2 = mosexam$eimexam2.par; hidetask eimexam2 task himexam2 = mosexam$himexam2.par; hidetask himexam2 task jimexam2 = mosexam$jimexam2.par; hidetask jimexam2 task limexam2 = mosexam$limexam2.par; hidetask limexam2 task rimexam2 = mosexam$rimexam2.par; hidetask rimexam2 task simexam2 = mosexam$simexam2.par; hidetask simexam2 task vimexam2 = mosexam$vimexam2.par; hidetask vimexam2 task mscotfflat = "mscdisplay$mscotfflat.cl" task flatcompress = "mscdisplay$flatcompress.cl" hidetask flatcompress clbye() mscred-5.05-2018.07.09/multampccd.men000066400000000000000000000023571332166314300166270ustar00rootroot00000000000000 ccdhedit - Mosaic header editor ccdlist - List mosaic processing information ccdproc - Process mosaic exposures combine - Combine mosaic exposures darkcombine - Combine and process mosaic dark count exposures flatcombine - Combine and process mosaic flat field exposures setinstrument - Set instrument parameters sflatcombine - Combine and process mosaic sky flat field exposures zerocombine - Combine and process mosaic zero level exposures mimpars - Mosaic image parameters for display mscarith - Image arithmetic mosaic exposures mscblkavg - Block average mosaic exposures with header keyword updating msccmd - Execute general command with image extension expansion mscdisplay - Display mosaic exposures in single frames mscexamine - Examine mosaic exposures displayed as single frames mscfocus - Measure focus from mosaic focus exposures mscotfflat - Built on-the-fly flat field calibrations mscrfits - Read mosaic data from a FITS tape mscstat - Image statistics on mosaic image extensions mscwfits - Write mosaic data to a FITS tape ADDITIONAL HELP TOPICS mscguide - Introductory guide to using the MSCRED package mscred-5.05-2018.07.09/multampccd.par000066400000000000000000000013371332166314300166270ustar00rootroot00000000000000# MULTAMPCCD package parameter file pixeltype,s,h,"real real",,,Output and calculation pixel datatypes verbose,b,h,no,,,Print log information to the standard output? logfile,f,h,"logfile",,,Text log file plotfile,f,h,"",,,Log metacode plot file backup,s,h,"once","none|once|all",,Backup data (none|once|all)? bkuproot,s,h,"Raw/",,,Backup root (directory or prefix) instrument,s,h,"mscdb$noao/mosaic1/mosaic.dat",,,CCD instrument file ampfile,s,h,"amps",,,Amplifier translation file ssfile,s,h,"subsets",,,Subset translation file im_bufsize,r,h,0.065536,0.001024,,Image I/O buffer size (in Mbytes) graphics,s,h,"stdgraph",,,Interactive graphics output device cursor,*gcur,h,"",,,Graphics cursor input version,s,h,"V2.1: November 1998" mscred-5.05-2018.07.09/src/000077500000000000000000000000001332166314300145555ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/Revisions000066400000000000000000003216411332166314300164700ustar00rootroot00000000000000.help revisions Oct96 noao.imred.mscred .nf REMOVE FIXPIX WORKAROUNDS WHEN V2.11.2 PATCH IS RELEASED. mscfinder/msctpeak.cl Made the internal table use an explicit extension of fits. (8/9/2012, Valdes) mscimage.cl ../mscred.par The task parameters "boundary" and "blank" were not being used. (9/18/09, Valdes) ../mscred.cl The logical directory ccdred was being redefined which confuses loading the ccdred package. The directory is now mccdred. (6/13/08, Valdes) t_mscwcs.x There was a bug where arguments were used both as input and output. (3/3/08, Valdes) ================= V4.8: Mar 3, 2008 ================= t_msctmplt.x Reference projections of zpn are changed to tan on output. (3/30/07, Valdes) mscarith.cl Changed nresults to nresult in the declaration since that is what is used in the script. (3/8/06, Valdes) ccdred/src/setsections.x The updating of the physical WCS was not correct for binned data. This would cause mscmerge produce incorrect sections such as for CCDSEC. In turn, that would cause applying merged calibrations of binned data to fail in CCDPROC. (4/15/05, Valdes) mscdisplay/src/t_mscdisplay.x In order to support the tiled WCS in XImtool the tx/ty calculation has to not subtract the mosaic origin on the individual tiles. (2/3/05, Valdes) ccdred/src/combine/src/generic/mkpkg ccdred/src/combine/src/mkpkg ccdred/src/combine/mkpkg ccdred/src/generic/mkpkg ccdred/src/mkpkg ccdred/mkpkg curfit/mkpkg imsurfit/mkpkg mscdisplay/src/imexam/mkpkg mscdisplay/src/starfocus/mkpkg mscdisplay/src/mkpkg mscdisplay/mkpkg mscfinder/cdrfits/mkpkg mscfinder/select/mkpkg mscfinder/mkpkg mkpkg ../mkpkg Restructured to put all binaries in mscbin$. (9/28/04, Valdes) t_patfit.x Added another line of output which is the statistical weight to use when combining multiple scale measurements. This can be used to run PATFIT independently on pieces of a mosaic and then combine the scales with the given weights to get the same result as running PATFIT over all the pieces together. (8/16/04, Valdes) t_patfit.x There was a bug when the background is specified and a non-zero constant value and there is block averaging used. (8/2/04, Valdes) ccdred/src/combine/src/icombine.x Added environment variable "imcombine_maxmemory" to control memory allocation. (7/28/04, Valdes) ccdred/src/combine/src/icmask.x ccdred/src/combine/src/iclog.x ccdred/src/combine/src/icombine.h ccdred/src/combine/combine.par ccdred/src/combine/fcombine.par ccdred/src/combine/scombine.par ccdred/src/combine/zcombine.par ccdred/src/combine/mergeamps.par As a special unadvertised feature the "maskvalue" parameter may be specified with a leading '<' or '>'. Ultimately a full expression should be added and documented. (7/26/04, Valdes) ccdred/src/xtfp.gx ccdred/src/xtfixpix.x ccdred/src/xtpmmap.x ccdred/src/xtfixpix.h Updated to pick up latest bugfixes from xtools$fixpix/. The most important fix is that column interpolation was not really working! (7/23/04, Valdes) ccdred/src/combine/x_combine.x ccdred/src/combine/scombine.par Added alias scombine for combine. (7/18/04, Valdes) ccdred/src/combine/src/ Updated to latest version. This includes a change to allow images to be specified with a directory path and have the masks specified in the header be found in that directory. (7/16/04, Valdes) ================== V4.8: May 11, 2004 ================== t_msccmatch.x 1. Added argument to control the maximum fraction of regions that can be rejected by the mask before ignoring the mask. 2. Currently the fraction is 0.5 during coarse search (the same as before) and 0 during the fine centering. The latter change means that if all the sources are flagged (say because the mask incorrectly flags all pixels) the program will quit with too few sources. (5/11/04, Valdes) t_msccmatch.x Added a line to the verbose output that prints the average shift. Note that this is different than the tangent point shift which is part of a higher order fit. (3/17/04, Valdes) ======================= V4.8: February 25, 2004 ======================= t_mscwcs.x A ctran descriptor was not being freed and so after enough calls to wcs_adjust an error would occur for too many ctran descriptors allocated. (2/25/04, Valdes) t_msccmatch.x Added check to avoid a segmentation violation if an error occurred in reading the coordinate list. (2/25/04, Valdes) mscdisplay/src/mosmap.x Fixed problem with possibly computing bad image sections when binning the real time readout. (2/13/04, Valdes) t_getcatalog.x Increase the formating by one decimal place. (2/3/04, Valdes) t_mscimatch.x Fixed intrinsic function type mismatch in imat_eprop. (1/15/04, Valdes) ccdproc/src/combine/src/xtimmap.gx Copying the IMIO structure to an internal structure required two amovi calls in order to maintain alignment. (1/12/04, Zarate/Valdes) t_xtalkcor.x More changes to handle checking for existing split output images and handling errors. (1/2/04, Valdes) ======================= V4.8: December 30, 2003 ======================= mscdisplay/src/starfocus/t_starfocus.x The input mosaic (i.e. tv) coordinates are transformed to image coordinates (in stf_find) but then not transformed back to mosaic coordinates for iteration, focus steps, and output. This results in the focus stepping and iteration not to work. Calls to mg_im2c were added. (12/16/03, Valdes) t_xtalkcor.x Removed the option, added on 3/13/03, to have a longer output list than input in order to specify explicit output names. (12/23/03, Valdes) t_xtalkcor.x Modified logic so that if the input is missing extensions it is not an error if those extensions are referenced in the crosstalk file as long as all dependent extensions are absent. (12/18/03, Valdes) mscshutcor.cl ../doc/mscshutcor.hlp ../mscred.cl ../mscred.men ../mscred.hd Added a new task to compute shutter corrections for mosaic exposures. (12/16/03, Valdes) ../mscred.cl ccdproc.cl calproc.cl Removed the mscstatus variable. (12/16/03, Valdes) ======================= V4.8: November 6, 2003 ======================= t_patfit.x In case of an error the input would be deleted if no output was specified or if the input and output are the same. Instead the temp file is supposed to be deleted. (10/30/03, Valdes) ../doc/wiynoptic.hlp Added user's guide for the WIYN/OPTIC camera. (10/22/03, Valdes) ccdred/src/proc.gx Forgot to set the minval/maxval variables for sky flats. (9/26/03, Valdes) mscimage.cl Added the "addonly" flag to the hedit calls. (9/25/03, Valdes) mscsetwcs.cl When msctpeak is used on non-extension data the database solution name is the image name. Mscsetwcs now finds the last solution in the database if the image being calibrated does not have an extension name. (9/24/03, Valdes) t_msccmatch.x The "maxiterate" parameter for GEOMAP was not set. It is now set to 4. (9/23/03, Valdes) ccdred/src/setflat.x Minor fix to remove unused variable. (9/22/03, Valdes) ccdred/src/ccdred.h ccdred/src/cor.gx ccdred/src/proc.gx ccdred/src/setflat.x Added an option to convert data to electrons or electrons/s during flat fielding provided the (translated) keyword GAINNORM is in the header. This is implemented by modifying the flat field normalization value which is why it can only be done during flat fielding. ( 9/17/03, Valdes) ccdred/src/setoverscan.x Added the keyword OVSNMEAN to give the mean overscan as a separate keyword. This is used for keyword monitoring. (9/17/03, Valdes) t_msccmatch.x The hidden debug option for outputing a vote array was changed slightly. (8/29/03, Valdes) t_xtalkcor.x 1. Fixed bug when giving a list of bad pixel names during splitting. 2. The bad pixel mask name is added to the header with keyword XTALKBPM. (8/28/03, Valdes) ccdred/src/combine/src/xtimmap.x Increased the length of image names in the structure. (8/20/03, Valdes) xtpmmap.x Added a check yt_match to deal with the unusual situation where the mask and reference image are off by a fraction of a pixel. (8/14/03, Valdes) ======================= V4.8: July 30, 2003 ======================= ccdred/src/combine/src/icsetout.x When using offsets based on physical coordinates and there is a flip the routine was incorrectly using imunmap instead of xt_imunmap. (7/30/03, Valdes) ccdred/src/imcombine/src/icstat.gx Fixed an incorrect declaration for asum$t() in the generic routine. (7/30/03, Valdes) ccdred/src/setsection.x The ltv calculation was wrong when LTM1_1/LTM2_2 are negative. (7/28/03, Valdes) t_mscimatch.x Added divide by zero protection. (7/17/03, Valdes) ======================= V4.8: June 24, 2003 ======================= mkpkg ccdred/mkpkg Modified to use plp2li.o if the private version is newer than the system version. (6/24/03, Valdes) mscdisplay$src/starfocus/t_starfocus.x mscdisplay$src/starfocus/stfprofile.x mscdisplay$src/starfocus/starfocus.h mscdisplay$src/imexam/stfmeasure.x mscdisplay$src/imexam/stfprofile.x + mscdisplay$src/imexam/starfocus.h Updated for recent bug fixes. (5/5/03, Valdes) ======================= V4.8: April 11, 2003 ======================= mscwcs.x Removed changes made on 11/22/02 as they introduced a bug when an image has a "image" coordinate system and valid WCS. (04/11/03, fpierfed) ccdred/src/combine/x_combine.x ccdred/src/combine/fcombine.par ccdred/src/combine/zcombine.par Make aliases for flat and zero combining so that they can have different default parameters. (4/11/03, Valdes) ccdred/src/combine/src/icombine.x Due to the way IMIO works it converts an out of memory error to cannot open pixel file if a memory alloaction error occurs when allocating file descriptor memory. So if this error occurs and the number of images is small the error will be interpreted as a memory allocation error. (4/9/03, Valdes) t_xtalkcor.x ../doc/xtalkcor.hlp The output split or pixel mask filenames may be specified explicitly for all extensions in addition to rootnames. This was added to allow the output to be written to different directories or nodes. (3/13/03, Valdes) ======================= V4.8: March 25, 2003 ======================= t_patfit.x There was a bug in the last change when using block averging and the background is not small. (3/25/03, Valdes) ======================= V4.8: March 14, 2003 ======================= ccdred/src/combine/mkpkg Needed to use the version of xt_pmmap in mscred to pick up the change that the sizes must match as well as the offsets and scales. (3/14/03, Valdes) ccdred/src/combine/t_combine.x There were missing arguments to pl_loadim. (3/14/03, Valdes) pupilfit.par The x and y offset values were limited to positive values. There is no reason for this so the p_min field was cleared. (3/11/03, Valdes) rmfringe.cl rmpupil.cl ../doc/rmfringe.cl ../doc/rmpupil.cl RMFRINGE has new parameters for the block averaging. Both RMFRINGE and RMPUPIL had their help and prompt strings modified to describe the new block averaging feature. t_patfit.x patfit.par patblk.gx + ../doc/patfit.hlp mkpkg The block averaging now applies to the input, pattern, weight, and mask images. (3/11/03, Valdes) mscwcs.x Modified this routine not to complain if there is an "image" coordinate system and not set up the astrometric WCS. (11/22/02, Valdes) ======================= V4.8: November 4, 2002 ======================= setsaturate.x The "saturation?value" parsing had a bug. (10/23/02, Valdes) t_msccmatch.x msccmatch.par Added parameters controling the centroiding and reorganized the epar parameter display. (10/2/02, Valdes) mscimage.cl t_mscpmask.x + mscpmask.par + plp2li.x + mkpkg x_mscred.x ../mscred.cl Added a workaround for a PLIO bug. MSCPMASK is used in MSCIMAGE in place of IMEXPR to convert an image to a mask. The executable is linked static. (9/27/02, Valdes) xtpmmap.x Added a workaround for a bug in pl_l2r$t for the I_PN opcode when the requested region cuts through the segment. (9/18/02, Valdes) xtpmmap.x Added errchk's on im_pmmapo. (9/16/02, Valdes) mscdisplay/src/imexam/iemw.x Added a heuristic check for the appropriate hHmM formats. (9/12/02, Valdes) xtpmmap.x A common case of matching a mask to an image is where the pixel sizes are the same but there are offsets and/or different sizes. An optimized mask matching based on using range lists and not calling mwcs was added. (9/12/02, Valdes) mscdisplay/src/mosmap.x Needed to initialize when there is no DATASEC but there is a DETSEC. (9/11/02, Valdes) xtpmmap.x Updated to current version of xtools$fixpix/. (9/10/02, Valdes) t_mscext.x Did not handle expansion correctly for the first extension when there is an image section. (9/10/02, Valdes) t_xtcoeff.x xtcoeff.par ../doc/xtcoeff.hlp Modified to include victim and source backgrounds and object masks. (9/3/02, Valdes) images$immatch/src/imcombine/src/iclog.x The pixel masks listed in the log output was wrong. This only applies to the log, the correct mask is used during processing. (6/26/02, Valdes) =================== V4.7: June 14, 2002 =================== ccdred/src/combine/src/icsetout.x Needed to disable axis mapping to handle cases where the input images are dimensionally reduced. (6/14/02, Valdes) ccdred/src/combine/src/xtimmap.gx The size of image header data structures was computed incorrectly resulting in the potential for segmenation violations. (6/14/02, Valdes) mscpupil.cl There was a bug in working with single images. (5/31/02, Valdes) ====================== V4.7: May 28, 2002 ====================== ccdred/src/combine/mefscale.x The call to ic_mopen was missing the offsets argument. (5/9/02, Valdes) ccdred/src/combine/src Updated to pick up fixes for projection. (4/22/02, Valdes) msczero.key Removed reference to USNO for the 'u' key. (4/11/02, Valdes) mscagetcat.cl + mscgetcatalog.cl t_getcatalog.x getcatalog.par mkpkg ../mscred.cl ../doc/mscgetcatalog.hlp The catalog access tools now use the ASTCAT package. For backwards compatibility the old catalog names may be used and they are then accessed as before. (4/11/02, Valdes) ccdred/src/combine/src/icmask.x There was a bug in the recent change to open and close masks as needed where a possibly null filename pointer was being checked for being a null string. (4/8/02, Valdes) msccntr.cl Added parameters for specifying the noise parameters. For now this will remain hidden and if users encounter problems they can set the default values. These should eventually become msccmatch parameters. (4/3/02, Valdes) mscimage.cl calproc.cl ccdproc.cl mscnimage.cl mscstack.cl sflatcombine.cl ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl Added default for new "outlimits" parameter in combine. (4/3/02, Valdes) mscztvmark.cl Needed to be updated for a change in the format of the uparm$mscdispN file to include the WCS number. This was not a problem when called from msczero but was a problem when called from msctvmark. (3/29/02, Valdes) ../lib/mscred.dat Removed the line "skyflat skyflat" in the default correction flag translations. (3/28/02, Valdes) ccdred/src/t_ccdlist.x The skyflat correction keyword is "sflatcor" instead of "skyflat". (3/28/02, Valdes/Conroy) ccdred/src/combine/t_combine.x In cmb_images it now uses extension [1] instead of [0] to determine if the file is mef and to get the header keywords which may not be in a global header. (3/28/02, Valdes/Conroy) sflatcombine.cl ccdred/sflatcombine.cl Added "masktype" and "maskvalue" parameters to allow use of object masks when making sky flats. (3/15/02, Valdes) t_xtalkcor.x Needed to add a copy step to create the single image output for extension with no correction when using the split option. (3/11/02, Valdes) rmfringe.cl ../doc/rmfringe.hlp There was a need for a fringe mask because the pupil pattern subtraction affects the derived fringe pattern. (3/7/02, Valdes) ccdred/src/combine/src/icombine.x Added error checks for imunmap of the output files. In the final staage of closing the output if an error occurs, principally in writing mask, this will at least allow the primary combined output image to be written. This is useful when an extremely large combining operation is performed. (3/6/02, Valdes) ccdred/src/combine/src/iclog.x ccdred/src/combine/src/icmask.x ccdred/src/combine/src/icstat.gx Rather than open all the masks at the beginning the masks are now opened and closed as needed. For situations with offsets this can reduce the amount of memory required for the masks. (3/6/02, Valdes) xtmaskname.x Added check for optional "masktype" environment variable with a value of "pl" to force the pl files. (3/1/02, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x mscdisplay/mscdisplay.par mscdisplay/mscrtdisplay.par The maximum frame is now 16 by default but if the task detects the WCS server is the old one and a frame is > 4 it aborts with an error. (2/27/02, Valdes) xtpmmap.x If the bad pixel mask does not exist and the extension name is not found no error was being reported. (2/26/02, Valdes) t_pupilfit.x There was a bug in the earlier fix. (2/25/02, Valdes) ccdproc.cl There was a typo "extlist" instead of "xtlist" when the crosstalk operation was selected but when no crosstalk correction was applied, either because of an error or because the operation was already done. This caused various warning or fatal errors. (2/21/02, Valdes) ccdred$src/combine/t_combine.x An error is no printed if an @file for the scales, zeros, or weights does not contain enough numeric values. (2/19/02, Valdes) ====================== V4.7: January 31, 2002 ====================== mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x Call yt_pmmap instead of xt_pmmap to add extension name to mask name if needed. (2/9/02, Valdes) xtpmmap.x If the specified name fails try adding the extension name of the reference image to the mask name. (2/9/02, Valdes) xtmaskname.x Add "type=mask" only if the mode is not READ_ONLY. (2/9/02, Valdes) ccdred/src/combine/src/ Update for IMCOMBINE changes to allow zero weight combining. (2/9/02, Valdes) ccdred/src/combine/combine.par ccdred/src/combine/mergeamps.par ccdred/src/combine/src/iclog.x ccdred/src/combine/src/icmask.h ccdred/src/combine/src/icmask.x _combine.par mscstack.par Imported IMCOMBINE changes to allow pixel masks in FITS format and to allow the mask keyword to be specified. The parameter changes eliminate the enumerated strings. (2/5/02, Valdes) ../lib/mkpkg.inc ../lib/mkpkg.sf.SSUN + The x_combine.e executable is now linked statically on Solaris. (1/31/02, Valdes) ccdred/src/combine/src/icombine.x ccdred/src/combine/src/icomb.gx ccdred/src/combine/src/xtimmap.gx ccdred/src/combine/src/icombine.h The buffer size management calculation based on the number of input images was no longer working because unless IM_BUFFRAC is explicitly set to 0, the requested buffer size is just a lower limit. The buffer size calculation was modified and calls to set IM_BUFFRAC to zero were added. (1/30/02, Valdes) ccdred/src/combine/src/xtimmap.gx ccdred/src/combine/src/icgdata.gx ccdred/src/combine/src/icomb.gx The code to close unused images when they are not needed had an error when there were y offsets. Rather than closing each image when it not longer contributed to an output line due to an offset, it was instead closing all images on every line and then mapping them again. (1/29/02, Valdes) t_pupilfit.x Fixed bug in setting up points to fit. (1/27/02, Valdes) mkpkg curfit/mkpkg imsurfit/mkpkg ccdred/src/mkpkg ccdred/src/generic/mkpkg mscdisplay/src/mkpkg mscdisplay/src/starfocus/mkpkg mscfinder/mkpkg mscfinder/cdrfits/mkpkg mscfinder/stdcoords.x -> stdcoords.xBAK mscdisplay/src/tile.x -> tile.xBAK mscdisplay/src/t_tile.x -> t_tile.xBAK mscdisplay/src/mittest.x -> mittest.xBAK Check and fixed file dependencies. Renamed .x files that are not used. (1/24/02, Valdes) rmfringe.cl + rmpupil.cl + doc/rmfringe.hlp + doc/rmpupil.hlp + ../mscred.cl ../mscred.men ../mscred.hd New non-interactive versions of the fringe and pupil removal tasks based on the PATFIT tasks. (1/22/02, Valdes) t_patfit.x + mapio.x + mim.x + mgs.x + patfit.par + doc/patfit.hlp + x_mscred.x mkpkg ../mscred.cl ../mscred.men ../mscred.hd New task PATFIT added. This depends on a set of "map I/O" routines for allowing reduced size images and constants as images. (1/22/02, Valdes) rmfringe.cl -> irmfringe.cl rmpupil.cl -> irmpupil.cl ../mscred.cl ../mscred.men Renamed the interactive fringe and pupil removal tasks. (1/22/02, Valdes) t_pupilfit.x mscpupil.cl pupilfit.par mscpupil.par Added new "mask" output type. (1/14/02, Valdes) xtmaskname.x + mkpkg Added new procedure for making mask names in either pl or fits format. This checks to see if the FITS kernel source code supports FITS format so that the routine will work with versions before V2.12. (1/14/02, Valdes) ======================= V4.6: December 7, 2001 ======================= ../lib/mkmsc/quad.dat + ../lib/mkmsc/fors.dat + ../lib/mkmsc/keck.dat + Sample description files for MKMSC. (12/7/01, Valdes) t_mkmsc.x + mkmsc.par + ../doc/mkmsc.hlp + ccdsection.x + x_mscred.x mkpkg ../mscred.cl ../mscred.hd ../mscred.men Added new task for converting multiamp/multiccd data in flat image format to multiextension format suitable for use with MSCRED. This is useful for CTIO quad and ESO FORS data. (12/7/01, Valdes) ======================= V4.6: December 4, 2001 ======================= ccdred/src/combine/src/icscale.x Fixed a bug with the normalization. (12/4/01, Valdes) ======================= V4.6: November 29, 2001 ======================= t_msccmatch.x 1. The centering by msccntr now returns the centering uncertainties (xerr and yerr). Uncertainties in radius (sqrt(xerr**2+yerr**2) more than 0.1 pixel are excluded to eliminate coordinates not near an object. 2. If the number of centered coordinates is less than half the total candidates then the task is considered to have failed to find the offset. 3. If more than half of the candidate in bounds search positions contain masked pixels then all the regions are used regardless of bad pixels. This is to allow use of large coarse search boxes and bad pixel masks in the fine centering. 4. The vote array centroid weighting is now the number of votes above the minimum, rather than the actual votes. This is important with large search boxes where a few outliers can significantly affect the centroid. 5. There was an error when not using a BPM. If the the coarse search needed to be repeated because of being too close to the search box edge new boxes were not read resulting in an infinite loop. 6. "ERROR: MSCCMATCH failed for " is now printed upon a failure. 7. The verbose output was extended to give both the number of failures and the total candidates for out of bounds, masked, and centered. 8. The header keyword MSCCMATC is added when the WCS is updated. The value is the time the shifts, scales, and rotations. (11/29/01, Valdes) msccntr.cl 1. Changed default cbox value to 11. 2. Now returns xerr and yerr. (11/29/01, Valdes) ccdproc.cl Added new parameter "split" to select use of split images during processing. (11/29/01, Valdes) t_xtalkcor.x ../doc/xtalkcor.hlp ccdproc.cl calproc.cl Added new parameter "split" to allow output to separate images. This saves time in building the final MEF file. CCDPROC and CALPROC were just modified to set split=no in the call to XTALKCOR. (9/13/01, Valdes) ================================== V4.6: September 5, 2001 (internal) ================================== mscdisplay/src/mosmap.x If there is no DETSEC but there is a WCS the DETSEC is computed from the WCS. (9/5/01, Valdes) ../mscred/mscred.cl ccdred/x_ccdred.x ccdred/mkpkg ccdred/src/mkpkg ccdred/src/combine ccdred/src/generic/mkpkg ccdred/src/combine: ccdred/src/combine/x_combine.x ccdred/src/combine/combine.par ccdred/src/combine/mergeamps.par ccdred/src/combine/icmefscale.x ccdred/src/combine/icombine.x ccdred/src/combine/mkpkg + ccdred/src/combine/t_combine.x ccdred/src/combine/src + 1. CCDRED executable divided into one for COMBINE and one for the rest. 2. COMBINE source moved to new directory. 3. COMBINE revised to use a common src directory with IMCOMBINE. (8/29/01, Valdes) ================================ V4.5: August 16, 2001 (internal) ================================ mscdisplay/mkpkg mscdisplay/imdwcsver.x src/t_mscdisplay.x src/t_mscrtdisp.x src/mosmap.x src/moscoords.x + src/mkpkg src/imexam/iegcur.x src/starfocus/t_starfocus.x msczero.cl Changes to support multiple WCS mappings in the display server. The mkpkg checks if pkg$images/tv/display/imdwcsver.x exists and if it doesn't it uses dummy routines. (8/16/01, Valdes) ../doc/installation.hlp Modified to handle case where the user builds the executables. (8/3/01, Valdes) t_jlists.x imtopen called with an extra argument. (7/17/01, Valdes) t_xtalkcor.x strcopy missing len argument. (7/17/01, Valdes) ../mscred.hd ../doc/ccdlist.hlp Added new help page. (7/3/01, Valdes) ccdred/src/xtprocid.x gpatmatch called as subroutine but should be an int function. (7/17/01, Valdes) ccdred/src/readcor.x ccdred/src/scancor.x Incorrect arguments for set_output. Since these routines are not used for mosaic data replace with an error statement for now. (7/17/01, Valdes) ccdred/src/setsaturate.x Replace pargr with pargi when used with SATGROW. (7/17/01, Valdes) ccdred/src/proc.gx ccdred/src/t_bleed.x Calls to bld_open were wrong. (7/17/01, Valdes) ../doc/ccdlist.hlp + ../mscred.hd Added a help page for CCDLIST. (7/3/01, Valdes) ============================== V4.5: June 16, 2001 (internal) ============================== ichdr.x The input procids and image names are only written to the output if there are less than 99 input images. (6/16/01, Valdes) ccdred/src/xtimmap.x + ccdred/src/icgdata.gx ccdred/src/icombine.gx ccdred/src/icscale.x ccdred/src/t_combine.x ccdred/src/mkpkg Modified to use xtimmap to control the large number of images. (6/16/01) ccdred/src/ccdtypes.x The ccdstr procedure that encodes the CCD type did not have a case for a sky flat. This means that the processing types output for use with calproc in mosaic data would not identify sky flats needing processing as sky flats leading to the possiblity of trying to apply a sky flat to the sky flat with the resulting error that the input is the same as calibration. (6/11/01, Valdes) ccdproc.cl calproc.cl If no output bad pixel mask then there will be no output merged mask. (5/25/01, Valdes) ================= V4.5: May 4, 2001 ================= t_msctmplt.x The combining of wterm and lterm was potentially incorrect because of the way in-place operations were done. (4/27/01, Valdes) mscdisplay/src/mosmap.x The calculation of the binning factor when there is no header information did not take the size of the bias section, which does no bin, into account. (3/27/01, Valdes) mscdisplay/src/t_mscdisplay.x There was an nint error in computing wipix limits in mos_params resulting in trimming one extra column in the display. (3/22/01, Valdes) ccdred/src/icscale.x An error in normalizing the scales and means was fixed. (3/20/01, Valdes) ccdproc.cl calproc.cl Modified to handle merging of the masks. (3/15/01, Valdes) t_combine.x mergeamps.par The T_AMPMERGE procedure was revised to call a new routine, MASKMERGE, to merge pixel masks using physical coordinate registration. A mask is produced if there is more than one mask from the set of the mask produced during combining and unique input masks. Empty masks are ignored. If there is no mask data or all are the same then the BPM keyword is unset or set to the common mask. When there is more than one mask an output mask is the computed as the maximum value from all the masks. The output mask name is specified by the new "outmasks" parameter. Currently this is a directory where entries bpmm_.pl are created. (3/15/01, Valdes) t_msccmatch.x msccntr.cl + ../mscred.cl 1. The centroiding step was changed to use the new script task MSCCNTR. This script fixes all the parameters so there is no need for MSCCPARS and MSCDPARS. It calls TXDUMP to extract the fields to avoid problems with parsing the database format in MSCCMATCH. 2. The centering box size is now fixed at 5 pixels instead of something based on the "maxshift" parameter. 3. The various keywords for exposure time, gain, etc. are now not used. (3/14/01, Valdes) t_msccmatch.x Converted from using imextensions to mscextensions to allow use of this task with single images. Also added an error check for no input images to avoid a potential divide by zero. (3/13/01, Valdes) ccdproc.cl calproc.cl _ccdtool.par Updated for new bleed trail parameters. (3/13/01, Valdes) ccdred/src/bleed.x + ccdred/src/bleed.com + ccdred/src/t_bleed.x + ccdred/src/setinmask.x + ccdred/src/setsaturate.x + ccdred/src/proc.gx ccdred/src/setproc.x ccdred/src/setheader.x ccdred/src/ccdproc.x ccdred/src/ccdcheck.x ccdred/src/setoutput.x ccdred/src/setbpmask.x ccdred/src/setfixpix.x ccdred/src/t_ccdproc.x ccdred/src/ccdred.h ccdred/src/mkpkg ccdred/ccdproc.par 1. New parameters "sgrow", "bleed", "btrail", and "bgrow". 2. New algorithm to find and grow saturated pixels and bleed trails. 3. Saturated and bleed pixels may be added to an output mask. 4. Saturated and bleed pixel may be "fixed" in the data. 5. If no input bad pixel mask is given it is treated as an empty mask. (3/13/01, Valdes) calimage.x The input bad pixel mask is not required to match by amplifier and CCD when it is specified by a header keyword. (3/13/01, Valdes) =================== V4.4: March 6, 2001 =================== ccdred/src/setheader.x The check on a flip between target and calibration is not done. (3/6/01, Valdes) msczero.cl mscztvmark.cl Changes to make these tasks work with CFH12K headers where there is no TRIMSEC and DATASEC is flipped. (3/5/01, Valdes) ccdred/src/t_combine.x The rejection masks now have the WCS updated for the extra dimension. Also the MASKiiii keywords are not needed since the IMCMB keywords will identify the input images. (3/1/00, Valdes) ccdred/src/icsetout.x Modified to reset physical coordinates. (2/28/00, Valdes) t_msctmplt.x Fixed bug where the RA/DEC were not updated when a reference image is used to set the other parameters. (2/28/01, Valdes) mscimage.cl Increased the precision of the RA/DEC output and changed the GEOMAP function from polynomial to chebyshev. (2/28/01, Valdes) ccdred/coutput.par There was a misformating problem in this parameter file. (2/27/01, Valdes) ======================= V4.3: February 23, 2001 For the Feb 23 export version mscimage was restored to the old version. ======================= mscimage.cl mscimage.par 1. The defaults nxblock and nyblock is INDEF and then they are set to the output image size in GEOTRAN. 2. Minor changes if pixmask=no. (2/22/01, Valdes) t_imstat.x Replaced using MIO with lower pixel mask I/O for efficiency and to workaround a problem with image sections. (2/21/01, Valdes) mscimage.cl mscimage.par mscoimage.cl + mscoimage.par + ../mscred.cl Old version of mscimage renamed to mscoimage. New version installed as mscimage. (2/20/01, Valdes) t_msctmplt.x mscwtemplate.par + x_mscred.x ../mscred.cl Added new hidden task mscwtemplate. (2/16/01, Valdes) t_imstat.x An error in initializing the region vectors during the histogram step was fixed. (2/12/01, Valdes) rmfringe.cl The default extname pattern was wrong. Change to "" to selected all extensions. (2/10/01, Valdes) mscmedian.cl mscmedian.par msctmp1.cl msctmp1.par ../mscred.cl ../mscred.men Added new task MSCMEDIAN. (2/10/01, Valdes) t_jlists.x joinlists.par mkpkg x_mscred.x ../mscred.cl Added new hidden task JOINLISTS. (2/10/01, Valdes) ccdred/src/t_combine.x There was no error checking when opening files in cmb_images. (2/9/01, Valdes) ====================== V4.3: February 8, 2001 ====================== ccdproc.cl calproc.cl When merge=yes and no merging is needed and if a previous image was already processed the previously processed image will be clobbered. (2/8/01, Valdes) mscfinder/t_tpeak.x mscfinder/msctpeak.cl The display fill option was being set in msctpeak by updating the user's default parameters. Now when TPEAK issues the display command it sets the fill parameter on the command line leaving the user's default parameter unchanged. TPEAK has a new parameter, fill, to control this and MSCTPEAK does not touch it to allow possible control of the fill option in this hidden task though I can't think of why the fill option would not be used. (2/8/01, Valdes) setsections.x There was still error in calculating the size of the sections when comparing CCDSEC between the input and the calibration in the case of flipping and binning. (1/30/01, Valdes) mscsetwcs.cl Added the translit step to eliminate quotes when getting the RA and DEC and the keyword values have whitespace. (2/5/01, Valdes) ccdred/src/setheader.x CCDPROC now calls xt_procid to create or update the PROCID keyword. (2/5/01, Valdes) mscstack.cl mscstack.par The new optional combine outputs are available through the new parameters "headers", "bpmasks", "rejmasks", "nrejmasks", "expmasks", "sigmas". (2/5/01, Valdes) ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl sflatcombine.cl calproc.cl ccdproc.cl Updated to explicitly pass null strings for the new optional combine/mergeamps output. (2/5/01, Valdes) ccdred/src/t_combine.x ccdred/src/icombine.gx ccdred/src/icscale.x ccdred/src/iclog.x ccdred/src/icemask.x + ccdred/src/ichdr.x + ccdred/src/xtprocid.x + ccdred/src/mkpkg ccdred/combine.par ccdred/coutput.par ccdred/mergeamps.par _combine.par 1. New output parameters added: "headers", "bpmasks", "rejmasks", "nrejmasks", "expmasks", "sigmas". 2. Old output parameters removed: "plfile", "rejmask", "sigma". 3. Dataless extensions of the input headers are recorded in the optional output FITS MEF files specified by the "headers" parameter. 4. Bad pixel masks with 0 for data and 1 for no data are recorded in the optional output masks specified by the "bpmasks" parameter. The output header contains the keyword BPM pointing to the mask. 5. Masks with the number of pixels rejected are now specified by the parameter "nrejmasks" instead of "plfile". 6. Exposure masks, which are the sum of the exposure times of the data combined, are recorded in the optional output masks specified by "expmasks". 7. The input data is scaled to the first input image and the output header is a copy of the first input image. 8. The exposure time and dark time keywords are no longer modified from the input times. The output will just contain a copy of the times from the first input image header. 9. The keyword NCOMBINE, PROCID, PROCIDnn, and IMCMBnnn are added modified or added to the output. 10. The log output includes the names the extra output files if specified. (2/5/01, Valdes) ccdred/src/icgrow.gx Added a step to periodically compress the masks. (2/2/01, Valdes) xtpmmap.x Updated to allow '^' to be used to invert a mask. (2/1/01, Valdes) mscfindgain.cl The script did not actually pass on the mask to ximstat. (2/1/01, Valdes) t_imstat.x Fixed a couple of bugs. (2/1/01, Valdes) ====================== V4.2: January 30, 2001 ====================== setsections.x There was an error in calculating the size of the sections when comparing CCDSEC between the input and the calibration. (1/30/01, Valdes) ccdred/src/ccdred.h Increased length of log strings to 199. This is to avoid String_File errors when the filenames are too long. (1/16/01, Valdes) ccdred/src/proc.gx Since pixel mask values of 2 and 3 are used for defining interpolation directions the saturated pixels are now identified by the value 4. Also, previously bad pixels were converted to the value 1 now the input bad pixels are not changed. (1/10/01, Valdes) t_xtcoeff.x Now deals with relative amplifier flips. (1/9/01, Valdes) ../mscred.cl ../mscred.men XTALKCOR is no longer a hidden task. (1/9/01, Valdes) ============================================= V4.1: January 6, 2001 : MDHS internal release ============================================= ccdproc.cl calproc.cl Made merge=yes the default. With the change to MERGEAMPS to check when there are not multiple amps to merge this is a safe default. (1/5/01, Valdes) t_combine.x Added check for just a single image to combine. This is used by MERGEAMPS to avoid merging when not necessary. (1/5/01, Valdes) t_xtalkcor.x + xtalk.gx + xtalkcor.par + doc/xtalkcor.hlp x_mscred.x mkpkg ../mscred.cl New version of crosstalk correction which supports multiple source amplifiers affecting a target amplifier. This is a compiled task which is optimized for this operation. (1/5/01, Valdes) ccdred/src/ccdamps.x When getting the amp or ccdname logical keywords try imageid followed by extname if no value is found. (12/28/00, Valdes) ccdproc.cl The default saturation was not quoted so it appears as a null string instead of INDEF. (12/20/00, Valdes) ccdproc.cl If the bpmask directory name matches the input name, for example obj092, then when the final imrename is called the temporary file ends up in the bpmask directory. This has been fixed by detecting this case and appending _bpm to the bpmask directory name. (12/15/00, Valdes) ======================== V4.1: December 14, 2000 ======================== ccdproc.cl _ccdtool.par ccdred/ccdproc.cl ccdred/src/setbpmask.x The parameter syntax for the saturation parameter is now two words. If the first word is a number that is the saturation value otherwise it is a keyword (either with or without a leading !). The second word is either ADUs or electrons. If it is missing then it defaults to ADUs. (12/14/00, Valdes) msczero.cl mscztvmark.cl More work to support flips and trims. (12/14/00, Valdes) ======================== V4.1: December 13, 2000 ======================== msctest - Removed this internal development test directory. (12/30/00, Valdes) ccdproc.cl calproc.cl Added a flpr after ccdtool to workaround a memory leak with masks. This can be removed with the next release of IRAF. (12/30/00, Valdes) ccdred/src/setfixpix.x ccdred/src/setproc.x ccdred/src/calimage.x Modified to use yt_pmunmap instead of imunmap in order to free the pl pointer. (12/13/00, Valdes) xtpmmap.x A version that contains yt_pmunmap for use until the next release of IRAF xtools includes xt_pmunmap. (12/13/00, Valdes) ======================== V4.1: December 7, 2000 ======================== mscfinder$msctpeak.cl The parsing of the reference point from the RA/DEC keywords would fail if there were blanks in the string representation of the sexigesimal values. This results in an error about coercing `' to string. This has now been fixed. (12/7/00, Valdes) ccdproc.cl calproc.cl The proper handling of the CCDMEAN/CCDMEANT keywords was not being done. Now the CCDMEAN/CCDMEANT keywords are deleted from all the extensions and the average of the CCDMEAN keywords is written to the global header. (12/7/00, Valdes) ======================== V4.1: December 5, 2000 ======================== mscfindgain.cl Modified to use XIMSTAT, thus allowing use of masks and sigma clipping. The script no longer calls nproto.findgain but includes all the code itself. The output format was improved. (12/5/00, Valdes) t_imstat.x ximstat.par x_mscred.x ../mscred.cl A version of IMSTAT, called XIMSTAT, that supports masks and sigma clipping was added as a hidden task. (12/5/00, Valdes) mosmap.x When there is binning and flips the step size was computed wrong because of a max statement that assumed the step size is positive. (12/5/00, Valdes) msczero.cl Added support for flipped extensions when creating the WCS dummy image. The task will still fail if there is a TRIMSEC for flipped extensions. (11/20/00, Valdes) mscimage.cl Added a missing return in a warning statement. (11/6/00, Valdes) ======================== V4.1: October 2, 2000 ======================== calproc.cl A default value for bpmasks was not set in the call to _ccdtool. (9/30/00, Valdes) t_msccmatch.x When collecting the brightest objects for the coarse search the regions going off an edge were excluded but not replaced with the next fainter object. For large search size this meant that significantly few object than the specified would be used resulting in a greater likelihood of failure. The algorithm now uses the specified number that pass all the checks. (9/27/00, Valdes) t_msccmatch.x If an error occurs in getting the coordinates an sfree is called without an smark. The smark was moved to before the possible error condition. (9/27/00, Valdes) ../lib/strip Added a strip file. (9/26/00, Valdes) t_imext.x Added logic to recognize an input specifications which has an explict extension as a single image. Previously an infinite loop would result. (9/26/00, Valdes) ccdproc/src/t_combine.x Modified the conversion of pclip from a fraction to a number of images because for even number of images the number above/below the median is one too small. (9/26/00, Valdes) mscztvmark.cl There is a commented out section for rotating the coordinates which is useful for debugging. (9/21/00, Valdes) mscjoin.cl The warning when _0 or _1 are not accessible was made more explicit. (9/20/00, Valdes) ======================== V4.1: September 20, 2000 ======================== mscfinder/tpltsol.cl 1. If the number of sources is less than 3 a message is printed. 2. If the number of sources is less than 6 an rxyscale solution is done. 3. The solution name is now set if extname is not present. (9/20/00, Valdes) mscfinder/msctpeak.cl Added "No images found" message. (9/20/00, Valdes) mscsetwcs.cl Changed to use mscextensions instead of imextensions. (9/18/00, Valdes) ======================== V4.1: September 15, 2000 ======================== t_imext.x Added a special check for the extname pattern "*" which was going into an infinite loop. The pattern "*" by itself is considered to match all extensions names including no extension name. (9/15/00, Valdes) mscfinder/msctpeak.cl mscfinder/tvmark_.par mscfinder/t_tpeak.x 1. An fseti call to CLIN was necessary to avoid an error when returning from the plate solution step if the user does '?'. 2. The dictionary string for the ":epar" command was truncated for some reason. 3. msctpeak.cl was changed to not always set the default marking radius. Instead the default is set in tvmark_.par. (9/15/00, Valdes) ccdred/src/t_combine.x ccdred/src/icimstack.x Error handling when running out of memory with immap (due to a very large min_lenuserarea) and when trying to stack was fixed up to report reasonable error messages and to not go into an infinite loop trying to manage memory. (9/13/00, Valdes) ccdred/src/iccombine.gx ccdred/src/icgdata.gx Additional errchk declarations were needed to catch out of memory during image reading which were not caught during the initial pass at reading the images. (9/11/00, Valdes) t_msccmatch.x The DEGTORAD macro in a min statement caused a mismatched types error on the Alpha. Explict type casts were added. (9/11/00, Valdes) ../mscred.men MSCSETWCS was not included in the list of tasks. (9/11/00, Valdes) mscpupil.cl If the input file does not exist there is now an error message rather than an obsure error about accessing undefined local variable. (9/8/00, Valdes) ==== V4.1 ==== ccdproc.cl calproc.cl Changed the error behavior back to the original abort in ccdtool; i.e. onerror="exit" changed to onerror="original". (9/7/00, Valdes) mscimage.hlp Help page updated. (9/6/00, Valdes) mscimage.cl Changed to use mscextensions instead of imextensions so that it would work with single images. (9/6/00, Valdes) msczero.cl The when 'x' or other keys that mark positions on the display were used it would print the label "1" (the line number in the input list) for all sources even though no label is defined. This was fixed to check if a there is actually a label. (9/6/00, Valdes) mscfinder/msctpeak.cl 1. Changed to use mscextensions instead of imextensions so that it would work with single images. 2. The extname parameter was not initialized to "". (9/6/00, Valdes) mscdisplay/src/t_mscdisplay.x Fixed an off-by-one error in WCS sent to the display when the display buffer is smaller than the image. This is the same error fixed in tv$display/t_display.x. (9/5/00, Valdes) msczero.cl Added a cbox parameter to set the centering box size. (9/5/00, Valdes) mscdisplay/src/imexam/t_imexam.x mscdisplay/src/imexam/timexam.x + mscdisplay/src/imexam/iecolon.x mscdisplay/src/imexam/mkpkg mscdisplay/mscexamine.par lib/scr/imexamine.key Added new key 't' to ouput an image section centered on the cursor. (9/2/00, Valdes) t_combine.x If an error occurs in mapping an image at an early stage it was possible to get into an infinite loop. (9/1/00, Valdes) t_combine.x When there is an error with an MEF image then the error recovery to delete the image would fail since you can't delete an extension. Added a higher level step in mefcombine to delete the output in the case of an error (8/30/00, Valdes) mscimage.cl mscimage.par 1. The ntrim parameter was changed to apply the trim to the input rather than the output. This has the effect of masking the specified number of edge pixels in the output mask even with rotations. 2. The boundary extension was added as parameters "boundary" and "constant". The default was changed from constant with value blank to reflect. (8/29/00, Valdes) t_msccmatch.x t_mscimatch.x t_mscwcs.x ccdred/src/ccdcheck.x ccdred/src/readcor.x ccdred/src/scancor.x ccdred/src/setfixpix.x Various minor changes and typo fixes found with spplint. (8/23/00, Valdes) mscjoin.cl To work around a problem with V2.11.3p1 the primary header is now referenced with [0]. (8/22/00, Valdes) ==== V4.0 ==== xtalkcor.cl If the crosstalk coefficient file has two extensions but no coefficients it behaves in the same way as with just one extension; i.e. no correction to the victim. Also if the coefficients are zero it only copies the victim. (8/22/00, Valdes) t_msccmatch.x The output coordinates now exclude those which failed to center. Also the coarse search is only done if nsearch>0 and search>0. (8/21/00, Valdes) ../mscred.cl 1. Hide dispsnap. 2. Hide mscpipeline. 3. Hide mscqphot. 4. Hide pixarea. 4. Hide msctoshort. (8/21/00, Valdes) ccdred/src/imcombine/t_combine.x ccdred/src/imcombine/icimstack.x ccdred/src/imcombine/iclog.x When there are a large number of images with bad pixel masks both the input images and the bad pixel masks are stacked for combining. The addition of stacking the masks allows for independent bad pixel masks for each input image which was not supported previously. (6/21/00, Valdes, 8/21/00 Valdes) xtcoeff.x + xtcoeff.par + ../doc/xtcoeff.hlp + mkpkg ../mscred.cl ../mscred.men ../mscred.hd ../lib/xtcoeff/ + Added new task to compute crosstalk coefficients. (8/18/00, Valdes) mscrfits.cl mscwfits.cl The call to fitscopy was changed to mscred.fitscopy to avoid a conflict if the ttools or fitsion packages are loaded. (8/15/00, Valdes) t_getcatalog.x The idea that the field center is given by the tangent point is not good for resampled images where the target WCS is well off the individual exposure. The task was modified to compute the midpoint of the extreme corners in arcsec from the tangent point and then use that for the field center and the computation of the radius enclosing the image(s). (8/15/00, Valdes) mscfindgain.cl ../mscred.cl New task for finding the gain and readnoise from mosaic exposures. This uses nproto.findgain. (8/14/00, Valdes) ccdred/src/imcombine/t_combine.x ccdred/src/imcombine/icscale.x For MEF data there was no error check on the statistics calculation. If a bad pixel mask (or thresholds) excluded all the pixels in the section then a segmentation error would result rather than an error message. An errchk was added. Also the scaling computation was moved to before the output header is created to avoid an image being left behind in case of an error. (7/31/00, Valdes) t_pupilfit.x The lmedian option divides the image by the line medians. The missing step was to mulitply back by the mean. (7/14/00, Valdes) t_mscwcs.x The routine to adjust the WCS by refitting after applying a low order correction (shift, rotation, scale) would shift the pixel position of the tangent point to keep the old coordinate reference point the same. This was changed to make the coordinate reference point be that after applying the low order correction. This has the effect of making the pixel position of the tangent point be nearly unchanged (it does change a small amount because of the degree of freedom in the ccmap fitting). Without this change the tangent point would move hundreds of pixels (depending on the zero point error) which affected the pupil fitting center, while with the change the tangent point moves only a few to 10 pixels (for the NOAO Mosaic I WCS and zero point shifts of order 30 arc seconds). (7/7/00, Valdes) mscarith.cl With "noact = yes" the output list was not generated and then the error about wrong number of elements in the operand lists would occur. (6/13/00, Valdes) mscdisplay/src/mosmap.x Added a minimum value for DX/DY. This would produce 0 in cases where the header keywords were wrong leading to a floating divide by zero error. (5/10/00, Valdes) mscztvmark.cl Added a check for scanning the right number of columns. (5/10/00, Valdes) t_msccmatch.x msccmatch.par The coordinate file can now be specified as a command to generate the file. (4/27/00, Valdes) msczero.cl mscztvmark.cl Fixed problems with working with untrimmed exposures. (4/27/00, Valdes) t_pupilfit.x pupilfit.par mscpupil.cl mscpupil.par 1. Added lmedian parameter to allow taking a median of each line prior to fitting the pupil. 2. Changed default 'sorder' parameter. 3. Added 'sorder' fixed to a value of 1 in the calls to pupilfit in mscpupil. 4. Made some minor changes to pupilfit. (4/27/00, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrdisp.x The title was being sent to the display server with a newline which causes readback of the WCS to fail. The newline was removed. (4/27/00, Valdes) mscsetwcs.cl The WCSSOL keyword is now deleted if needed. (4/19/00, Valdes) ccsetwcs.x The replacement of the tangent point from the image into the database solution was not working. So the WCSSOL coordinate system would always be that of the database rather than the image. (4/19/00, Valdes) msczero.cl msczero.key 1. Added "updcoord" and "mark" parameters. 2. Renamed "mark" parameter to "mtype". 3. Added keys 'e' and 'i' to MSCZERO. 4. Reorganize script. 5. Added marking on display with using various keys. (4/10/00, Valdes) mscztvmark.cl Added a column to the returned file with the line number from the original coordinate file. (4/10/00, Valdes) t_imext.x An "extname" pattern that is only whitespace matches all extensions. (4/6/00, Valdes) msczero.cl msczero.key 1. Added MSCTVMARK parameters. 2. Added 's' key. 3. Added "id" query parameter. 4. Now uses a temporary WCS image so that new coordinates and marking will use the current zero point. 5. Added 'u' key to access the USNO catalog with MSCGETCATALOG. A magnitude query parameter "mag" was added to limit the magnitudes. (3/31/00, Valdes) t_getcatalog.x getcatalog.par mscgetcatalog.cl Added "magmin" and "magmax" parameters. (3/31/00, Valdes) msctvmark.cl This simply calls MSCZTVMARK with the mosaic geometry file created by MSCDISPLAY. 1. Added a "fields" parameter to allow selecting the fields which have the RA, DEC, and ID values. 2. Added "output" parameter to allow saving the file used by TVMARK. This also includes the mosaic display pixel coordinates. The output file consists of x, y, id, ra, dec. (3/31/00, Valdes) mscztvmark.cl ../mscred.cl This is what used to be MSCTVMARK. 1. Added a "fields" parameter to allow selecting the fields which have the RA, DEC, and ID values. 2. Added "output" parameter to allow saving the file used by TVMARK. This also includes the mosaic display pixel coordinates. The output file consists of x, y, id, ra, dec. 3. Added "mscdisp" parameter which is the mosaic geometry file created either by MSCDISPLAY or MSCZERO. (3/31/00, Valdes) t_msccmatch.x msccmatch.par The "reject" parameter from CCMAP was added as a user parameter. (3/3/00, Valdes) t_msctmplt.x Added special case for ZPX. (3/2/00, Valdes) mscwcs.x The astrometry coordinate system is now always "tan" projection regardless of the input projection. (3/2/00, Valdes) t_getcatalog.x getcatalog.par mscgetcatalog.par Added another catalog, the USNO catalog at CADC. (3/2/00, Valdes) calproc.cl ccdproc.cl mscarith.cl msccmd.cl Put explicit verbose- in imrename calls. (2/17/00, Valdes) ../mscred.cl Commented out the immatchx loading. (2/15/00, Valdes) t_fitscopy.x The error checking of awaitb was not being done correctly. (2/9/00, Valdes) mscsplit.cl Minor change to allow extname to be undefined. (1/26/00, Valdes) mscdisplay/src/starfocus/rngranges. Modified to fix a repeat with no exit. (1/24/00, Valdes) ccdred/src/icsetout.x Fixed error with MWCS dimension mismatch when using offsets on input images which have been dimensionally reduced. (1/12/00, Valdes) ../mscred.cl Added mscstatus variable. (12/20/99, Valdes) t_msccmatch.x msccmatch.par Added parameters to control listing of coordinates, graphics, and cursor input. If interactive fit is enabled then either interactive has to be enabled or a cursor input file has to be given. (12/20/99, Valdes) cccdred/src/calimage.x Will now print error message from xt_pmmap to explain why a bad pixel mask was not found. (12/17/99, Valdes) rmpupil.cl 1. The automatic scaling now uses abin=360. in pupilfit to avoid problems with wild edge values. 2. The default if the automatic scaling is undefined or negative is set to 1 for difference and 0.0001 for ratio. (12/16/99, Valdes) t_pupilfit.x Did more to insure a reasonable number of points in each radial fit. (12/16/99, Valdes) t_fitscopy.x The filename root procedure was being called on the header filenames which already have the image extension root removed. This means that names with '.' other than in the image extension will be stripped during reading. (12/16/99, Valdes) t_mscrtdisp.x Added change for displaying with no interpolation. (12/14/99, Valdes) ccdred/src/icmm.gx This routine was not returning a sorted list for use with growing. (12/7/99, Valdes) setsections.x There was an error in calculating the size of the sections when comparing CCDSEC between the input and the calibration. (12/3/99, Valdes) t_msctmplt.x Fixed bug introduced when converting to using astrometry coordinates. (12/2/99, Valdes) rmpupil.cl rmfringe.cl Modified to default to all extensions if the extension name list is not understood. (11/22/99, Valdes) rmpupil.cl Modified to do block averaging even in non-interactive mode to make the fit go faster. (11/22/99, Valdes) t_pupilfit.x There were some conditions where the number of points to fit would be negative leading to a salloc underflow error. Modified code to handling this situation. (11/22/99, Valdes) t_msccmatch.x msccmatch.par Made additions to search for a rotation as well as shift. (11/22/99, Valdes) t_msccmatch.x If interactive then don't use the rms test and let the user decide. (11/20/99, Valdes) t_mscwcs.x Added msc_wcsstatd parameters for crpix1 and crpix2. (11/20/99, Valdes) t_mscwcs.x The change that allowed a primary image to be used would cause a MWCS dismension mismatch error for MEF files with an empty primary image. This error is now trapped and the task continues on to the first extension. (11/20/99, Valdes) ccdred/src/imcombine/icombine.gx An input array was declared with a value of 3 though it was passed to the routine with 4 elements. Later there was a reference to the 4th element. While this is legal as the size in the declaration is a dummy this was a compiler error on one platform. Changed the declaration to 4. (11/19/99, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/sigm2.gx The "fill" parameter now has a function. If fill=no then the full mosaic will be displayed at the nearest blocking factor that fits the screen. If fill=yes then in addition to the blocking the mosaic is interpolated to fill the frame buffer in at least one dimension. (11/17/99, Valdes) mscdisplay/mimpars.par Changed the exttmplt parameter to match the output of MSCSPLIT. (11/16/99, Valdes) mscsplit.cl mscjoin.cl ../doc/mscsplit.hlp ../doc/mscjoin.hlp ../mscred.cl ../mscred.men ../mscred.hd Added new tasks to split and join MEF files. (11/16/99, Valdes) rmfringe.cl rmpupil.cl Changed default extension name in RMFRINGE and added a check and warning if the extension list expands to no images in both tasks. (11/15/99, Valdes) ccdproc.cl calproc.cl Added msstatus and onerror features. (11/5/99, Valdes) ccdred/src/ccdproc.x Modified to make errors in the setup be warnings. (11/4/99, Valdes) mscdisplay/src/t_mscrtdisp.x Changed the backup to 25 lines instead of 5 lines. (11/4/99, Valdes) t_mscimatch.x The way the sky was handled with dozero=no was incorrect resulting in incorrect sky values. (11/1/99, Valdes) mscimage.cl Delete NEXTEND, DETSEC, CCDSEC, AMPSEC, IMAGEID, DATASEC, TRIMSEC, and BIASSEC, from the output single image. (10/29/99, Valdes) mscsetwcs.cl 1. Now will add WCSASTRM information if given in the database file. 2. Will log to logfile if one is specified by the package. (10/27/99, Valdes) dispsnap.cl + ../mscred.cl New task to load and snap the display to an export format. (10/26/99, Valdes) t_xlog.x + xlog.par + x_mscred.x mkpkg ../mscred.cl New logging subroutine package and task interface. (10/20/99, Valdes) t_mscwcs.x Now allows working with a simple primary image. (10/25/99, Valdes) ccdred/src/t_combine.x Added workaround for error recovery when the error string is lost. (10/21/99, Valdes) mkpkg The default update and build no longer includes MSCFINDER. If this is desired it must be built separately. (10/19/99, Valdes) mscfinder/cdrfits/fits_read.x mscfinder/cdrfits/fits_rimage.x mscfinder/cdrfits/ftb_gtsub.x mscfinder/cdrfits/ftb_rheader.x mscfinder/mkpkg The latest TABLES release moved the previous gf_ calls to gi_ and the new gf_ calls are for use with CFITSIO. To adjust for this change the gf_ calls have to be changed to gi_. (10/19/99, Valdes) mscdisplay/src/mosmap.x Modifications to allow the CCDs to be in different orders when calculating the gaps. (10/19/99, Valdes) mscdisplay/src/mscg.gx There was a typo in the mscgs2$t routines that caused on the fly processing to fail. (10/14/99, Valdes) rmpupil.cl rmfringe.cl Added feature to allow changing block size in program. (10/12/99, Valdes) ccdred/src/setbpmask.x + ccdred/src/calimage.x ccdred/src/ccdcache.x ccdred/src/ccdcheck.x ccdred/src/ccdproc.x ccdred/src/ccdred.h ccdred/src/mkpkg ccdred/src/proc.gx ccdred/src/setdark.x ccdred/src/setflat.x ccdred/src/setheader.x ccdred/src/setoutput.x ccdred/src/setproc.x ccdred/src/setsflat.x ccdred/src/setzero.x ccdred/src/t_ccdproc.x ccdred/src/t_ccdtool.x ccdred/src/setfixpix.x ccdred/src/generic/ccdred.h ccdred/src/mkpkg ccdred/ccdproc.par ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl Added output saturated pixel masks. t_msccmatch.x msccmatch.par 1. New step to automatically find coordinate offset. 2. New step to check bad pixel mask for saturated and bad pixels. 3. New step to output coordinates for objects not affected by bad pixels. 4. Now reads magnitudes if given and uses brighter objects for automatic search. (9/27/99, Valdes) sflatcombine.cl ccdred/sflatcombine.cl Removed automatic processing. (9/27/99, Valdes) rmpupil.cl Now allows in-place operation. (9/27/99, Valdes) mscimage.cl mscimage.par 1. The function parameter was removed and hardwired to "polynomial". This is to avoid a bug in flux conservation with the other functions. 2. Added explicit parameters to the call to GEOTRAN. (9/27/99, Valdes) mscsetwcs.cl Now includes equinox as a parameter and precession if needed. (9/27/99, Valdes) mscarith.cl Another change related to CCDMEAN. (9/27/99, Valdes) ccdproc.cl Now includes output masks and saturation mapping. (9/27/99, Valdes) imsurfit/t_imsurfit.x Modified to allow same input and output image name. (9/25/99, Valdes) mscpipeline/* + ../mscred/mscred.cl Added new pipeline subpackage. (9/25/99, Valdes) (9/25/99, Valdes) mscqphot.cl + mscspars.par + mscppars.par + ../mscred/mscred.cl New task for doing photometric calibration in pipeline. (9/25/99, Valdes) t_getcatalog.x + getcatalog.par + mscgetcatalog.cl + x_mscred.x mkpkg ../mscred/mscred.cl Prototype task to get catalog data. Currently only for USNO. (9/25/99, Valdes) t_toshort.x + toshort.par + msctoshort.cl + x_mscred.x mkpkg ../mscred/mscred.cl New task to convert images/MEF to scaled short format. (9/25/99, Valdes) addkey.par + t_addkey.x + mkpkg x_mscred.x ../mscred/mscred.cl New hidden task for adding keywords with comments. Needed for the MAP. (9/25/99, Valdes) ========== MSCREDV3.3 ========== ccdred$src/t_ccdgroups.x ccdred$ccdgroups.par 1. Added parameter to break into sequences. 2. Added verbose parameter to provide more control than just the package. (9/22/99, Valdes) t_msctmplt.x All operations are now performed in "astrometry" coordinates to avoid problems at RA=0 and DEC=+-90. (9/17/99, Valdes) mscwcs.x Added an msc_open to convert an already open mw pointer to a wcs pointer. The msc_openim routine now calls msc_open after doing the mw_openim or setting the WCS from a database. (9/17/99, Valdes) mscarith.cl Added another change to handle the CCDMEAN keyword without errors. (9/15/99, Valdes) ccdproc.cl Added checks for the output image being the same as the input image and for the output image existing. (9/9/99, Valdes) xtalkcor.cl Added a check for whether the xtalkfile given in the header is found. mscdisplay/src/mosqproc.x - mscdisplay/src/t_mosqproc.x - mscdisplay/src/t_mosdisp.x - ccdred/src/generic/corinput.x - mkpkg Removed unneed files. ccdred/src/t_combine.x Changed an error call to an erract. (9/3/99, Valdes) ccdred/src/t_ccdmask.x Removed extra argument. (9/3/99, Valdes) ccdred/src/t_ccdlist.x mscdisplay/src/t_mscrtdisp.x t_mscimatch.x Added missing argument. (9/3/99, Valdes) mscdisplay/src/mscg.x Fixed type declarations for asum. (9/3/99, Valdes) ccdred/src/cosmic/crexamine.x ccdred/src/iccaclip.gx ccdred/src/icscale.x t_mscimatch.x t_mscwcs.x Added sfree before return. (9/3/99, Valdes) ============ MSCREDV3.2.1 ============ t_mscimatch.x Fixed bug where sigma was declared incorrectly as int instead of double in imat_fit2. If niterate > 0 this would cause a floating operand error on Linux systems and possibly others. (9/3/99, Valdes) t_mscimatch.x mscimatch.par Added feature to save measurements and restore measurements. (9/2/99, Valdes) rmpupil.cl Needed to change the default value of extname. (8/27/99, Valdes) ========== MSCREDV3.2 ========== msctvmark.cl Was not dealing correctly with untrimmed data. (8/2/99, Valdes) mscfinder/msctpeak.x Added an extname parameter. (8/2/99, Valdes) mscfinder/t_tpeak.x mscfinder/tpltsol.cl mscfinder/tpeak.key 1. Fixed bugs not allowing update of coordinates. 2. Delete 'e', 'x', and 'p' keys and changed 'f' to update positions of uncentered sources. (8/2/99, Valdes) t_mscdisplay.x t_mscrtdisp.x Modified z scaling output. (7/30/99, Valdes) xtalkcor.cl The crosstalk file can be specified with the !keyword syntax. (7/28/99, Valdes) mscdisplay/mosmap.x The OTF calibration directory can be specified with the !keyword syntax. (7/28/99, Valdes) mscdisplay/mosmap.x The scheme for defining defaults during readout has been modified. The old scheme is still supported. The new scheme allows having both prescan and overscan and regions. (7/27/99, Valdes) t_msccmatch.x msccmatch.par The default fitting geometry is now general but constrained to orders of 2 with half cross terms. This is because refraction does not rotate the axis around the optical axis. (7/14/99, Valdes) ========== MSCREDV3.1 ========== t_imext.x Modified to accept a list of patterns rather than one pattern for selecting extension names. (6/18/99, Valdes) calproc.cl ccdproc.cl mkfits.cl mscarith.cl mscblkavg.cl mscimage.cl mscimatch.cl mscsetwcs.cl rmfringe.cl rmpupil.cl sflatcombine.cl xtalkcor.cl Made sure HEDIT calls include both the add and del options explicitly. (6/17/99, Valdes) ccdred/src/icsetout.x Changed to better parse the offset types. The WCS correction for offsets was incorrect. (6/17/99, Valdes) t_msccmatch.x 1. Rather than reporting the number of stars out of bounds it was reporting the number of stars in bounds. 2. Minor bug where the first extensions was used for the scale rather than the image being considered. (6/16/99, Valdes) mscdisplay/src/sigm2.gx An argument to zigm2_setup was being changed by the routine and this changed argument was then incorrectly used by the calling program. The argument was made input only. (6/15/99, Valdes) t_mscwcs.x t_msccmatch.x mscwcs.par Now only the total target number of grid points for doing the WCS adjusment is specified and the number of points along each axis is computed to preserve nearly equal pixel spacing along both axes independent of the image axis ratio. (6/11/99, Valdes) t_mscwcs.x Fixed bug in adjusting WCS when the logical and physical coordinates are not the same. (6/11/99, Valdes) t_msctmplt.x Modified to use CCD closest to it's own tangent point as the WCS reference if one is not specified. (6/10/99, Valdes) t_pixarea.x pixarea.par mscpixarea.cl Modified to use pixel area at tangent point for the CCD closest to it's own tangent if a normalization area is not specified. (6/10/99, Valdes) t_msctmplt.x When the input data is block averaged or binned the output image comes out in physical coordinates rather than a simpler pixel sampling to the input image. Fixed so that the output image will have the same pixel scale as the input data with the physical coordinate system reset. (6/8/99, Valdes) mscfinder/msctpeak.cl mscfinder/tpltsol.cl The ennumerated projection parameters for msctpeak and tpltsol were removed. (6/8/99, Valdes) msczero.cl mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x 1. The frame select parameter for display is now applied when checking if the image is loaded. Now if the image is loaded in another frame and checking is done the frame will switch to frame without loading. 2. MSCZERO now will select the frame when the image is currently loaded. (6/3/99, Valdes) msctvmark.cl msczero.cl The conversions between detector coordinates (the mosaic DETSEC system used for display) and logical pixels in an image extension was done wrong. This would only be a problem when the the physical and logical coordinate systems are different. (6/3/99, Valdes) t_mscctran.x Fixed a bug that could use the wrong input units if a previous execution specified units. This affected MSCZERO. (6/3/99, Valdes) mscfinder/tpltsol.cl The database entry now has a solution name given by the extension alone rather than including the image name. (6/3/99, Valdes) mscfinder/t_tpeak.x 1. Quoted the RA and DEC values passed to TPLTSOL. Otherwise if the DEC had a sign it would cause an error. 2. The '?' help file was not being found. (6/3/99, Valdes) ccdred/src/t_ccdgroups.x Added a "date" grouping where the date-obs string is stripped of any time component before grouping by matching patterns. (5/19/99, Valdes) t_mscimatch.x Fixed possible error introduced with the sky level modification. (5/18/99, Valdes) ../lib/zzsetenv.def Added package library definitions for tables so they don't have to be included explicitly. (5/18/99, Valdes) ccdred/src/t_ccdlist.x Added support for crosstalk and removed illumination/fringe/scancor/readcor stuff. (5/13/99, Valdes) xtalkcor.cl Added noproc flag and behavior. (5/13/99, Valdes) ========== MSCREDV3.1 ========== rmfringe.cl + ../mscred.cl Added new task to interactively remove a fringe correction. This is similar to RMPUPIL. (5/11/99, Valdes) mscdisplay/src/mosmap.x mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x The step which flips the images by mapping them with a flipped section was moved into the lower level routine mg_open in order to have the same mapping apply to MSCEXAM, etc. (5/11/99, Valdes) t_mscext.x t_imext.x Modified to use temporary disk images rather than in memory string to avoid problem with long lists of files to be expanded. (5/11/99, Valdes) mscsetwcs.cl + mscwcs.cl - ../mscred.cl Added new task to set WCS from a database file and RA/Dec header keywords. (5/10/99, Valdes) mscdisplay/src/imexam/iepos.x The x and y keys were not writing to the logfile. Fixed to be the same as the standard version. (5/7/99, Valdes) rmpupil.cl Modified parameters to allow specifying the initial or final scale to use. (5/4/99, Valdes) t_pupilfit.x Fixed intrinsic function type mismatch errors which cause compiling failure on Dec machines. (4/29/99, Valdes) rmpupil.cl Changed the IMEXPR calls to force real output to avoid double results with small scaling constants. (4/28/99, Valdes) ccdproc.cl calproc.cl Needed to remove TMFNAME keyword from final result. (4/26,99, Valdes) ========== MSCREDV3.0 ========== mscwcs.x Fixed error in structure definition. (4/22/99, Valdes) ccdproc.cl calproc.cl Added crosstalk correction option to CCDPROC. This calls XTALKCOR. (4/21/99, Valdes) ccdred/src/ccdlog.x The image name part of the log now first looks for a keyword TMPFNAME and if not found uses the image name associated with the IMIO pointer (as before). This is used to allow temporary files to be used in scripts and still get the name of the actual file in the log. (4/21/99, Valdes) xtalkcor.cl + ../mscred.cl ../mscred.men New crosstalk correction task. (4/20/99, Valdes) mscstat.cl Added global mode option. (4/20/99, Valdes) t_msctmplt.x If no WCS reference image is given then the first input image (the first extension if using MSCIMAGE) is used. The averaging of the WCS is no longer done. (4/20/99, Valdes) ccsetwcs.x mscwcs.x The WCSSOL solution is automatically converted into the standard units rather than being left in ra of hours. (4/20/99, Valdes) t_fitscopy.x If the input or output is a tape the task needs to abort and not continue. (4/15/99, Valdes) t_combine.x ccdred/coutput.par sflatcombine.cl Fixed problems with COUTPUT. (4/14/99, Valdes) sflatcombine.cl Fixed typo. (4/14/99, Valdes) rmpupil.cl Improved to allow input and output lists, the input and output images to be the same, to add a processing keyword to the headers, to check the header for previous processing. (4/14/99, Valdes) mscpixarea.cl + t_pixarea.x + pixarea.par + mkpkg x_mscred.x ../mscred.cl ../mscred.hd ../mscred.men Added new tasks to compute pixel area corrections based on WCS. PIXAREA works on individual images and MSCPIXAREA works on MEF mosaic data. (4/12/99, Valdes) t_mscimatch.x Modified to allow use of "skymean" keyword. If zero=no then these keywords can be used to constrain the offsets as determined by the keywords. (4/7/99, Valdes) imsurfit/* + mscskysub.par + x_mscred.x mkpkg ../mscred.cl ../mscred.hd ../mscred.men Modified IMSURFIT to allow use of masks and to output the residuals consisting of the data - fit + mean(fit). It also adds the keyword "skymean" to the header with the value of mean(fit). (4/7/99, Valdes) ccdred/src/ccdred.h ccdred/src/setdark.x ccdred/src/setfringe.x ccdred/src/setillum.x ccdred/src/setsflat.x ccdred/src/setflat.x ccdred/src/settrim.x ccdred/src/setzero.x ccdred/src/setsections.x ccdred/src/setheader.x Significant changes to handle flipped datasec, ccdsec, and detsec. (3/25/99, Valdes) ../mscred.par ../lib/mosaic.dat + Made a new default instrument translation file as a guide to users. The new default will work with the NOAO Mosaic headers. (3/19/99, Valdes) mscdisplay/src/mosmap.x The way the gaps are added was not right when CCDs have multiple amps. A minor change fixed this. (3/18/99, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x There was an error in how DX and DY were used when there are flips. The values are now absolute values in the call to mos_params. (3/17/99, Valdes) mscarith.cl msccmd.cl calproc.cl ccdproc.cl Modified to handle case where the input image name is the same as a logical directory name. Before the change the imrename would put the temporary image in that directory. Now if the image name is the same as a logical variable the imrename is done to ./input. This may not work right if the input has a directory path but it is better than having the image disappear some place. (3/17/99, Valdes) msczero.cl msczero.key Added 'r' key to reload display and 'm' to mark objects using the new MSCTVMARK. (3/16/99, Valdes) mscwcs.x When using a WCSSOL solution the units are done differently. (3/16/99, Valdes) ../mscred.cl ../mscred.hd ../mscred.men ../mscred.par msctvmark.cl + New task to mark coodinates in MSCDISPLAY. (3/16/99, Valdes) mscimatch.par t_mscimatch.x Added bad pixel mask option. (3/16/99, Valdes) ccdproc.cl calproc.cl Fixed problem with previous change. (3/16/99, Valdes) mscdisplay/src/mosmap.x Modified sprintf statements that format a keyword to not overflow the string buffer. (3/9/99, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x The "auto" zcombine option would not go to "none" if the PROC flag was not set to yes. (3/2/99, Valdes) ccdproc.cl calproc.cl Removed use of list format for the expanded extensions to avoid overflow of the list string. (2/10/99, Valdes) mscdisplay/src/t_mscdisplay.x The fill code was enforcing the same magnification in x and y which does not allow correct display of data binned differently in x and y. (11/24/98, Valdes) mscdisplay/src/mosmap.x There was a missing statement. (11/16/98, Valdes) mscdisplay/src/t_mscrtdisp.x Had to add a FIO cancel to force a refill of the buffers. (11/10/98, Valdes) mscblkavg.cl + ../doc/mscblkavg.hlp + ../mscred.cl ../mscred.hd ../mscred.men New task to block average a mosaic exposure with update of RDNOISE, GAIN, CCDSUM, DATASEC, BIASSEC, TRIMSEC, and CCDSEC. (11/7/98, Valdes) mscdisplay/mscdisplay.par mscdisplay/mscrtdisp.par mscdisplay/mscexamine.par The mimpars prompt string was expanded. (10/13/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x When the image has been processed and zcom=auto then it needs to do the right zcombine. (10/11/98, Valdes) ccdred/src/xtfpixix.x + ccdred/src/xtfp.gx + ccdred/src/xtfixpix.h + ccdred/src/proc.gx ccdred/src/setfixpix.x ccdred/src/setproc.x ccdred/src/mkpkg ccdred/src/generic/mkpkg Installed bugfixes from V2.11.2. (10/9/98, Valdes) ccdred/src/icsetout.x Updated for bug fix dealing with WCS of dimensionally reduced images. (10/6/98, Valdes) ../mkpkg Missing $endif. (9/21/98, Valdes) t_fitscopy.x Fixed use of int variable as a bool which is an error on linux. (9/21/98, Valdes) ==== V1.2 ==== mscred.par doc/installation.hlp New version information. (9/17/98, Valdes) ../mscred.hd ../mscred.men Update. (9/17/98, Valdes) ../doc/mscguide.hlp New version. (9/17/98, Valdes) msctools/pl2msc.cl + msctools/msctools.cl New tool to convert a pixel list directory to a mosaic MEF file. (9/16/98, Valdes) msctools/mkbpm.cl + msctools/msctools.cl New tool to create bad pixel mask from ratio of flat fields. (9/10/98, Valdes) mscwcs.x Fixed problem with the case where the header has no WCS. (9/9/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x mscdisplay/src/mosmap.x Bug fix for zcombine=auto option. (6/6/98, Valdes) t_pupilfit.x mscpupil.cl rmpupil.cl + ../mscred.cl Work on pupil correction. (9/7/98, Valdes) msctools/fmtastrom.cl + msctools/msctools.cl New tool to format KTM data strings from image WCS. (9/6/98, Valdes) ../doc/mscotfflat.hlp + mscdisplay/mscotfflat.cl + mscdisplay/flatcompress.cl + msctools/mkdispflat.cl - msctools/flatcompress.cl - ../mscred.cl Installed script task to build OTF calibrations. (9/5/98, Valdes) mscdisplay/src/mosmap.x mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x Tweaks for printing flat information in the display title and mapping filter names to actual flat field calibrations used. (9/3/98, Valdes) ccdred/src/proc.gx When the number of pixels in the overscan is less than 3 then use the average if "minmax" overscan is selected. (9/2/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x mscdisplay/src/mosmap.x mscdisplay/src/mscg.gx mscdisplay/src/mosgeom.h 1. Made changes to real-time display which checks for no data. 2. It is now ok for sleep to be zero by using a minimum sleep of 1. 3. The test for stalled readout now waits for several cycles for the data to arrive. (8/31/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x mscdisplay/src/mosmap.x mscdisplay/src/mscg.gx mscdisplay/src/mosgeom.h mscdisplay/mimpars.par Added to flags to allow independent control of the bias subtraction and the flat fielding when processing is selected. (8/28/98, Valdes) mscdisplay/src/t_mscdisplay.x Modified the default sample section to exclude edges of image. (8/25/98, Valdes) ../lib/mscdb - ../mscred.cl Made the MSCRED database be an external directory to be defined in extern.pkg. (8/6/98, Valdes) mscdisplay/mimpars.par + mscdisplay/mscdisplay.par mscdisplay/mscrtdisplay.par mscdisplay/mscexamine.par mscdisplay/src/starfocus/mscstarfocus.par ../mscred.cl A new PSET defines the mosaic image displayed. The pset was added to all the tasks which need to access this information. (8/7/98, Valdes) mscdisplay/src/mosmap.x mscdb$noao/kpno/4meter/CCDMosaThin1.dat mscdb$noao/kpno/4meter/CCDMosaThin1.cl mscdb$noao/kpno/4meter/mosaic1.dat mscdb$noao/kpno/36inch/CCDMosaThin1.dat mscdb$noao/kpno/36inch/CCDMosaThin1.cl mscdb$noao/kpno/36inch/mosaic1.dat 1. The amplifier name mapping now includes translating the extension name. The logic is 1) look for the value of the "amp" keyword (amp is mapped to imageid in the NOAO Mosaic translations), 2) look for "extname" keyword and translate it (will translate to itself if not in the translation file), 3) extract from the image name. The purpose of this change is to allow the same amp value during readout and after readout when imageid is not yet set but extname is set. Then the defaults for detsec, datasec, and the bias trimming can be indexed by the imageid values. 2. Calibration directory and filter parameters were added to map to the calibration files for on-the-fly processing. (8/6/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x mscdisplay/mscdisplay.par mscdisplay/mscrtdisplay.par New zcombine value is "auto" to chose between "none" and "minmax" depending on whether the displayed image is flattened. (8/6/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/t_mscrtdisp.x mscdisplay/src/sigm2.gx 1. Rounding problem in sigm2_setup was fixed. 2. Calculation of number of pixels when an offset is present was wrong resulting in running off the end of an array. (8/5/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/mscdisplay.par 1. Commented out use of im_bufsize since it seems to actually slow things down. 2. Add parameter "onepass" to select the one pass loading. (8/4/98, Valdes) mscdisplay/src/t_mscrtdisp.x + mscdisplay/mscrtdisplay.par + mscdisplay/x_mscdisplay.x mscdisplay/mkpkg ../mscred.cl The old version of MSCDISPLAY with the individual extension loading and iterative waiting for real time display was renamed to MSCRTDISPLAY. This version includes the changes to MSCDISPLAY to support OTF processing. (8/3/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/mscdisplay.par 1. If possible, a buffer the full size of the display is used to build up the displayed data so that display can be filled in on pass with WRITE_ONLY permission to the display. 2. The "im_bufsize parameter is now used to set input I/O buffers for greater efficency. 3. Mapping of the display was changed. Erase occurs later and display is mapped WRITE_ONLY when displaying in one pass to minimize I/O to display. 5. Changes were made to support OTF processing: new "process" parameter and passing of mg structure instead of im structure. 6. Trimming is now done later rather than with image sections. 7. Flips are implemented with untrimmed image sections. 8. Streamlined by removing all real-time modifications. (8/3/98, Valdes) mscdisplay/src/mscg.gx + mscdisplay/src/sigm2.gx + mscdisplay/src/mosmap.x mscdisplay/src/maxmin.x mscdisplay/src/migl2.gx mscdisplay/src/mignl.gx mscdisplay/src/migs2.gx mscdisplay/src/mosgeom.h mscdisplay/src/mkpkg 1. All input I/O now goes through the routines in mscg.gx. These routines implement OTF processing. They also optimize access to unsigned FITS data. 2. The sigm2.gx file is a version of the one in DISPLAY with the IMIO calls changed to go through the mscg.gx routines. 3. Changes were made to mimap/mgopen to setup the OTF processing. (8/3/98, Valdes) ccdred$src/t_combine.x Temporarily change the output rejection mask from a pl to a user specified extension. For large files there is some problem with pl files. (7/31/98, Valdes) ccdproc.cl calproc.cl The call to imextensions would produce a warning if no extensions are present. Changed to avoid this warning. (7/30/98, Valdes) ccdred$src/icgdata.gx If a line had no data then the number of pixels needed to be initialized. (7/29/98, Valdes) ccdred$src/iclog.x Added logging of rejection mask. (7/29/98, Valdes) ccdred$src/setproc.x Added workaround for xtools fixpix bug not setting the pixel type. (7/20/98, Valdes) ccdred/src/ccdtypes.x Fixed bug with stripping whitespace from ccdtype string. (7/20/98, Valdes) mscstack.cl Added rejmask to internal call to combine. (7/17/98, Valdes) t_msccmatch.x Now only reports the number of out of bounds coordinates rather than the individual coordinates. (7/2/98, Valdes) mscimage.cl mscimage.par 1. A new parameter to specify the interpolant for the mask was added. 2. When the interpolated mask image is converted to a pl mask the absolute value of the pixels is taken. This is to flag negative ringing. (7/2/98, Valdes) ../lib/mscdb/noao/* Modified instrument translation files to have MSCDISPLAY defaults for overscan trim to deal with binned case. (7/2/98, Valdes) mscdisplay/src/mosmap.x Modified to work with binned data when no header information is present. The overscan width is obtained from the translation file. (7/2/98, Valdes) ccdproc.cl sflatcombine.cl ccdred/src/t_ccdproc.x ccdred/ccdproc.par ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl 1. Added "output" parameter to CCDPROC. 2. The combine scripts behave as before. (6/19/98, Valdes) ../lib/mscdb/noao/* 1. Added information for mosaic2. 2. Restructured directories and files. 3. Modified instrument translation files to have MSCDISPLAY defaults for data and detector sections. (6/18/98, Valdes) setinstrument.cl Changed this task to have parameters for site, telescope, and instrument. (6/18/98, Valdes) mscdisplay/src/mosmap.x Modified how default data and detector sections are determined when not present in the image headers (i.e. during readout). Now it uses information from the instrument translation file. This was done to support multiple instruments. (6/18/98, Valdes) ffpupilcor.cl Changed default statsec. (6/18/98, Valdes) t_mscimatch.x mscimatch.par Modified to allow constraining either the scale or zero values. (6/10/98, Valdes) t_mscimatch.x Fixed missing format argument when no good data is found. Improved error message to hint at possible problem. (6/9/98, Valdes) t_pupilfit.x Data array needed to be freed. (6/1/98, Valdes) ccdred/src/cor.gx ccdred/src/proc.gx New version that normalizes the flat field first and checks for extreme flat field values. If an extreme flat field value is found then the value is replaced by 1; i.e. the flat field is skipped if the flat field value is extreme. (6/1/98, Valdes) _combine.par combine.cl sflatcombine.cl New parameter for rejection masks added. (5/18/98, Valdes) mscpupil.cl + mscpupil.par + ../mscred.cl ../mscred.men A new task to fit and remove a pupil image from mosaic format data. (5/12/98, Valdes) t_pupilfit.x + pupilfit.par + x_mscred.e mkpkg ../mscred.cl A new task to fit a pupil image. (5/12/98, Valdes) t_imstat.x + imstat.h + imstatistic.par + xtpmmap.x + x_mscred.e mkpkg ../mscred.cl Added a version of IMSTAT that uses masks. The file xtpmmap.x is included to pick up a bug fix to xt_pminvert made for V2.11.2. (4/22/98, Valdes) ffpupilcor.cl + ../doc/ffpupilcor.hlp + ../mscred.cl ../mscred.men ../mscred.hd Added a new task to correct broad band flat fields for the pupil ghost. (4/16/98, Valdes) mscdisplay/src/migs2.gx Fixed bug with setting origin. (4/16/98, Valdes) mscimage.cl Used a workaround for making the mask image of creating it as a FITS file and then converting to a PL file at the end. There is some IMIO problem with using a PL file with GEOTRAN as used in MSCIMAGE. (4/10/98, Valdes) t_msctmplt.x Added parameter to select output pixel type. (4/10/98, Valdes) ../mkpkg Added Linux architectures. (4/7/98, Valdes) mscarith.cl Fixed error in order of deleting temporary files. (4/5/98, Valdes) sflatcombine.cl Removed enumerated list for scale parameter to allow @file input. (4/5/98, Valdes) ccsetwcs.x Fixed argument type mismatch in call to cc_nwcsim. (4/4/98, Valdes) t_fitscopy.x Removed extra argument in calls to imtopen and strcat. (4/4/98, Valdes) mscfinder/cdrfits/fits_read.x fnroot was used as a subroutine instead of an int function. (4/4/98, Valdes) mscfinder/cdrfits/ftb_rheader.x sscan was used as a function instead of a subroutine. (4/4/98, Valdes) mscfinder/t_tpeak.x 1. changed tp_colon declaration to bool 2. sscan was used as a function instead of a subroutine 3. valid declaration changed from bool to int (4/4/98, Valdes) ccdred/src/t_combine.x 1. changed mef from bool to int 2. changed delete from bool to int (4/4/98, Valdes) ccdred/src/fixpix.x 1. removed extra argument in imgl1i call 2. added missing flag argument to calls to pm_save (4/4/98, Valdes) ccdred/src/icstat.gx call to asums was declared as short instead of real (4/4/98, Valdes) ccdred/src/readcor.x modified to take an input and output image and do the in-place operation only if the input and output are the same. (4/4/98, Valdes) ccdred/src/t_ccdlist.x added missing argument to strcpy (4/4/98, Valdes) ccdred/src/t_ccdmask.x removed extract argument in call to cm_mask (4/4/98, Valdes) mscdisplay/src/t_mscdisplay.x 1. add an error function for alogr call. 2. fixed typo in parenthesis in clgetr call. (4/4/98, Valdes) mscdisplay/src/starfocus/rngranges.x added missing argument to two rng_error calls (4/4/98, Valdes) ../doc/mscimage.hlp ../doc/mscguide2.1.hlp + Wrote help and updated guide. (3/24/98, Valdes) ../lib/mscdb/noao/mosaic1/mosaic.dat ../lib/mscdb/noao/mosaic1/4meter.dat ../lib/mscdb/noao/mosaic1/36inch.dat Added translation for projector flat. (3/24/98, Valdes) ccdred/src/proc.gx ccdred/src/ccdmean.x The mean computation was changed to do a 2 pass/2 sigma sigma clip on each output line. The final mean is the mean over all the lines weighted by the number of pixels used in each line mean. (3/24/98, Valdes) ccdred/src/cor.gx Needed to add a no operation case statement. (3/20/98, Valdes) mscimage.cl mscimage.par The following changes now put the gaps into an output bad pixel mask and handle the edge pixels better. 1. The output mask is initialized to 10000. 2. The boundary uses "constant" extension. For the image data the constant is the "blank" value. For the mask it is 1000. 3. The mask is interpolated even if the mask is empty. This is done to set mask values at the edge of the image. 4. The default is now to create a pixel mask. (3/17/98, Valdes) mscarith.cl The script was looking for CCDMEAN and would fail if it was not found. It was changed to only use it if it is present. (3/9/98, Valdes) t_mscimatch.x + mscimatch.par + x_mscred.x mkpkg ../mscred.cl A new compiled version of the intensity matching task was added. This version is much faster and better. (2/23/98, Valdes) t_fitscopy.x If the original name is selected and a null output image is given then a temporary image name is used for the output name. (2/20/98, Valdes) mscdisplay/mscdisplay.par mscdisplay/src/t_mscdisplay.x Added an initial wait parameter for DCA operation. (2/10/98, Valdes) ==== V1.1 ==== mscred.par doc/installation.hlp New version information. (2/3/98, Valdes) mscdisplay/src/t_mscdisplay.x mscdisplay/src/mosmap.x Modifications to support a flipped detector section. (2/5/98, Conroy/Valdes) mscdisplay/src/mosmap.x mscdisplay/mscdisplay.par If the image name to be displayed is not a MEF file but a root for a list of images then the "exttmplt" parameter specifies a image template to be appended to the root which will expand to the list of images to be displayed as a mosaic. (2/5/98, Conroy/Valdes) msczero.cl After determining the physical coordinates for the individual image the coordinates need to be transformed to logical for the rest of the script. (2/5/98, Conroy/Valdes) ccdred/src/icsetout.x The WCS updating needed to be corrected. (2/5/98, Valdes) doc/mscguide.hlp Update to latest version. (2/3/98, Valdes) ../lib/mscdb/noao/mosaic1/4meter/wcs.dat ../lib/mscdb/noao/mosaic1/36inch/wcs.dat Change projection type from "tan" to "tnx". (2/3/98, Valdes) msczero.cl Modified to call the new MSCWCS routine. (2/3/98, Valdes) t_mscwcs.x + mscwcs.par + t_wcsadjust.x - t_msccmatch.x msccmatch.par mkpkg x_mscred.x ../mscred.cl 1. The routines for adjusting a WCS for shift, rotation, and magnification were rewritten to modify a tnx (or other) WCS. The routines were previously in t_wcsadjust.x but are now in t_mscwcs.x. The names were changed and arguments and structure are different. 2. MSCCMATCH was modified to use the new routines to produce a WCS in the header rather than a new database entry. 3. A new task MSCWCS (replacing a script of the same name) modifies the WCS in a list of images for shift, rotation, and magnification. If there is only a shift then only the tangent point coordinates are modified. (2/3/98, Valdes) mscwcs.x skywcs.x + ccsetwcs.x + skywcsdef.h + skywcs.h + mkpkg mscdisplay/mkpkg t_mscctran.x t_msctmplt.x t_msccmatch.x t_mscxcor.x 1. Modified to use new "tnx" WCS. 2. When an image with WCSSOL is found the database solution is converted internally to a tnx WCS. 3. The "usewcssol" argument in msc_openim() was removed and all routines calling this procedure were modified. (2/3/98, Valdes) ==== V1.0 ==== mscred.par doc/installation.hlp New version information. (1/27/98, Valdes) doc/mscguide.hlp New version. (1/27/98, Valdes) ccdred/src/mscarith.cl This task now specially handles CCDMEAN. (1/26/98, Valdes) ccdred/src/t_combine.x The BPM keyword is removed for the output image. (1/23/98, Valdes) mscimage.cl 1. The NEXTEND keyword is removed for the output image. 2. The pixel mask now ends with _bpm to distinguish it from the data image. (1/23/98, Valdes) curfit/* + x_mscred.e mkpkg ../mscred.cl Added a version of utilities.curfit, called msccurfit, which has a separate output results parameter. (1/23/98, Valdes) ccdproc.cl ../lib/mscdb/noao/mosaic1/mosaic.cl Removed parameters relating to max_cache, illumination and fringe corrections, readout axis, and scanning from this task to simplify the parameters. (1/16/97, Valdes) ccdred/src/t_combine.x ccdred/coutput.par + ccdred/x_ccdred.x ccdred/ccdred.cl ../mscred.cl A new task to print the output names generated by COMBINE when combining by subsets was added. This allows scripts to figure out what images are/will be created. This is used in SFLATCOMBINE to allow resetting the image type for the output sky flats. (1/16/98, Valdes) ../mscred.cl ccdred/ccdred.cl sflatcombine.cl + ccdred/sflatcombine.cl + A new task to process and then combine dithered object exposures to create a sky flat was added. This task changes the final image type to "skyflat". (1/16/98, Valdes) ccdred/src/setzero.x ccdred/src/settrim.x ccdred/src/setdark.x ccdred/src/setfixpix.x ccdred/src/setflat.x ccdred/src/setfringe.x ccdred/src/setillum.x ccdred/src/setoverscan.x ccdred/src/setsflat.x The CCDPROC log and header keyword strings were shorttened. (1/16/98, Valdes) _ccdtool.par calproc.cl ccdproc.cl ccdred/ccdproc.par ccdred/src/ccdtypes.h ccdred/src/ccdcheck.x ccdred/src/setheader.x ccdred/src/cor.gx ccdred/src/proc.gx ccdred/src/calimage.x ccdred/src/ccdproc.x ccdred/src/t_ccdlist.x ccdred/src/setsflat.x + ccdred/src/ccdred.h ../lib/mscdb/noao/mosaic1/mosaic.cl 1. A new ccdtype "skyflat" was added. 2. New processing parameters "sflatcor" and "sflat" were added to apply a sky flat correction. 3. CCDPROC now includes a sky flat correction. (1/16/98, Valdes) ../mscred.par ../lib/mscdb/noao/mosaic1/mosaic.cl ccdred/src/ccddelete.x 1. The package backup parameter was changed to select an ennumerated backup mode of none, once, or all. 2. The backup prefix/directory is now specified by the package "bkuproot" parameter. 3. The backup can now be set to none, once, or all. 4. In verbose mode whenever data is backed up by renaming a message is printed. (1/16/98, Valdes) ccdred/src/mkpkg ccdred/x_ccdred.x The tasks and procedures for cosmicrays, mkskyflat, mkskycor, mkillumcor, and mkillumflat were removed from compiling and linking. The code is still present. (1/16/98, Valdes) src/combine.cl src/_combine.par src/mscstack.par src/ccdred/combine.par src/ccdred/src/icombine.com src/ccdred/src/icaclip.gx src/ccdred/src/iccclip.gx src/ccdred/src/icgdata.gx src/ccdred/src/iclog.x src/ccdred/src/icpclip.gx src/ccdred/src/icsclip.gx src/ccdred/src/t_combine.x Changed combine grow parameter to real 2D radius. (12/26/97, Valdes) src/ccdred/src/icombine.gx src/ccdred/src/icgrow.gx Modified to allow 2D grow rejection. (12/26/97, Valdes) src/msczero.cl src/msczero.key Improved task. (12/18/97, Valdes) src/mscimatch.cl + doc/mscimatch.hlp + mscred.cl mscred.men mscred.hd New task to match intensity scales in dithered images. (12/17/97, Valdes) src/t_msctmplt.x Modified to use new WCS functions. (12/17/97, Valdes) src/msczero.cl src/msczero.key Modified to work on list of images, to remember the last zeropoint coordinate, and to use astrometry WCS. (12/10/97, Valdes) src/mscdither.cl src/mscdither.par mscred.cl mscred.men mscred.hd 1. Updated mscdither to use msccoordfit. 2. Removed mscdither package use pending further development. (12/9/97, Valdes) src/t_msccmatch.x + src/msccmatch.par + src/mscdpars.par + src/msccpars.par + src/doc/msccoordfit + src/x_mscred.x src/mkpkg mscred.cl mscred.men mscred.hd New task to match coordinates in dithered mosaic exposures. (12/8/97, Valdes) src/t_wcsadjust.x + src/wcsadjust.par + src/mkpkg Added routines to adjust WCS for shift, scale, and rotation. (12/8/97, Valdes) src/mscwcs.x src/t_mscctran.x 1. Added "astrometry" coordinate system. 2. Added wcsstat function. (12/8/97, Valdes) src/t_mscxcor.x src/mscxcor.par src/x_mscred.x src/mkpkg doc/mscxcor.hlp mscred.cl mscred.men mscred.hd Renamed mscregister to mscxcor. (12/8/97, Valdes) src/mscstat.cl This script no longer needs to deal with image sections since this is now done by imextensions. (12/1/97, Valdes) src/t_imext.x Modified to allow image sections. (12/1/97, Valdes) src/mscdisplay/src/mkoverscan.x src/mscdisplay/src/gamma.x Fixed intrinsic function type mismatch in mkoverscan.x and use of the same variable name as the function name in gamma.x. These are errors with the Dec Alpha compiler. (11/18/97, Valdes) ==== V0.2 ==== mscred.par doc/installation.hlp New version information. (11/4/97, Valdes) src/msczero.cl src/msczero.key + The key '?' prints help, only reports coordinate without centering or writing to a file, 'w' centers and writes coordinate to a file, 'z' centers and accumulates offset, 'u' updates the image header and database. (11/4/97, Valdes) src/ccdred/src/icscale.x For MEF files the statistics section can be an @file with sections for each subset and any line that is not a section will cause that subset not to be used. (10/31/97, Valdes) src/ccdred/src/t_combine.x src/ccdred/src/icscale.x src/ccdred/src/icombine.gx src/ccdred/src/icombine.com src/ccdred/combine.par src/ccdred/src/iclog.x src/mscstack.cl src/combine.cl - src/_combine.par - mscred.cl COMBINE will now operate on both regular images and MEF files. 1. The scales, zeros, and wts arrays are not passed down from the top of the program rather than created in icombine$t. This allows values to be set earlier which are then not changed by lower levels such as in icscale. 2. The common block now includes the statistics section so that it will only be queried once. 3. cmb_images detects the type of input data. The "extensions" parameter is not needed and the functions are determined by detecting the type of input data. 4. cmb_images reads any scale factors from a file and assigned to the images before the images are reordered by grouping. For MEF data there is then one value per file. 5. For MEF data there are new routines that take care of extracting the extensions and compute scaling factors from image statistics by combining the statistics from the extensions into one value. 6. icscale now checks for previously defined scaling factors and leaves them unchanged. 7. The use _combine and combine.cl as an interface to MEF files is no longer needed. (10/29/97, Valdes) src/msczero.cl 1. The prompts for ra/dec are no longer updated for previously accumulated offsets. 2. Added missing cos(dec) terms. (10/28/97, Valdes) src/mscdisplay/src/t_fitscopy.x src/mscdisplay/src/fitscopy.par src/mscdisplay/src/mscrfits.cl src/mscdisplay/src/mscwfits.cl src/mscdisplay/doc/mscwfits.hlp src/mscdisplay/doc/msc4fits.hlp 1. Added parameters "listonly", "shortlist", and "longlist" and removed "list". 2. The listing information now includes the filename and the number of extensions given by the NEXTEND keyword. 3. The listing format has one line with the input/output filenames, the original filename, the number of extensions, and the title. 4. The short listing consists of the one line while the long listing shows each extension. 5. When doing a "listonly" with "shortlist" then after reading the first header block the task closes the file rather than reading to the end of the file. This makes for a much faster listing mode. 6. Any pathname in the disk file name is removed when setting the FILENAMEkeywords. 7. If FILENAME is not present but IRAFNAME is present then the latter is used for the original name. 8. Help pages were competed. (10/24/97, Valdes) src/mscdisplay/src/t_mscdisplay.x Rearrange the code so it puts the final WCS information in the image display before displaying to allow MSCEXAM to run while MSCDISPLAY is running in automatic display mode. (10/23/97, Valdes) src/mscdisplay/src/imexam/mscexam.h src/mscdisplay/src/imexam/iemw.x Modified to use new coordinate routines. Now world coordinates are reported using the full database solution. (10/22/97, Valdes) src/t_mscreg.x src/mscregister.par 1. Modified to use new coordinate routines. 2. Added a sigma clipping average for the mean shifts which links the wx and wy shifts together; i.e. if a wx shift is rejected then so is the corresponding wy shift. 3. Added parameter to allow correlation plots to be show even if not doing interactive review. (10/22/97, Valdes) src/mscxreg.cl 1. Removed call to mscctran and modified to only do the pixel shifts. 2. Added parameter to allow correlation plots to be shown even if not doing interactive review. (10/22/97, Valdes) src/mscimage.cl src/msczero.cl Modified to use new version of MSCCTRAN. (10/22/97, Valdes) src/t_mscctran.x + src/mscctran.par + src/liststr.gx + src/rgstr.gx + src/liststr.x + src/rgstr.x + src/mkpkg src/x_mscred.x mscred.cl A compiled version of MSCCTRAN using the new coordinate routines. (10/22/97, Valdes) src/mscwcs.x + src/mkpkg A package of coordinate routines for using database solutions specified in images with the WCSSOL keyword. (10/22/97, Valdes) src/mscimage.cl src/mscimage.par 1. Changed boundary for GEOTRAN to "nearest". 2. Added trim parameter to trim edges of output pieces. (10/13/97, Valdes) src/mscxreg.dat + src/mscxreg.cl src/msczero.cl src/mscregister.par src/t_mscreg.x Changes to allow specifying an input coordinate list (generated for example using the in MSCZERO which now writes the coordinates to the log file) to be used to select regions for correlation. (10/10/97, Valdes) src/mscarith.cl + src/mscstat.cl + New tasks. (10/10/97, Valdes) src/msccmd.cl + mscred.cl mscred.men New task to expand image extensions and excute general command. (10/7/97, Valdes) src/mscimage.cl src/mscimage.par Added "fluxconserve" parameter. (10/7/97, Valdes) src/ccdred/src/icscale.x No longer does zero level correction if zero offsets are input from a file. (10/3/97, Valdes) * New package created. (10/28/96, Valdes) .endhelp mscred-5.05-2018.07.09/src/_ccdhedit.par000066400000000000000000000002541332166314300171700ustar00rootroot00000000000000images,s,a,,,,CCD images parameter,s,a,,,,Image header parameter value,s,a,,,,Parameter value type,s,h,"string","string|real|integer",,Parameter type (string|real|integer) mscred-5.05-2018.07.09/src/_ccdlist.par000066400000000000000000000003051332166314300170430ustar00rootroot00000000000000images,s,a,,,,CCD images to listed ccdtype,s,h,"",,,CCD image type to be listed names,b,h,no,,,List image names only? long,b,h,no,,,Long format listing? ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/_ccdtool.par000066400000000000000000000045661332166314300170620ustar00rootroot00000000000000input,s,a,"",,,List of input CCD images to process output,s,a,"",,,List of output processed CCD images nointerp,s,a,"",,,List of output uninterpolated images bpmasks,s,a,"",,,List of output bad pixel masks calproc,f,h,"",,,List of calibration images to be processed (output file) ccdtype,s,h,"object",,,CCD image type to select (if not null) proctype,s,h,"",,,CCD processing type (if not null) max_cache,i,h,0,0,,Maximum image caching memory (in Mbytes) noproc,b,h,no,,,"List processing steps only?" onerror,s,h,"original","abort|warn|exit|original",,"Action on error " fixpix,b,h,yes,,,Apply bad pixel interpolation? overscan,b,h,yes,,,Apply overscan strip correction? trim,b,h,yes,,,Trim the image? zerocor,b,h,yes,,,Apply zero level correction? darkcor,b,h,yes,,,Apply dark count correction? flatcor,b,h,yes,,,Apply flat field correction? sflatcor,b,h,no,,,Apply sky flat field correction? illumcor,b,h,no,,,Apply illumination correction? fringecor,b,h,no,,,Apply fringe correction? readcor,b,h,no,,,Convert zero level image to readout correction? scancor,b,h,no,,,"Convert flat field image to scan correction? " fixfile,s,h,"",,,List of input bad pixel masks saturation,s,h,INDEF,,,Saturated pixel threshold sgrow,i,h,0,0,,Saturated pixel grow radius bleed,s,h,INDEF,,,Bleed pixel threshold btrail,i,h,20,0,,Bleed trail minimum length bgrow,i,h,0,0,,Bleed pixel grow radius biassec,s,h,"",,,Overscan strip image section trimsec,s,h,"",,,Trim data section zero,s,h,"",,,List of zero level calibration images dark,s,h,"",,,List of dark count calibration images flat,s,h,"",,,List of primary flat field images sflat,s,h,"",,,List of sky flat field images illum,s,h,"",,,List of illumination correction images fringe,s,h,"",,,List of fringe correction images minreplace,r,h,1.,,,Minimum flat field value readaxis,s,h,"line","column|line",, Read out axis (column|line) scantype,s,h,"shortscan","shortscan|longscan",,Scan type (shortscan|longscan) nscan,i,h,1,1,,"Number of short scan lines " interactive,b,h,no,,,Fit overscan interactively? function,s,h,"legendre",,,Fitting function order,i,h,1,1,,Number of polynomial terms or spline pieces sample,s,h,"*",,,Sample points to fit naverage,i,h,1,,,Number of sample points to combine niterate,i,h,1,0,,Number of rejection iterations low_reject,r,h,3.,0.,,Low sigma rejection factor high_reject,r,h,3.,0.,,High sigma rejection factor grow,r,h,0.,0.,,Rejection growing radius mscred-5.05-2018.07.09/src/_combine.par000066400000000000000000000037071332166314300170430ustar00rootroot00000000000000# COMBINE -- Image combine parameters input,s,a,,,,List of images to combine output,s,a,,,,List of output images headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,"List of sigma images (optional) " ccdtype,s,h,"",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,no,,,Combine images by subset? delete,b,h,no,,,"Delete input images after combining? " combine,s,h,"average","average|median",,Type of combine operation reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection project,b,h,no,,,Project highest dimension of input images? outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype offsets,f,h,"none",,,Input image offsets masktype,s,h,"none",,,Mask type maskvalue,r,h,0,,,Mask value blank,r,h,0.,,,"Value if there are no pixels " scale,s,h,"none",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights statsec,s,h,"",,,"Image section for computing statistics " lthreshold,r,h,INDEF,,,Lower threshold hthreshold,r,h,INDEF,,,Upper threshold nlow,i,h,1,0,,minmax: Number of low pixels to reject nhigh,i,h,1,0,,minmax: Number of high pixels to reject nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) mclip,b,h,yes,,,Use median in sigma clipping algorithms? lsigma,r,h,3.,0.,,Lower sigma clipping factor hsigma,r,h,3.,0.,,Upper sigma clipping factor rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections pclip,r,h,-0.5,,,pclip: Percentile clipping parameter grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection mscred-5.05-2018.07.09/src/addkey.par000066400000000000000000000002311332166314300165160ustar00rootroot00000000000000image,f,a,,,,Image to edit keyword,s,a,,,,Keyword value,s,a,,,,Keyword value comment,s,a,,,,Keyowrd comment type,s,h,"c","|b|s|i|l|r|d|c|",,Keyword type mscred-5.05-2018.07.09/src/calproc.cl000066400000000000000000000165231332166314300165270ustar00rootroot00000000000000# CALPROC -- Process calibration Mosaic CCD data. procedure calproc () file images = "" {prompt="List of Mosaic CCD images to process"} bool noproc = no {prompt="List processing steps only?\n"} bool xtalkcor = yes {prompt="Apply crosstalk correction?"} bool overscan = yes {prompt="Apply overscan strip correction?"} bool trim = yes {prompt="Trim the image?"} bool fixpix = yes {prompt="Apply bad pixel mask correction?"} bool zerocor = yes {prompt="Apply zero level correction?"} bool darkcor = yes {prompt="Apply dark count correction?"} bool flatcor = yes {prompt="Apply flat field correction?"} bool sflatcor = no {prompt="Apply sky flat field correction?"} bool merge = no {prompt="Merge amplifiers from same CCD?\n"} string xtalkfile = "mscdb$noao/CCDMosaThin1/xtalk.dat" {prompt="Crosstalk file"} string biassec = "" {prompt="Overscan strip image section"} string trimsec = "" {prompt="Trim data section"} string fixfile = "" {prompt="List of bad pixel masks"} string zero = "" {prompt="List of zero level calibration images"} string dark = "" {prompt="List of dark count calibration images"} string flat = "" {prompt="List of flat field images"} string sflat = "" {prompt="List of sky flat field images"} real minreplace = 1. {prompt="Minimum flat field value\n"} bool interactive = no {prompt="Fit overscan interactively?"} string function = "minmax" {prompt="Fitting function"} int order = 1 {prompt="Number of polynomial terms or spline pieces", min=1} string sample = "*" {prompt="Sample points to fit"} int naverage = 1 {prompt="Number of sample points to combine"} int niterate = 1 {prompt="Number of rejection iterations", min=0} real low_reject = 3. {prompt="Low sigma rejection factor", min=0.} real high_reject = 3. {prompt="High sigma rejection factor", min=0.} real grow = 0. {prompt="Rejection growing radius", min=0.} struct *fd, *fd2 begin bool mef int nimages file input, outname, extlist, xtalktemp, mergetemp, mergeinput, cal1 string ccdtype, extname, tmpfname cache mscextensions # Create temporary filenames. outname = mktemp ("tmp") // ".fits" xtalktemp = mktemp ("tmp") // ".fits" mergetemp = mktemp ("tmp") // ".fits" extlist = mktemp ("tmp$iraf") cal1 = mktemp ("tmp$iraf") # Process the calibration images. fd = images while (fscan (fd, input, ccdtype) != EOF) { # Expand the input image into image extensions. mscextensions (input, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) if (mscextensions.nimages == 0) { delete (extlist, verify-) next } nimages = mscextensions.nimages mef = mscextensions.imext if (mef && xtalkcor) { xtalkcor (input, xtalktemp, "", xtalkfile=xtalkfile, split-, fextn="fits", noproc=no) delete (extlist, verify-) mscextensions (xtalktemp, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) if (mscextensions.nimages == nimages) { sleep (1) # Delay to help FITS kernel cache imcopy (xtalktemp//"[0]", outname, verbose=no) fd2 = extlist while (fscan (fd2, extname) != EOF) { tmpfname = input // substr (extname, stridx("[", extname), strlen (extname)) hedit (extname, "TMPFNAME", tmpfname, add+, del-, show-, verify-, update+) } fd2 = "" } else { delete (extlist, verify-) mscextensions (input, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) } } # Process the input image extensions. sleep (1) # Delay to help FITS kernel cache if (mef && !imaccess (outname//"[0]")) imcopy (input//"[0]", outname, verbose=no) _ccdtool ("@"//extlist, outname//"[inherit]", "", "", calproc=cal1, ccdtype="", proctype=ccdtype, max_cache=0, nointerp="", noproc=noproc, onerror="original", overscan=overscan, trim=trim, fixpix=fixpix, zerocor=zerocor, darkcor=darkcor, flatcor=flatcor, sflatcor=sflatcor, illumcor=no, fringecor=no, readcor=no, scancor=no, saturation="INDEF", sgrow=0, bleed="INDEF", btrail=0, bgrow=0, readaxis="line", biassec=biassec, trimsec=trimsec, fixfile=fixfile, zero=zero, dark=dark, flat=flat, sflat=sflat, illum="", fringe="", minreplace=minreplace, scantype="shortscan", nscan=1, interactive=interactive, function=function, order=order, sample=sample, naverage=naverage, niterate=niterate, low_reject=low_reject, high_reject=high_reject, grow=grow) flpr # It is an error if there are calibration images to process. if (access (cal1)) { fd = "" delete (outname, verify=no) delete (extlist, verify=no) delete (cal1, verify=no) error (1, "Error processing " // input) } # If no processing occurred delete output. # If xtalkcor was done then either delete intermediate file # or rename to output. if (mef) { if (imaccess (outname//"[1]")) { if (imaccess (xtalktemp//"[0]")) imdelete (xtalktemp, verify=no) } else { imdelete (outname, verify=no) if (imaccess (xtalktemp//"[0]")) imrename (xtalktemp, outname, verbose-) } } # Merge amplifiers if desired. if (merge && mef) { if (imaccess (outname//"[1]")) { imrename (outname, mergetemp, verbose-) mergeinput = mergetemp flpr } else { imdelete (outname, verify=no, >& "dev$null") mergeinput = input } mergeamps (mergeinput, outname, outmasks="", imcmb="$I", headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigmas="", ccdtype="", amps=yes, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="physical", masktype="none", maskvalue=0., blank=1., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0.) if (imaccess (outname//"[0]") && verbose) printf ("%s: Merge amplifiers\n", input) if (mergeinput == mergetemp) { if (imaccess (outname//"[0]")) imdelete (mergetemp, verify-) else { if (defvar (outname)) imrename (mergetemp, "./"//outname, verbose=no) else imrename (mergetemp, outname, verbose=no) } } } # Check if the input was processed. # If so make backup and rename the temporary output to the # original image name. If CCDMEAN is defined compute a # global mean. delete (extlist, verify=no) mscextensions (outname, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) if (mscextensions.nimages > 0) { if (mscextensions.nimages > 1) { hselect (outname//"[1]", "ccdmean", yes) | scan (x) if (nscan() > 0) { hselect ("@"//extlist, "ccdmean", yes) | average | scan (x) hedit ("@"//extlist, "ccdmean,ccdmeant", add-, del+, verify-, show-, update+) hedit (outname//"[0]", "ccdmean", x, add+, del-, verify-, show-, update+) } hedit ("@"//extlist, "tmpfname", add-, del+, verify-, show-, update+) } ccddelete (input) if (defvar (input)) imrename (outname, "./"//input, verbose=no) else imrename (outname, input, verbose=no) } else imdelete (outname, verify=no, >& "dev$null") delete (extlist, verify=no) } fd = "" end mscred-5.05-2018.07.09/src/catdb.dat000066400000000000000000000166711332166314300163370ustar00rootroot00000000000000# Initial cut at an astrometric catalog database file. begin filename@noao address query nquery 0 protocol nheader 1 csystem J2000 nfields 0 begin usnob1@noao address inet:80:archive.tuc.noao.edu:text query GET /cgi-bin/scat?catalog=ub1&ra=%-s&dec=%-s&sys=J2000&mrad=%-s&nstar=-1 HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec 00:00:00.0 degrees %0.1h radius 6.0 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type btext hskip 12 nheader 1 csystem J2000.0 nfields 7 id 1 12 INDEF %12s ra 14 12 d hours %12.3H dec 27 12 d degrees %12.2h mag1 52 4 r INDEF %4.2f mag2 58 4 r INDEF %4.2f mag3 64 4 r INDEF %4.2f dist 90 6 r minutes %6.2f begin twomass@noao address inet:80:archive.tuc.noao.edu:text query GET /cgi-bin/scat?catalog=tmc&ra=%-s&dec=%-s&sys=J2000&mrad=%-s&nstar=-1 HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec 00:00:00.0 degrees %0.1h radius 6.0 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type stext hskip 11 nheader 1 csystem J2000.0 nfields 7 id 1 0 INDEF %11s ra 2 0 d hours %12.3H dec 3 0 d degrees %12.2h mag1 4 0 r INDEF %6.3f mag2 5 0 r INDEF %6.3f mag3 6 0 r INDEF %6.3f dist 7 0 r minutes %6.2f begin twomass@irsa address inet:80:irsa.ipac.caltech.edu:text query GET /cgi-bin/Gator/nph-query?outfmt=1&objstr=%-s+%-s&spatial=Cone&radius=%-s&radunits=arcmin&catalog=fp_psc HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec 00:00:00.0 degrees %0.1h radius 1.0 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type btext hskip 19 nheader 1 csystem J2000.0 nfields 5 ra 2 10 d degrees %12.3H dec 13 10 d degrees %12.2h mag1 58 6 r INDEF %6.3f mag2 75 6 r INDEF %6.3f mag3 92 6 r INDEF %6.3f begin twomass14@irsa address inet:80:irsa.ipac.caltech.edu:text query GET /cgi-bin/Gator/nph-query?outfmt=1&objstr=%-s+%-s&spatial=Cone&radius=%-s&radunits=arcmin&catalog=fp_psc&constraints=j_m<14 HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec 00:00:00.0 degrees %0.1h radius 1.0 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type btext hskip 19 nheader 1 csystem J2000.0 nfields 5 ra 2 10 d degrees %12.3H dec 13 10 d degrees %12.2h mag1 58 6 r INDEF %6.3f mag2 75 6 r INDEF %6.3f mag3 92 6 r INDEF %6.3f begin lan92@noao address inet:80:www.noao.edu:text query GET /cgi-bin/catalogs/ccget?catalog=landolt1992.dat&lngcenter=%-s&latcenter=%-s&width=%-s&columns=c[*] HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec 00:00:00.0 degrees %0.1h width 10.0 degrees %0.3f qsystem J2000.0 INDEF %s protocol http type stext hskip 15 tskip 1 nheader 1 csystem J2000.0 nfields 17 id 1 0 c INDEF %11s ra 2 0 d hours %08.0h dec 3 0 d degrees %9.0h v 4 0 r INDEF %6.3f bv 5 0 r INDEF %6.3f ub 6 0 r INDEF %6.3f vr 7 0 r INDEF %6.3f ri 8 0 r INDEF %6.3f vi 9 0 r INDEF %6.3f n 10 0 i INDEF %2d m 11 0 i INDEF %2d ev 12 0 r INDEF %6.4f ebv 13 0 r INDEF %6.4f eub 14 0 r INDEF %6.3f evr 15 0 r INDEF %6.4f eri 16 0 r INDEF %6.4f evi 17 0 r INDEF %6.4f begin usno2@cadc address inet:80:cadcwww.dao.nrc.ca:text query GET /cadcbin/getusno2?ra=%-s&dec=%-s&radius=%-s&m=0,21&nout=1000000 HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec +00:00:00.0 degrees %0.1h radius 5 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type stext hskip 2 tskip 1 recsize 73 triml 0 trimr 0 nheader 1 csystem J2000.0 nfields 9 id 1 0 c INDEF %15s ra 2 0 d degrees %10.5f dec 3 0 d degrees %10.5f mag1 4 0 r INDEF %6.2f mag2 5 0 r INDEF %6.2f col1 6 0 r INDEF %6.2f plateno 7 0 i INDEF %4d acsstar 8 0 b INDEF %3b arcdist 9 0 r asecs %6.1f begin usno1@cadc address inet:80:cadcwww.dao.nrc.ca:text query GET /cadcbin/getusno?ra=%-s&dec=%-s&radius=%-s&m=0,21&nout=1000000 HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec +00:00:00.0 degrees %0.1h radius 5 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type stext hskip 2 tskip 1 recsize 73 triml 0 trimr 0 nheader 1 csystem J2000 nfields 9 id 1 0 c INDEF %15s ra 2 0 d degrees %10.5f dec 3 0 d degrees %10.5f mag1 4 0 r INDEF %6.2f mag2 5 0 r INDEF %6.2f col1 6 0 r INDEF %6.2f plateno 7 0 i INDEF %4d acsstar 8 0 b INDEF %3b arcdist 9 0 r asecs %6.1f begin gsc1@cadc address inet:80:cadcwww.dao.nrc.ca:text query GET /cadcbin/gsc-server?%-s,%-s&r=0,%-s&m=0,21&f=8&s=R HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec +00:00:00.0 degrees %0.1h radius 5 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type stext hskip 4 tskip 1 recsize 65 triml 0 trimr 1 nheader 1 csystem J2000 nfields 9 id 1 0 c INDEF %13s ra 2 0 d degrees %10.5f dec 3 0 d degrees %10.5f epos 4 0 r arcsecs %4.1f mag1 5 0 r INDEF %6.2f emag1 6 0 r INDEF %6.2f acsstar 7 0 c INDEF %3s arcdist 8 0 r arcmin %6.2f pangle 9 0 r degrees %4d begin hipp@cadc address inet:80:cadcwww.dao.nrc.ca:text query GET /cadcbin/hipparcos-server?ra=%-s&dec=%-s&radius=%-s HTTP/1.0\n\n nquery 4 ra 00:00:00.00 hours %0.2h dec +00:00:00.0 degrees %0.1h radius 5 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type stext hskip 2 tskip 1 recsize 0 triml 0 trimr 0 nheader 1 csystem J2000 nfields 11 id 1 0 c INDEF %8s ra 2 0 d degrees %19g dec 3 0 d degrees %19g mag1 4 0 r INDEF %6.2f px 5 0 d marcsec %6.2f pmra 6 0 d marcsec/yr %7.2f pmdec 7 0 d marcsec/yr %7.2f sptype 8 0 c INDEF %5s pangle 9 0 r degrees %3d arcdist 10 0 r arcmin %6.1f hip 11 0 c INDEF %s #begin tmass@ipac #address inet:8002:irsadev.ipac.caltech.edu:text #query GET /cgi-bin/CatRegion/nph-catregion?catalog=pt_src_cat&objstr=%-s,%-s,Equ+J2000&within=%-s+degree&select=designation,+ra,+dec,+j_m,+h_m,+k_m HTTP/1.0\n\n #nquery 4 # ra 0.00000 degrees %0.5f # dec 0.00000 degrees %0.5f # radius 0.100 degrees %0.03f # qsystem J2000.0 INDEF %s #protocol none #type stext # hskip 8 # tskip 0 # recsize 0 # triml 0 # trimr 0 #nheader 1 # csystem J2000 #nfields 6 # id 1 0 c INDEF %14s # ra 2 0 d degrees %11.6f # dec 3 0 d degrees %11.6f # mag1 4 0 r INDEF %7.3f # mag2 5 0 r INDEF %7.3f # mag3 6 0 r INDEF %7.3f begin gsc2@stsci address inet:80:www-gsss.stsci.edu:text query GET /cgi-bin/gsc22query.exe?ra=%-s&dec=%-s&r1=0.0&r2=%-s&m1=0.0&m2=19.5&n=100000&submit2=Submit+Request HTTP/1.0\n\n nquery 4 ra 00:00:00.0 hours %0.2h dec +00:00:00 degrees %0.1h radius 5 minutes %0.1f qsystem J2000.0 INDEF %s protocol http type stext hskip 2 tskip 1 recsize 0 triml 0 trimr 1 nheader 1 csystem J2000 nfields 23 id 1 0 c INDEF %12s ra 2 0 d degrees %12.8f dec 3 0 d degrees %12.8f era 4 0 d arcsec %8.6f edec 5 0 d arcsec %8.6f epoch 6 0 d years %11.6f pmra 7 0 d marcsec/yr %10.8f pmdec 8 0 d marcsec/yr %10.8f epmra 9 0 d marcsec/yr %10.8f epmdec 10 0 d marcsec/yr %10.8f mag1 11 0 r INDEF %5.2f emag1 12 0 r INDEF %5.2f mag2 13 0 r INDEF %5.2f emag2 14 0 r INDEF %5.2f mag3 15 0 r INDEF %5.2f emag3 16 0 r INDEF %5.2f mag4 17 0 r INDEF %5.2f emag4 18 0 r INDEF %5.2f smaxis 19 0 r pixels %7.2f ecc 20 0 r INDEF %4.2f pangle 21 0 r degrees %6.2f class 22 0 c INDEF %2s status 23 0 c INDEF %7s mscred-5.05-2018.07.09/src/ccdhedit.cl000066400000000000000000000012071332166314300166440ustar00rootroot00000000000000# CCDHEDIT -- Edit Mosaic CCD images. procedure ccdhedit (images, parameter, value) string images {prompt="CCD images"} string parameter {prompt="Image header parameter"} string value {prompt="Parameter value"} string extname = "" {prompt="Extension name pattern"} string type = "string" {prompt="Parameter type (string|real|integer)", enum="string|real|integer"} begin file inlist inlist = mktemp ("tmp$iraf") mscextensions (images, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > inlist) _ccdhedit ("@"//inlist, parameter, value, type=type) delete (inlist, verify=no) end mscred-5.05-2018.07.09/src/ccdlist.cl000066400000000000000000000017141332166314300165250ustar00rootroot00000000000000# CCDLIST -- List Mosaic CCD images. procedure ccdlist (images) string images {prompt="CCD images to listed"} string ccdtype = "" {prompt="CCD image type to be listed"} string extname = "" {prompt="Extension name pattern"} bool names = no {prompt="List image names only?"} bool long = no {prompt="Long format listing?"} begin file inlist inlist = mktemp ("tmp$iraf") if (extname == "mef" && names && !long) { mscextensions (images, output="file", index="1", extname="", extver="", lindex=no, lname=no, lver=no, ikparams="", > inlist) _ccdlist ("@"//inlist, ccdtype=ccdtype, names=names, long=long, ccdproc="") | translit ("STDIN", "[", " ", del-) | fields ("STDIN", 1, lines="1-") } else { mscextensions (images, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > inlist) _ccdlist ("@"//inlist, ccdtype=ccdtype, names=names, long=long, ccdproc="") } delete (inlist, verify=no) end mscred-5.05-2018.07.09/src/ccdproc.cl000066400000000000000000000423321332166314300165160ustar00rootroot00000000000000# CCDPROC -- Process Mosaic CCD data. procedure ccdproc (images) string images = "" {prompt="List of Mosaic CCD images to process"} string output = "" {prompt="List of output processed images"} string bpmasks = "" {prompt="List of output bad pixel masks"} string ccdtype = "object" {prompt="CCD image type to process"} bool noproc = no {prompt="List processing steps only?\n"} bool xtalkcor = no {prompt="Apply crosstalk correction?"} bool fixpix = yes {prompt="Apply bad pixel mask correction?"} bool overscan = yes {prompt="Apply overscan strip correction?"} bool trim = yes {prompt="Trim the image?"} bool zerocor = yes {prompt="Apply zero level correction?"} bool darkcor = yes {prompt="Apply dark count correction?"} bool flatcor = yes {prompt="Apply flat field correction?"} bool sflatcor = no {prompt="Apply sky flat field correction?"} bool split = no {prompt="Use split images during processing?"} bool merge = yes {prompt="Merge amplifiers from same CCD?\n"} string xtalkfile = "" {prompt="Crosstalk file"} string fixfile = "" {prompt="List of bad pixel masks"} string saturation = "INDEF" {prompt="Saturated pixel threshold"} int sgrow = 0 {prompt="Saturated pixel grow radius"} string bleed = "INDEF" {prompt="Bleed pixel threshold"} int btrail = 20 {prompt="Bleed trail minimum length"} int bgrow = 0 {prompt="Bleed pixel grow radius"} string biassec = "" {prompt="Overscan strip image section"} string trimsec = "" {prompt="Trim data section"} string zero = "" {prompt="List of zero level calibration images"} string dark = "" {prompt="List of dark count calibration images"} string flat = "" {prompt="List of flat field images"} string sflat = "" {prompt="List of secondary flat field images"} real minreplace = 1. {prompt="Minimum flat field value\n"} bool interactive = no {prompt="Fit overscan interactively?"} string function = "minmax" {prompt="Fitting function"} int order = 1 {prompt="Number of polynomial terms or spline pieces", min=1} string sample = "*" {prompt="Sample points to fit"} int naverage = 1 {prompt="Number of sample points to combine"} int niterate = 1 {prompt="Number of rejection iterations", min=0} real low_reject = 3. {prompt="Low sigma rejection factor", min=0.} real high_reject = 3. {prompt="High sigma rejection factor", min=0.} real grow = 0. {prompt="Rejection growing radius", min=0.} struct *fd, *fd2 begin bool mef, splt int nimages, len string ims, fixf, extname, bpmname, tmproot, tmpfname, ext1 file input, outname, bpmask file outtemp, xtalktemp, mergetemp, mergemask, mergeinput, cal1, cal2 file inlist, inbpmlist, zerolist, darklist, flatlist, sflatlist file extlist, outlist, bpmlist, xtlist, mergelist, moutlist, templist file out cache mscextensions, sections # Create temporary filenames. tmproot = mktemp ("tmp$ccdproc") templist = tmproot // "A" inlist = tmproot // "B" outlist = tmproot // "C" extlist = tmproot // "D" bpmlist = tmproot // "E" xtlist = tmproot // "F" mergelist = tmproot // "G" moutlist = tmproot // "H" inbpmlist = tmproot // "I" zerolist = tmproot // "J" darklist = tmproot // "K" flatlist = tmproot // "L" sflatlist = tmproot // "M" outtemp = tmproot // "N" xtalktemp = tmproot // "O" mergetemp = tmproot // "P" mergemask = tmproot // "Q" cal1 = tmproot // "R" cal2 = tmproot // "S" print (inlist, >> templist) print (outlist, >> templist) print (extlist, >> templist) print (bpmlist, >> templist) print (xtlist, >> templist) print (mergelist, >> templist) print (moutlist, >> templist) print (inbpmlist, >> templist) print (zerolist, >> templist) print (darklist, >> templist) print (flatlist, >> templist) print (sflatlist, >> templist) print (cal1, >> templist) print (cal2, >> templist) # Expand the input and output lists. Use workaround for # ccdlist using the ccdproc pset which confuses later scans. #sections (images, option="root", > cal1) tmpfname = _ccdlist.ccdproc; _ccdlist.ccdproc="setinstrument" ccdlist (images, ccdtype=ccdtype, extname="mef", names+, long-, > cal1) _ccdlist.ccdproc=tmpfname sections ("@"//cal1, option="root", > "dev$null") nimages = sections.nimages sections (output, option="root") | joinlines (cal1, "STDIN", output=cal2, delim=" ", missing="-", maxchars=161, shortest=no, verbose=no) delete (cal1, verify=no, >& "dev$null") if (sections.nimages > 0 && sections.nimages != nimages) { delete (cal2, verify=no, >& "dev$null") error (1, "Input and output lists do not match") } sections (bpmasks, option="root") | joinlines (cal2, "STDIN", output=inlist, delim=" ", missing="-", maxchars=161, shortest=no, verbose=no) delete (cal2, verify=no, >& "dev$null") if (sections.nimages > 0 && sections.nimages != nimages) { delete (inlist, verify=no, >& "dev$null") error (1, "Input and mask lists do not match") } # Expand the calibration images into image extensions. fixf = fixfile if (stridx("!",fixf)==0) { mscextensions (fixf, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > inbpmlist) fixf = "@"//inbpmlist } mscextensions (zero, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > zerolist) mscextensions (dark, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > darklist) mscextensions (flat, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > flatlist) mscextensions (sflat, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > sflatlist) # Process the data. fd = inlist while (fscan (fd, input, outname, bpmask) != EOF) { if (outname == "-") { if (split) outname = input else outname = outtemp } if (bpmask == "-") bpmask = "" # Strip FITS extension from output name. len = strlen (outname) if (len > 5) if (substr (outname, len-4, len) == ".fits") outname = substr (outname, 1, len-5) # Expand the input image into image extensions. mscextensions (input, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) nimages = mscextensions.nimages mef = mscextensions.imext if (nimages == 0) { delete (extlist, verify-) next } # Expand and check output images. splt = (mef && split) if (splt) { ext1 = "" fd2 = extlist while (fscan (fd2, extname) != EOF) { if (ext1 == "") ext1 = "_" // substr (extname, stridx("[",extname)+1,stridx("]",extname)-1) tmpfname = outname // "_" // substr (extname, stridx("[",extname)+1,stridx("]",extname)-1) if (imaccess (tmpfname) == YES) break print (tmpfname, >> outlist) if (merge) { tmpfname = mergetemp // "_" // substr (extname, stridx("[",extname)+1,stridx("]",extname)-1) print (tmpfname, >> mergelist) } } fd2 = "" if (imaccess (tmpfname) == YES) { if (access (outlist)) delete (outlist, verify-) delete (extlist, verify-) printf ("WARNING: Output image already exists (%s)\n", tmpfname) next } } else { ext1 = "[1]" if (imaccess (outname//"[0]") == YES) { delete (extlist, verify-) printf ("WARNING: Output image already exists (%s)\n", outname) next } if (defvar (outname)) print ("./" // outname, > outlist) else print (outname, > outlist) if (merge) print (mergetemp, > mergelist) } # Set output mask names. bpmname = "" if (bpmask != "") { if (bpmask == input || bpmask == output || bpmask//".fits" == input || bpmask//".fits" == output) bpmask = bpmask // "_bpm" if (mef) { if (!access (bpmask)) mkdir (bpmask) fd2 = extlist while (fscan (fd2, extname) != EOF) { tmpfname = bpmask // "/bpm_" // substr (extname, stridx("[",extname)+1,stridx("]",extname)-1) print (tmpfname, >> bpmlist) } fd2 = "" bpmname = "@"//bpmlist } else bpmname = bpmask } # Do crosstalk correction. if (mef && xtalkcor) { xtalkcor (input, xtalktemp, "", xtalkfile=xtalkfile, split=splt, fextn="fits", noproc=noproc) if (splt) { mscextensions (xtalktemp//"_*", output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (extlist, "STDIN", output=xtlist, delim=" ", missing="-", maxchars=161, shortest=no, verbose=no) } else { mscextensions (xtalktemp, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (extlist, "STDIN", output=xtlist, delim=" ", missing="-", maxchars=161, shortest=no, verbose=no) } delete (extlist, verify-) if (mscextensions.nimages == nimages) { fd2 = xtlist while (fscan (fd2, tmpfname, extname) != EOF) { hedit (extname, "TMPFNAME", tmpfname, add+, del-, show-, verify-, update+) print (extname, >> extlist) } fd2 = ""; delete (xtlist, verify-) if (splt) copy (extlist, xtlist, verbose-) else { print (xtalktemp, > xtlist) sleep (1) # Delay to help FITS kernel cache imcopy (xtalktemp//"[0]", outname, verbose=no) } } else { delete (xtlist, verify-) mscextensions (input, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) } } # Process the input image extensions. if (splt) { out = "@" // outlist } else { sleep (1) # Delay to help FITS kernel cache if (mef && !imaccess (outname//"[0]")) imcopy (input//"[0]", outname, verbose=no) out = outname // "[inherit]" } _ccdtool ("@"//extlist, out, "", bpmname, calproc=cal1, nointerp="", ccdtype=ccdtype, proctype="", max_cache=0, noproc=noproc, onerror="original", overscan=overscan, trim=trim, fixpix=fixpix, zerocor=zerocor, darkcor=darkcor, flatcor=flatcor, sflatcor=sflatcor, illumcor=no, fringecor=no, readcor=no, scancor=no, readaxis="line", saturation=saturation, sgrow=sgrow, bleed=bleed, btrail=btrail, bgrow=bgrow, biassec=biassec, trimsec=trimsec, fixfile=fixf, zero="@"//zerolist, dark="@"//darklist, flat="@"//flatlist, sflat="@"//sflatlist, minreplace=minreplace, interactive=interactive, function=function, order=order, sample=sample, naverage=naverage, niterate=niterate, low_reject=low_reject, high_reject=high_reject, grow=grow) flpr # If calibration images need to be processed first process them. if (access (cal1)) { # Convert list of extensions to parent image names. mscuniq (cal1, cal2) delete (cal1, verify=no) # Process the calibration images. calproc (images=cal2, noproc=noproc, xtalkcor=xtalkcor, overscan=overscan, trim=trim, fixpix=fixpix, zerocor=zerocor, darkcor=darkcor, flatcor=flatcor, sflatcor=sflatcor, merge=merge, xtalkfile=xtalkfile, fixfile=fixf, biassec=biassec, trimsec=trimsec, zero="@"//zerolist, dark="@"//darklist, flat="@"//flatlist, sflat="@"//sflatlist, minreplace=minreplace, interactive=interactive, function=function, order=order, sample=sample, naverage=naverage, niterate=niterate, low_reject=low_reject, high_reject=high_reject, grow=grow) delete (cal2, verify=no) # Reset calibration lists in case of merging. if (merge) { delete (zerolist, verify-) mscextensions (zero, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > zerolist) delete (darklist, verify-) mscextensions (dark, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > darklist) delete (flatlist, verify-) mscextensions (flat, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > flatlist) delete (sflatlist, verify-) mscextensions (sflat, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > sflatlist) } # Now process the input image. _ccdtool ("@"//extlist, out, "", bpmname, calproc=cal1, ccdtype=ccdtype, proctype="", nointerp="", max_cache=0, noproc=noproc, onerror="original", overscan=overscan, trim=trim, fixpix=fixpix, zerocor=zerocor, darkcor=darkcor, flatcor=flatcor, sflatcor=sflatcor, illumcor=no, fringecor=no, readcor=no, scancor=no, saturation=saturation, sgrow=sgrow, bleed=bleed, btrail=btrail, bgrow=bgrow, readaxis="line", biassec=biassec, trimsec=trimsec, fixfile=fixf, zero="@"//zerolist, dark="@"//darklist, flat="@"//flatlist, sflat="@"//sflatlist, minreplace=minreplace, interactive=interactive, function=function, order=order, sample=sample, naverage=naverage, niterate=niterate, low_reject=low_reject, high_reject=high_reject, grow=grow) flpr # It is an error if there are calibration images to process. if (access (cal1)) { fd = "" imdelete ("@"//outlist, verify=no) delete ("@"//templist, verify=no, >& "dev$null") delete (templist, verify=no) error (1, "Error processing " // input) } } # If no processing occurred delete output. # If xtalkcor was done then either delete intermediate file # or rename to output. if (mef) { if (imaccess (outname//ext1)) { if (access (xtlist)) imdelete ("@"//xtlist, verify=no) } else { imdelete ("@"//outlist, verify=no, >& "dev$null") if (access (xtlist)) imrename ("@"//xtlist, "@"//outlist, verbose-) } } # Merge amplifiers if desired. if (merge && mef) { if (imaccess (outname//ext1)) { imrename ("@"//outlist, "@"//mergelist, verbose-) mergeinput = "@" // mergelist flpr } else { imdelete ("@"//outlist, verify=no, >& "dev$null") if (splt) mergeinput = "@" // extlist else mergeinput = input } if (bpmask == "") mergeamps (mergeinput, outname, "", headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigmas="", outnames=moutlist, imcmb="$I", ccdtype="", amps=yes, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="physical", masktype="none", maskvalue=0., blank=1., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., verbose=no) else mergeamps (mergeinput, outname, bpmask//"/", headers="", bpmasks=bpmask//"/"//mergemask, imcmb="$I", rejmasks="", nrejmasks="", expmasks="", sigmas="", outnames=moutlist, ccdtype="", amps=yes, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="physical", masktype="none", maskvalue=0., blank=1., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., verbose=no) if (access (moutlist) && verbose) { if (splt) printf ("%s: Merge amplifiers to ", input) else printf ("%s: Merge amplifiers\n", input) } if (mergeinput == "@" // mergelist) { if (access (moutlist)) { imdelete (mergeinput, verify-) if (bpmname != "") imdelete (bpmname, verify-) delete (outlist, verify-) rename (moutlist, outlist, field="all") } else imrename ("@"//mergelist, "@"//outlist, verbose=no) } if (access (mergelist)) delete (mergelist, verify-) if (access (moutlist)) delete (moutlist, verify-) } # Check if the input was processed. # If so make backup and rename the temporary output to the # original image name. If CCDMEAN is defined compute a # global mean. delete (extlist, verify=no) mscextensions ("@"//outlist, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) if (mscextensions.nimages > 0) { if (mscextensions.nimages > 1) { type (extlist) | scan (tmpfname) hselect (tmpfname, "ccdmean", yes) | scan (x) if (nscan() > 0) { hselect ("@"//extlist, "ccdmean", yes) | average | scan (x) hedit ("@"//extlist, "ccdmean,ccdmeant", add-, del+, verify-, show-, update+) if (splt) { hedit ("@"//extlist, "ccdmean", x, add+, del-, verify-, show-, update+) } else { hedit (outname//"[0]", "ccdmean", x, add+, del-, verify-, show-, update+) } } hedit ("@"//extlist, "tmpfname", add-, del+, verify-, show-, update+) } if (!splt && outname == outtemp) { ccddelete (input) if (defvar (input)) imrename (outname, "./"//input, verbose=no) else imrename (outname, input, verbose=no) } } else imdelete ("@"//outlist, verify=no, >& "dev$null") delete (extlist, verify=no) if (access (outlist)) delete (outlist, verify=no) if (access (bpmlist)) delete (bpmlist, verify=no) if (access (xtlist)) delete (xtlist, verify=no) if (access (mergelist)) delete (mergelist, verify=no) } # Delete all temporary files. fd = "" delete ("@"//templist, verify=no, >& "dev$null") delete (templist, verify=no) end mscred-5.05-2018.07.09/src/ccdred/000077500000000000000000000000001332166314300160015ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/Revisions000066400000000000000000001650541332166314300177200ustar00rootroot00000000000000.help revisions Jun88 noao.imred.ccdred .nf REMOVE FIXPIX WORKAROUND WHEN V2.11.2 PATCH IS RELEASE. setsection.x The ltv calculation was wrong when LTM1_1/LTM2_2 are negative. (8/12/08, Valdes) ccdred.h cor.gx proc.gx setflat.x Added an option to convert data to electrons or electrons/s during flat fielding provided the (translated) keyword GAINNORM is in the header. This is implemented by modifying the flat field normalization value which is why it can only be done during flat fielding. ( 9/17/03, Valdes) /setoverscan.x Added the keyword OVSNMEAN to give the mean overscan as a separate keyword. This is used for keyword monitoring. (9/17/03, Valdes) setsection.x The ltv calculation was wrong when LTM1_1/LTM2_2 are negative. (7/28/03, Valdes) setsaturate.x The "saturation?value" parsing had a bug. (10/23/02, Valdes) ccdred$src/combine/src/icmask.x There was a bug in the recent change to open and close masks as needed where a possibly null filename pointer was being checked for being a null string. (4/8/02, Valdes) ccdred$darkcombine.cl ccdred$flatcombine.cl ccdred$sflatcombine.cl ccdred$zerocombine.cl Added default for new "outlimits" parameter in combine. (4/3/02, Valdes) ccdred$src/t_ccdlist.x The skyflat correction keyword is "sflatcor" instead of "skyflat". (3/28/02, Valdes/Conroy) ccdred$src/combine/t_combine.x In cmb_images it now uses extension [1] instead of [0] to determine if the file is mef and to get the header keywords which may not be in a global header. (3/28/02, Valdes/Conroy) ccdred$src/combine/t_combine.x An error is no printed if an @file for the scales, zeros, or weights does not contain enough numeric values. (2/19/02, Valdes) xtprocid.x gpatmatch called as subroutine but should be an int function. (7/17/01, Valdes) readcor.x scancor.x Incorrect arguments for set_output. Since these routines are not used for mosaic data replace with an error statement for now. (7/17/01, Valdes) setsaturate.x Replace pargr with pargi when used with SATGROW. (7/17/01, Valdes) proc.gx t_bleed.x Calls to bld_open were wrong. (7/17/01, Valdes) ichdr.x The input procids and image names are only written to the output if there are less than 99 input images. (6/16/01, Valdes) xtimmap.x + icgdata.gx icombine.gx icscale.x t_combine.x mkpkg Modified to use xtimmap to control the large number of images. (6/16/01) ccdtypes.x The ccdstr procedure to encode the type as a string did not have a case for sky flat. (6/11/01, Valdes) t_combine.x The T_AMPMERGE procedure was revised to call a new routine, MASKMERGE, to merge pixel masks using physical coordinate registration. A mask is produced if there is more than one mask from the set of the mask produced during combining and unique input masks. Empty masks are ignored. If there is no mask data or all are the same then the BPM keyword is unset or set to the common mask. When there is more than one mask an output mask is the computed as the maximum value from all the masks. The output mask name is the output combined image rootname with the extension "_bpmN", where N is extension number. (3/15/01, Valdes) setoutput.x If the offset type is not world or wcs then the physical coordinate system is NOT reset. This is needed for merging amplifiers. (3/15/01, Valdes) t_ccdgroups.x ccdgroups.par Added "ccdname" as a grouping type. (3/14/01, Valdes) bleed.x + bleed.com + t_bleed.x + setinmask.x + setsaturate.x + proc.gx setproc.x setheader.x ccdproc.x ccdcheck.x setoutput.x setbpmask.x setfixpix.x t_ccdproc.x ccdred.h ccdproc.par mkpkg 1. New parameters "sgrow", "bleed", "btrail", and "bgrow". 2. New algorithm to find and grow saturated pixels and bleed trails. 3. Saturated and bleed pixels may be added to an output mask. 4. Saturated and bleed pixel may be "fixed" in the data. 5. If no input bad pixel mask is given it is treated as an empty mask. calimage.x The input bad pixel mask is not required to match by amplifier and CCD when it is specified by a header keyword. (3/13/01, Valdes) setheader.x The check on a flip between target and calibration is not done. (3/6/01, Valdes) setheader.x CCDPROC now calls xt_procid to create or update the PROCID keyword. (2/5/01, Valdes) darkcombine.cl flatcombine.cl sflatcombine.cl zerocombine.cl Updated to explicitly pass null strings for the new optional combine/mergeamps output. (2/5/01, Valdes) t_combine.x icombine.gx icscale.x iclog.x icemask.x + ichdr.x + xtprocid.x + mkpkg combine.par coutput.par mergeamps.par 1. New output parameters added: "headers", "bpmasks", "rejmasks", "nrejmasks", "expmasks", "sigmas". 2. Old output parameters removed: "plfile", "rejmask", "sigma". 3. Dataless extensions of the input headers are recorded in the optional output FITS MEF files specified by the "headers" parameter. 4. Bad pixel masks with 0 for data and 1 for no data are recorded in the optional output masks specified by the "bpmasks" parameter. The output header contains the keyword BPM pointing to the mask. 5. Masks with the number of pixels rejected are now specified by the parameter "nrejmasks" instead of "plfile". 6. Exposure masks, which are the sum of the exposure times of the data combined, are recorded in the optional output masks specified by "expmasks". 7. The input data is scaled to the first input image and the output header is a copy of the first input image. 8. The exposure time and dark time keywords are no longer modified from the input times. The output will just contain a copy of the times from the first input image header. 9. The keyword NCOMBINE, PROCID, PROCIDnn, and IMCMBnnn are added modified or added to the output. 10. The log output includes the names the extra output files if specified. (2/5/01, Valdes) setsections.x The matching of DATASEC and CCDSEC was not right with binning. (2/6/01, Valdes) icgrow.gx Added a step to periodically compress the masks. (2/2/01, Valdes) ccdred.h Increased length of log strings to 199. This is to avoid String_File errors when the filenames are too long. (1/16/01, Valdes) t_combine.x Added check for just a single image to combine. This is used by MERGEAMPS to avoid merging when not necessary. (1/5/01, Valdes) ccdamps.x When getting the amp or ccdname logical keywords try imageid followed by extname if no value is found. (12/28/00, Valdes) setfixpix.x setproc.x calimage.x Modified to use yt_pmunmap instead of imunmap in order to free the pl pointer. (12/13/00, Valdes) xtpmmap.x A version that contains yt_pmunmap for use until the next release of IRAF xtools includes xt_pmunmap. (12/13/00, Valdes) t_combine.x Modified the conversion of pclip from a fraction to a number of images because for even number of images the number above/below the median is one too small. (9/26/00, Valdes) t_combine.x icimstack.x Error handling when running out of memory with immap (due to a very large min_lenuserarea) and when trying to stack was fixed up to report reasonable error messages and to not go into an infinite loop trying to manage memory. (9/13/00, Valdes) iccombine.gx icgdata.gx Additional errchk declarations were needed to catch out of memory during image reading which were not caught during the initial pass at reading the images. (9/11/00, Valdes) t_combine.x If an error occurs in mapping an image at an early stage it was possible to get into an infinite loop. (9/1/00, Valdes) t_combine.x When there is an error with an MEF image then the error recovery to delete the image would fail since you can't delete an extension. Added a higher level step in mefcombine to delete the output in the case of an error (8/30/00, Valdes) ccdred/src/imcombine/t_combine.x ccdred/src/imcombine/icscale.x For MEF data there was no error check on the statistics calculation. If a bad pixel mask (or thresholds) excluded all the pixels in the section then a segmentation error would result rather than an error message. An errchk was added. Also the scaling computation was moved to before the output header is created to avoid an image being left behind in case of an error. (7/31/00, Valdes) ccdred/src/imcombine/t_combine.x ccdred/src/imcombine/icimstack.x ccdred/src/imcombine/iclog.x When there are a large number of images with bad pixel masks both the input images and the bad pixel masks are stacked for combining. The addition of stacking the masks allows for independent bad pixel masks for each input image which was not supported previously. (6/21/00, Valdes, 8/21/00 Valdes) ccdred/src/icmedian.gx Replaced with faster Wirth algorithm. (5/16/00, Valdes) ccdred/src/icgdata.gx ccdred/src/iclog.x ccdred/src/icmask.x ccdred/src/icombine.gx ccdred/src/icscale.x ccdred/src/icsetout.x Changed declarations for the array "out" to be ARB rather than 3 in some places (because it was not changed when another element was added) or 4. This will insure that any future output elements added will no require changing these arguments for the sake of cosmetic correctness. (1/13/99, Valdes) ccdred/src/icsetout.x Fixed error with MWCS dimension mismatch when using offsets on input images which have been dimensionally reduced. (1/12/00, Valdes) cccdred/src/calimage.x Will now print error message from xt_pmmap to explain why a bad pixel mask was not found. (12/17/99, Valdes) ccdred/src/ccdproc.x Modified to make errors in the setup be warnings. (11/4/99, Valdes) ccdred/src/setbpmask.x + ccdred/src/calimage.x ccdred/src/ccdcache.x ccdred/src/ccdcheck.x ccdred/src/ccdproc.x ccdred/src/ccdred.h ccdred/src/mkpkg ccdred/src/proc.gx ccdred/src/setdark.x ccdred/src/setflat.x ccdred/src/setheader.x ccdred/src/setoutput.x ccdred/src/setproc.x ccdred/src/setsflat.x ccdred/src/setzero.x ccdred/src/t_ccdproc.x ccdred/src/t_ccdtool.x ccdred/src/setfixpix.x ccdred/src/generic/ccdred.h ccdred/src/mkpkg ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl Added output saturated pixel masks. ccdred$src/t_ccdgroups.x ccdred$ccdgroups.par 1. Added parameter to break into sequences. 2. Added verbose parameter to provide more control than just the package. (9/22/99, Valdes) ccdred$src/icsetout.x Changed to better parse the offset types. The WCS correction for offsets was incorrect. (6/17/99, Valdes) ccdred$src/icgdata.gx If a line had no data then the number of pixels needed to be initialized. (7/29/98, Valdes) ccdred$src/iclog.x Added logging of rejection mask. (7/29/98, Valdes) ccdred$src/setproc.x Added workaround for xtools fixpix bug not setting the pixel type. (7/20/98, Valdes) ccdred$src/ccdtypes.x Fixed bug with stripping whitespace from ccdtype string. (7/20/98, Valdes) ccdred/src/t_ccdproc.x ccdred/ccdproc.par ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl 1. Added "output" parameter to CCDPROC. 2. The combine scripts behave as before. (6/19/98, Valdes) ccdred/src/fpfx.gx Fixed bug with going out-of-bounds on FP_COL. (6/5/98, Valdes) ccdred/src/cor.gx ccdred/src/proc.gx New version that normalizes the flat field first and checks for extreme flat field values. If an extreme flat field value is found then the value is replaced by 1; i.e. the flat field is skipped if the flat field value is extreme. (6/1/98, Valdes) ccdred/src/t_combine.x ccdred/src/icombine.gx ccdred/src/icrmasks.x + ccdred/src/mkpkg ccdred/combine.par ccdred/coutput.par ccdred/darkcombine.cl ccdred/flatcombine.cl ccdred/sflatcombine.cl ccdred/zerocombine.cl Modifications to add an output mask of rejected pixels from each input image. (5/18/98, Valdes - and 6/10/98 typo fix) ccdred/src/proc.gx ccdred/src/ccdmean.x The mean computation was changed to do a 2 pass, 2 sigma sigma clip on each output line. The final mean is the mean over all the lines weighted by the number of pixels used in each line mean. (3/24/98, Valdes) ccdred/src/icscale.x For MEF files the statistics section can be an @file with sections for each subset and any line that is not a section will cause that subset not to be used. (10/31/97, Valdes) ccdred/src/t_combine.x ccdred/src/icscale.x ccdred/src/icombine.gx ccdred/src/icombine.com ccdred/combine.par ccdred/src/iclog.x COMBINE will now operate on both regular images and MEF files. 1. The scales, zeros, and wts arrays are not passed down from the top of the program rather than created in icombine$t. This allows values to be set earlier which are then not changed by lower levels such as in icscale. 2. The common block now includes the statistics section so that it will only be queried once. 3. cmb_images detects the type of input data. The "extensions" parameter is not needed and the functions are determined by detecting the type of input data. 4. cmb_images reads any scale factors from a file and assigned to the images before the images are reordered by grouping. For MEF data there is then one value per file. 5. For MEF data there are new routines that take care of extracting the extensions and compute scaling factors from image statistics by combining the statistics from the extensions into one value. 6. icscale now checks for previously defined scaling factors and leaves them unchanged. (10/29/97, Valdes) ccdred$src/setsections. Generalized the LTERM update to work with arbitrary WCSDIM. (7/24/97, Valdes) ----- The following changes were logged Jan 17, 1997. ccdred$src/t_ccdgroups.x ccdred$ccdgroup.par New grouping parameters are "amplifier" and "ampsubset" to group by the new CCDRED parameters of amplier or the combination of amplifier and subset. The title and date group types were removed and a new group type "keyword" was added. There is a new parameter "keyword" that specifies the header keyword to use for grouping. By using the keyword group type and specifying the title or date-obs keyword the previous functionality is preserved. Obviously by allowing any keyword for grouping there is now additional functionality. ccdred$mkpkg ccdred$src/ccddelete.x ccdred$ccddelete.par + ccdred$x_ccdred.x New CL callable task to do the backup/delete operation provided in CCDPROC and COMBINE. This task is not defined in CCDRED but is used in scripts such as in the CCD Mosaic package. ccdred$ccdred.par New "im_bufsize" parameter to better control IMIO buffering. ccdred$src/calimage.h ccdred$src/calimage.x Modifications to allow checking of amp and to specify calibration files by keyword. The "fixfile" mask was added as a calibration image type. ccdred$src/ccdcache.com ccdred$src/ccdcache.x Added support for the IMIO buffer size parameter. Added support for USHORT. Flat fields are no longer cached. Simplified caching. ccdred$src/ccdcheck.x Commented out checks on CCDMEAN and CCDMEANT since this will be handled differently in the various setup routines. ccdred$src/ccdcopy.x Change to have image pointer instead of image names as arguments. ccdred$src/ccdlog.x ccdred$src/ccdproc.x ccdred$src/t_mkfringe.x ccdred$src/t_mkillumcor.x ccdred$src/t_mkillumft.x ccdred$src/t_mkskycor.x Make significant changes to buffer the log information and then flush it on demand. ccdred$src/ccdmean.x Changed to be called with an image pointer rather than an image name. ccdred$src/ccdred.h Restructured, new structure parameters, and addition of overscan types. ccdred$src/ccdtypes.x ccdred$src/t_ccdinst.x ccdred$src/t_ccdlist.x ccdred$src/t_combine.x New procedure names and new procedures have been added to deal with decoding the ccdtypes. ccdred$src/iclog.x Eliminate the use of the TEMPNAME keyword since clobbering is no longer allowed and temp image names are not used. ccdred$src/proc.gx Make changes for the line-by-line overscan correction. ccdred$src/scancor.x Modified for new arguments in set_output. ccdred$src/setzero.x ccdred$src/setdark.x ccdred$src/setflat.x ccdred$src/setfringe.x ccdred$src/setillum.x Uses new IN_CCDTYPE structure parameter. Uses new CALPROC structure parameter to choose ccdproc1 or ccdproc2 for calibration. Uses new logging structure parameter. ccdred$src/setdark. x It is now an error if the darktime is zero. ccdred$src/setflat.x ccdred$src/setillum.x The ccdmean calculation is no longer a CCDPROC flag (that is passed on to a recursive call to ccdproc for calculation) but is computed in this procedure if necessary. ccdred$src/setfixpix.x Uses xt_pmmap for doing the coordinate matching. ccdred$src/setheader.x Adds a fudge delay in ccdmeant. Adds physical WCS corresponding to the CCD coordinates. ccdred$src/setoutput.x Because the output image is now not mapped until all the setup stuff is done the image size is set based on the trim parameters in the ccd data structure which is a new procedure argument. ccdred$src/setoverscan.x Modified to use the new overscan type parameter. Uses new IN_CCDTYPE structure parameter. ccdred$src/setproc.x ccdred$src/ccdproc.x ccdred$src/t_mkfringcor.x ccdred$src/t_mkillumcor.x ccdred$src/t_mkillumft.x ccdred$src/t_mkskycor.x The output image pointer is no longer and argument. New arguments are proc, calproc, and listproc flags to be set in the ccd data structure. ccdred$src/setsection.x The physical WCS is set to the CCD section coordinates based on the CCDSEC keyword. This is then used to map the pixel mask to the input data. ccdred$src/settrim.x The new TRIM data structure parameters are set. The new TRIMLOG parameters and logging routine is used. ccdred$src/setinput.x - ccdred$src/ccdproc.x ccdred$src/t_mkfringe.x ccdred$src/t_mkillumcor.x ccdred$src/t_mkillumft.x ccdred$src/t_mkskycor.x ccdred$src/t_mkskyflat.x ccdred$src/t_combine.x Removed use of set_input. ccdred$darkcombine.cl ccdred$flatcombine.cl ccdred$zerocombine.cl ccdred$src/t_combine.x ccdred$combine.par New "extensions" parameter to control whether to create output image names with the subset extension. If set to no this allows the same output name to be used for building up multiextension FITS files. Because of the possibility of appending to existing output FITS images the "clobber" option was removed. ccdred$src/t_ccdproc.x The task procedure t_ccdproc is now just a interface to calling a new ccdproc. It specifies that the output image is the same as the input image, that the processing type is the same as the selection type, and that calibration image processing is allowed. This is the same behavior as previously. ccdred$src/t_ccdtool.x + ccdred$ccdtool.par ccdred$x_ccdred.x A new task procedure, t_ccdtool, has been added that calls the new ccdproc. This specifies an output image, a processing type which may be different than the selection type, and does not allow calibration image processing. Instead calibration images that need to be processed are recorded in a file and the input images are not processed. ccdred$src/ccdproc.x The old ccdproc procedure is now ccdproc1. The new ccdproc2 procedure is called to log the calibration images that must be processed when calibration processing is turned off. The new ccdproc procedure is largely what the old t_ccdproc was. It has additions for possibly having a different output images, selecting a different processing type from the ccdtype selection, and a flag to turn off calibration image processing. It has be restructured to do all the setup stuff before opening the output image so that if no processing is needed an output file is never opened. It allows cached images to remain in the process cache between executions of the task. ccdred$src/setreadcor.x + New procedure to set the readout correction flag. ----- ccdred$src/ccddelete.x ccdred$ccddelete.par ccdred$x_ccdred.x ccdred$doc/ccddelete.hlp + Added a CL callable version of the delete/backup procedure. (1/14/97, Valdes) ccdred$src/setsections.x ccdred$src/setheader.x Modified to set physical WCS to be the CCD coordinates. (1/14/97, Valdes) ccdred$src/ccdred.h ccdred$src/setoverscan.x ccdred$proc.gx Added mean, median, and minmax overscan subtraction types. (11/18/96, Valdes) ----- ccdred$t_mkfringe.x ccdred$t_mkillumcor.x ccdred$t_mkillumft.x ccdred$t_mkskycor.x ccdred$t_mkskyflat.x Replaced calls to ccdcopy with calls to imcopy. (8/23/96, Valdes) ccdred$doc/* The help was updated for all the changes noted below. (8/14/96, Valdes) ccdred$src/calimage.x ccdred$src/setsections.x ccdred$src/t_ccdlist.x The parameters biassec, trimsec, fixfile, zero, dark, flat, illum, and fringe now allow the specification ! to specify a keyword to be used. (8/14/96, Valdes) ccdred$ccdtest/demo.cl - ccdred$ccdtest/demo.par - ccdred$ccdtest/demo.hlp - ccdred$ccdtest/demo.dat - ccdred$ccdtest/badpix.dat - ccdred$ccdtest/demos/ + ccdred$ccdtest/demos/badpix.dat + ccdred$ccdtest/demos/ccdred.cl + ccdred$ccdtest/demos/ccdred.dat + ccdred$ccdtest/demos/demos.cl + ccdred$ccdtest/demos/demos.men + ccdred$ccdtest/demos/demos.par + ccdred$ccdtest/ccdtest.cl ccdred$ccdtest/ccdtest.hd ccdred$ccdtest/ccdtest.men The old DEMO task was eliminated and the new DEMOS task, the same as used in other packages, which can be extended by adding script files to the demos directory was added. The old demo is now "demos ccdred". Revisions to the demos will be noted in a Revisions file in that directory. (8/13/96, Valdes) ccdred$ccdtest/t_mkimage.x - ccdred$ccdtest/mkimage.par - ccdred$ccdtest/mkimage.hlp - ccdred$ccdtest/mkpkg - ccdred$ccdtest/artobs.cl ccdred$ccdtest/ccdtest.cl ccdred$ccdtest/ccdtest.hd ccdred$ccdtest/ccdtest.men ccdred$mkpkg MKIMAGE was a prototype for MKPATTERN. The ARTOBS script was rewritten to use MKPATTERN and MKIMAGE was eliminated. There are now no compiled tasks in CCDTEST. (8/13/96, Valdes) ccdred$src/ccdamp.x + ccdred$src/calimage.h + ccdred$src/calimage.x ccdred$src/t_ccdgroups.x ccdred$src/t_ccdlist.x ccdred$src/ccdinst1.key ccdred$src/ccdinst2.key ccdred$src/ccdinst3.key ccdred$src/t_combine.x ccdred$src/t_ccdinst.x ccdred$src/mkpkg ccdred$ccdred.par ccdred$ccdgroups.par 1. Images may now be grouped by an "amp" parameter. This parameter differs from "subsets" in that it applies to all CCD image types. 2. Parameters changes include a new ccdred.ampfile and an extension to the group types to include "amplifier" and "ampsubsets". (8/12/96, Valdes) ccdred$src/fixpix.h + ccdred$src/fixpix.x + ccdred$src/fpfx.gx + ccdred$src/corinput.gx - ccdred$src/ccdred.h ccdred$src/ccdtypes.h ccdred$src/setfixpix.x ccdred$src/t_ccdproc.x ccdred$src/ccdproc.x ccdred$src/proc.gx ccdred$src/setproc.x ccdred$src/ccdcheck.x ccdred$src/calimage.x ccdred$src/setsections.x ccdred$src/mkpkg ccdred$src/generic/mkpkg 1. Added "mask" as a new type of calibration image. 2. A new version of the bad pixel fixing algorithm was added. It is the same as proto.fixpix. 3. The bad pixel file is now a mask image which may be referenced as "BPM". (8/12/96, Valdes) ccdred$src/t_ccdmask.x + ccdred$ccdmask.par + ccdred$doc/ccdmask.hlp + ccdred$src/mkpkg ccdred$ccdred.cl ccdred$ccdred.hd ccdred$ccdred.men ccdred$x_ccdred.x A new task, CCDMASK, has been added. This task finds deviant pixels in CCD data and creates a pixel mask. (6/17/96, Valdes) ccdred$src/ccdtest/demo1.dat + Added a modified playback that is faster for generating a small test set. (3/22/96, Valdes) ===== V2.11 ===== ccdred$src/icscale.x The ccdmean keyword is now updated rather than deleted. However the ccdmeant keyword is delete to force a later computation if needed. (1/7/97, Valdes) ccdred$src/icsetout.x ccdred$doc/combine.hlp A new option for computing offsets from the image WCS has been added. (1/7/97, Valdes) ccdred$src/icmask.x ccdred$src/iclog.x ccdred$src/icombine.com ccdred$src/icmask.h + ccdred$src/icmask.com - Changed to use a mask structure. (1/7/97, Valdes) ccdred$src/t_combine.x ccdred$src/icombine.gx ccdred$src/icimstack.x + ccdred$src/iclog.x ccdred$src/mkpkg ccdred$doc/combine.hlp The limit on the maximum number of images that can be combined, set by the maximum number of logical file descriptors, has been removed. If the condition of too many files is detected the task now automatically stacks all the images in a temporary image and then combines them with the project option. The project option probably did not work previously. May not still work. (1/7/97, Valdes) ccdred$src/icsort.gx There was an error in the ic_2sort routine when there are exactly three images that one of the explicit cases did not properly keep the image identifications. See buglog 344. (1/17/97, Valdes) ccdred$src/calimage.x The use of SZ_SUBSET-1 can cause problems because the names are unique to SZ_SUBSET but if unique part is the SZ_SUBSET character this causes problems. (1/17/97, Valdes) ========== V2.10.4-p2 ========== ccdred$src/icpclip.gx Fixed a bug where a variable was improperly used for two different purposes causing the algorithm to fail (bug 316). (10/19/95, Valdes) ccdred$src/cosmic/crlist.x The output bad pixel data accidentally included some extra fields making it incorrect to use the file directly with BADPIXIMAGE. The extra diagnostic fields were removed. (9/25/95, Valdes) ccdred$src/cosmic/t_cosmicrays.x Added a test for interactive mode before opening the graphics stream and whether to call the training routine. This change was needed to allow the task to run non-interactively on dumb, non-graphics terminals. (7/24/95, Valdes) ======= V2.10.4 ======= ccdred$src/t_combine.x If an error occurs while opening an input image header the error recovery will close all open images and then propagate the error. For the case of running out of file descriptors with STF format images this will allow the error message to be printed rather than the error code. (4/3/95, Valdes) ccdred$src/icscale.x ccdred$doc/combine.hlp The behavior of the weights when using both multiplicative and zero point scaling was incorrect; the zero levels have to account for the scaling. (3/27/95, Valdes) ccdred$src/cosmic/t_cosmicrays.x There was an error in setting the x,y coordinates of the window such that it left some of the coordinates undefined. This causes an FPE on the Alpha. (2/17/95, Valdes) ctype.h ccdred$src/ccdsubsets.x Change the test for non-filename characters to map all characters but alphabetic, numbers, and period to '_'. (2/17/95, Valdes) ccdred$src/proc.gx The asum$t function was not properly declared. (9/13/94, Valdes) ccdred$src/t_mkfringe.x ccdred$src/t_mkillumcor.x ccdred$src/t_mkillumft.x ccdred$src/t_mkskycor.x ccdred$src/t_mkskyflat.x Added calls to ccd_open/ccd_close in order to initialize the image caching even if images are not actually cached. (9/13/94, Valdes) ccdred$src/cosmic/t_cosmicrays.x ccdred$src/cosmic/crexamine.x ccdred$doc/cosmicrays.hlp 1. A new parameter was added to the crexamine subroutine in the previous modification for "training" the program. In the subroutine the parameter was used as a modifyable parameter but it was being called with a fixed constant. The effect was the costant value was no longer correct after the first execution and the program would act as if a 'q' was typed after the first interactive execution. This was fixed to treat the input argument as input only. 2. The help page now emphasizes that the "answer" parameter is not to be used on the command line and if it is then the task will ignored the value and act as if the user always responds with "yes". (8/17/94, Valdes) ccdred/src/cosmic/t_cosmicrays.x ccdred/src/cosmic/crfind.x ccdred/src/cosmic/crexamine.x ccdred/src/cosmic/crlist.x ccdred/src/cosmic/crlist.h ccdred/cosmicrays.par ccdred/doc/cosmicrays.hlp noao$lib/scr/cosmicrays.key Added some new parameters and a new functionality to allow setting the flux ratio threshold by training with respect to a user supplied list of classifications. Normally the list would be the image display cursor. (6/29/94, Valdes) ccdred/src/cosmic/t_cosmicrays.x Added an imflush() and imseti() after the initial copy of the input image to the output is done and before the random access to replace the detected cosmic rays. The imseti sets the image I/O advice to RANDOM. (6/24/94, Valdes) ccdred/src/ccdcheck.x ccdred/src/ccdmean.x ccdred/src/setheader.x ccdred/src/scancor.x ccdred/src/setillum.x ccdred/src/t_mkillumcor.x ccdred/src/t_mkfringe.x ccdred/src/t_mkskycor.x ccdred/src/t_mkillumft.x ccdred/src/t_mkskyflat.x ccdred/doc/ccdproc.hlp ccdred/doc/ccdinst.hlp Added a CCDMEANT keyword giving the time when the CCDMEAN value was calculated. Routines that later access this keyword check this time against the image modify time to determine whether to invalidate the value and recompute it. This solves the problem of people modifying the image outside the CCDRED package and possibly using an incorrect scaling value. For backwards compatiblity if the new keyword is missing it is assumed to be same as the modify time; i.e. the CCDMEAN keyword is valid. (6/22/94, Valdes) ccdred/src/t_mkillumcor.x ccdred/src/t_mkillumft.x ccdred/src/t_mkskycor.x ccdred/src/t_mkskyflat.x Added an extra argument to the millumination subroutine to specify whether to print log information. This is because this procedure is used as an intermediate step in things like the fringe correction the message is confusing to users. (6/21/94, Valdes) ccdred/src/icaclip.gx ccdred/src/iccclip.gx ccdred/src/icpclip.gx ccdred/src/icsclip.gx 1. The restoration of deleted pixels to satisfy the nkeep parameter was being done inside the iteration loop causing the possiblity of a non-terminating loop; i.e. pixels are rejected, they are restored, and the number left then does not statisfy the termination condition. The restoration step was moved following the iterative rejection. 2. The restoration was also incorrectly when mclip=no and could lead to a segmentation violation. (6/13/94, Valdes) ccdred/src/iccclip.gx ccdred/src/icsclip.gx Found and fixed another typo bug. (6/7/94, Valdes/Zhang) ccdred/src/t_combine.x For some reason the clget for the nkeep parameter was deleted (it was in V2.10.2 but was gone in the version as of this date). It was added again. (6/6/94, Valdes) ccdred/src/icscale.x The sigma scaling flag, doscale1, would not be set in the case of a mean offset of zero though the scale factors could be different. (5/25/94, Valdes/Zhang) ccdred/src/icsclip.gx There was a missing line: l = Memi[mp1]. (5/25/94, Valdes/Zhang) pkg/images/imarith/icaclip.gx ccdred/src/icaclip.gx ccdred/src/iccclip.gx ccdred/src/icpclip.gx ccdred/src/icsclip.gx The reordering step when a central median is used during rejection but the final combining is average was incorrect if the number of rejected low pixels was greater than the number of pixel number of pixels not rejected. (5/25/94, Valdes) ccdred/src/t_combine.x Added a workaround for image header copy problem which leaves part of the TEMPNAME keyword in the output image headers. For an output pixel list file this could cause the file to be screwed up. (5/6/94, Valdes) ccdred/src/icscale.x ccdred/src/t_combine.x 1. There is now a warning error if the scale, zero, or weight type is unknown. 2. An sfree was being called before the allocated memory was finished being used. (5/2/94, Valdes) ccdred/src/iclog.x Changed the mean, median, mode, and zero formats from 6g to 7.5g to insure 5 significant digits regardless of signs and decimal points. (4/13/94, Valdes) ccdred/src/icaclip.gx ccdred/src/iccclip.gx ccdred/src/icsclip.gx The image sigma was incorrectly computed when an offset scaling is used. (3/8/94, Valdes) ccdred/src/setoverscan.x ccdred/doc/ccdproc.hlp It is an error if no bias section is given or if the whole image is given. (1/3/94, Valdes) ccdred/src/t_ccdinst.x There was an error causing reentrant formats which was fixed. (12/16/93, Valdes) ccdred/src/ccdnscan.x + ccdred/src/scancor.x ccdred/src/setzero.x ccdred/src/setdark.x ccdred/src/setflat.x ccdred/src/calimage.x ccdred/src/proc.gx ccdred/src/t_ccdinst.x ccdred/src/t_mkskyflat.x ccdred/src/t_ccdproc.x ccdred/src/ccdproc.x ccdred/src/setfringe.x ccdred/src/setillum.x ccdred/src/mkpkg ccdred/doc/ccdproc.hlp ccdred/doc/ccdinst.hlp ccdred/doc/instruments.hlp For short scan data the task now looks for the number of scan lines in the image header. Also when a calibration image is software scanned a new image is created. This allows processing objects with different numbers of scan lines and preserving the unscanned calibration image. (12/15/93, Valdes) ccdred/src/setoutput.x ccdred/doc/ccdproc.hlp ccdred/doc/ccdred.hlp 1. The output datatypes were extended from just short and real to include ushort, integer, long, and double. The calculation types are still only short or real. 2. The output datatype is no longer allowed to be of lower precision than the input datatype. (12/4/93, Valdes) ccdred/src/t_combine.x ccdred/combine.par ccdred/doc/combine.hlp ccdred/doc/darkcombine.hlp ccdred/doc/flatcombine.hlp ccdred/doc/zerocombine.hlp 1. The "outtype" parameter was being ignored and the package "pixeltype" parameter was used instead. This was fixed to use the "outtype" parameter. 2. The output pixel datatypes now include unsigned short. 3. The DARKCOMBINE, FLATCOMBINE, and ZEROCOMBINE scripts specified that the output datatype be "real" because of the bug noted above the output type was being determined by the package "pixeltype" parameter. The change above fixes this so that the combined output will always be real. The help pages did not state that what the output datatype would be so a sentence was added specifying the output datatype is real. (12/4/93, Valdes) ccdred/icgrow.gx ccdred/icpclip.gx ccdred/icsclip.gx ccdred/icaclip.gx ccdred/iccclip.gx ccdred/t_combine.x ccdred/doc/combine.hlp If there were fewer initial pixels than specified by nkeep then the task would attempt to add garbage data to achieve nkeep pixels. This could occur when using offsets, bad pixel masks, or thresholds. The code was changed to check against the initial number of pixels rather than the number of images. Also a negative nkeep is no longer converted to a positive value based on the number of images. Instead it specifies the maximum number of pixels to reject from the initial set of pixels. (11/8/93, Valdes) ccdred/doc/ccdproc.hlp Added a sentence explicitly saying the fixpix option provides the same algorithm as FIXPIX. (11/1/93, Valdes) ccdred/src/icscale.x ccdred/doc/combine.hlp The help indicated that user input scale or zero level factors by an @file or keyword are multiplicative and additive while the task was using then as divisive and subtractive. This was corrected to agree with the intend of the documentation. Also the factors are no longer normalized. (9/24/93, Valdes) ccdred/src/icsetout.x The case in which absolute offsets are specified but the offsets are all the same did not work correctly. (9/24/93, Valdes) ccdred/doc/geometry.hlp ccdred/doc/ccdproc.hlp ccdred/doc/guide.hlp The help was modified to say that the overscan region length is determine from trimsec and is ignored in biassec. (9/23/93, Valdes) ccdred/doc/instruments.hlp ccdred/doc/subsets.hlp Added notes that comments are allowed. Also if there is more than one translation for the same CCDRED parameter the last one takes effect. (9/20/93, Valdes) ccdred/doc/combine.hlp Clarified how bad pixel masks work with the "project" option. (9/13/93, Valdes) ccdred/src/t_combine.x The algorithm for making sure there are enough file descriptors failed to account for the need to reopen the output image header for an update. Thus when the number of input images + output images + logfile was exactly 60 the task would fail. The update occurs when the output image is unmapped so the solution was to close the input images first except for the first image whose pointer is used in the new copy of the output image. (8/4/93, Valdes) ============ V2.10.3 beta ============ ccdred/src/icgdata.gx There was an indexing error in setting up the ID array when using the grow option. This caused the CRREJECT/CCDCLIP algorithm to fail with a floating divide by zero error when there were non-zero shifts. (5/26/93, Valdes) ccdred/src/icmedian.gx The median calculation is now done so that the original input data is not lost. This slightly greater inefficiency is required so that an output sigma image may be computed if desired. (5/10/93, Valdes) ccdred/darkcombine.cl ccdred/doc/darkcombine.hlp ccdred/doc/flatcombine.hlp ccddb/kpno/direct.cl ccddb/kpno/coude.cl ccddb/kpno/cryocam.cl ccddb/kpno/echelle.cl ccddb/kpno/foe.cl ccddb/kpno/specphot.cl ccddb/kpno/sunlink.cl 1. Updated FLATCOMBINE defaults for KPNO data. 2. Changed package defaults for DARKCOMBINE to use "minmax" rejection. (4/19/93, Valdes) ccdred/src/icombine.gx There was no error checking when writing to the output image. If an error occurred (the example being when an imaccessible imdir was set) obscure messages would result. Errchks were added. (4/16/93, Valdes) ccdred/src/setfpix.x ccdred/src/ccdproc.x ccdred/src/t_ccdproc.x ccdred/doc/ccdproc.hlp ccdred/doc/instrument.hlp If a specified bad pixel file is not found an abort now occurs. Also the FIXPIX processing header flag is set even if there are no bad pixels. The documentation was revised to stress that an "untrimmed" bad pixel file refers to the original CCD coordinates which is especially important with subraster readouts. (2/23/93, Valdes) ccdred/src/icaclip.gx ccdred/src/iccclip.gx ccdred/src/icpclip.gx ccdred/src/icsclip.gx When using mclip=yes and when more pixels are rejected than allowed by the nkeep parameter there was a subtle bug in how the pixels are added back which can result in a segmentation violation. if (nh == n2) ==> if (nh == n[i]) (1/20/93, Valdes) ccdred/zerocombine.cl ccdred/darkcombine.cl ccdred/flatcombine.cl Explicitly set ccdproc.noproc to no. (11/23/92, Valdes) ======= V2.10.2 ======= ccdred/src/calimage.x Added test on the requested ccdtype when setting up the calibration images to avoid mapping a calibration type image which is not going to be used. (11/17/92, Valdes) ccdred/darkcombine.cl Fixed typo in output parameter prompt string refering to a flat field. (11/10/92, Valdes) ccdred/src/ccdred.h ccdred/src/t_ccdproc.x ccdred/src/proc.gx Separated the minreplace operation from the findmean operation. It is now a separate operation only applied to flat images. (10/26/92, Valdes) ccdred/ccdtest/demo.dat Removed display commands. Because DISPLAY is always loaded in V2.10 there was no way to escape the displaying. (9/30/92, Valdes) ccdred$darkcombine.cl ccdred$flatcombine.cl ccdred$zerocombine.cl ccdred$doc/darkcombine.hlp ccdred$doc/flatcombine.hlp ccdred$doc/zerocombine.hlp Added "blank", "nkeep", and "snoise" parameters. (9/30/92, Valdes) ccdred$src/t_combine.x ccdred$src/icaclip.gx ccdred$src/iccclip.gx ccdred$src/icgrow.gx ccdred$src/iclog.x ccdred$src/icombine.com ccdred$src/icombine.gx ccdred$src/icombine.h ccdred$src/icpclip.gx ccdred$src/icscale.x ccdred$src/icsclip.gx ccdred$src/icsetout.x ccdred$combine.par ccdred$doc/combine.hlp The weighting was changed from using the square root of the exposure time or image statistics to using the values directly. This corresponds to variance weighting. Other options for specifying the scaling and weighting factors were added; namely from a file or from a different image header keyword. The \fInkeep\fR parameter was added to allow controlling the maximum number of pixels to be rejected by the clipping algorithms. The \fIsnoise\fR parameter was added to include a sensitivity or scale noise component to the noise model. Errors will now delete the output image. (9/30/92, Valdes) ccdred$src/t_combine.x ccdred$src/iclog.x The log now prints the final image name rather than the temp name when using the clobber option. (8/25/92, Valdes) ccdred$src/icaclip.gx ccdred$src/iccclip.gx ccdred$src/icpclip.gx ccdred$src/icsclip.gx There was a very unlikely possibility that if all the input pixels had exactly the same number of rejected pixels the weighted average would be done incorrectly because the dflag would not be set. (8/11/92, Valdes) ccdred$src/icmm.gx This procedure failed to set the dflag resulting in the weighted average being computed in correctly. (8/11/92, Valdes) ccdred$src/icscale.x When scaling and zero offseting the zero level factors were incorrectly computed. (8/10/92, Valdes) ccdred$src/ic[acs]clip.gx ccdred$src/icstat.gx Corrected type mismatches in intrinsic functions. (8/10/92, Valdes) ======= V2.10.1 ======= ======= V2.10.0 ======= ===== V2.10 ===== ccdred$src/icombine.gx Needed to clear buffers returned by impl1 during the memory check to avoid possible invalid values. (4/27/92, Valdes) ccdred$src/t_ccdproc.x ccdred$src/calimage.x Made it an error if an explicit calibration image is specified but cannot be opened. Previously it would then look in the input list for the appropriate type. (4/24/92, Valdes) ccdred$ccdproc.x ccdred$t_ccdproc.x Made the COMP type be processed like and OBJECT rather that the default case. The only effect of this is to not have CCDMEAN calculated. (4/8/92, Valdes) ccdred$src/icalip.gx ccdred$src/icclip.gx ccdred$src/ipslip.gx ccdred$src/icslip.gx ccdred$src/icmedian.gx The median calculation with an even number of points for short data could overflow (addition of two short values) and be incorrect. (3/16/92, Valdes) ccdred$src/iclog.x Added listing of read noise and gain. (2/10/92, Valdes) ccdred$src/icpclip.gx Reduced the minimum number of images allowed for PCLIP to 3. (1/7/92, Valdes) ccdred$darkcombine.cl ccdred$flatcombine.cl Set default parameters as requested by the support people. (12/12/91, Valdes) ccdred$src/icgrow.gx The first pixel to be checked was incorrectly set to 0 instead of 1 resulting in a segvio when using the grow option. (12/6/91, Valdes) ccdred$src/proc.gx ccdred$src/icgdata.gx ccdred$src/icscale.x ccdred$src/setfixpix.x ccdred$src/t_combine.x Fixed argument mismatch errors found by SPPLINT. (11/22/91, Valdes) ccdred$src Replaced COMBINE with new version. (9/1/91, Valdes) ccdred$ccdtest/observe.cl -> artobs.cl ccdred$ccdtest/observe.hlp -> artobs.hlp ccdred$ccdtest/subsection.cl ccdred$ccdtest/subsection.hlp ccdred$ccdtest/mkimage.hlp ccdred$ccdtest/demo.dat ccdred$ccdtest/ccdtest.men ccdred$ccdtest/ccdtest.hd ccdred$ccdtest/ccdtest.cl ccdred$ccddb/kpno/demo.dat Renamed OBSERVE to ARTOBS to avoid conflict with the CCDACQ task of the same name. (8/29/91, Valdes) ccdred$src/setoutput.x ccdred$src/setproc.x ccdred$src/setdark.x ccdred$src/setzero.x ccdred$src/setflat.x ccdred$src/setfringe.x ccdred$doc/ccdred.hlp The default output pixel type and computation type are now real. The computation type may be separately specified. (5/29/91, Valdes) ccdred$src/t_mkskycor.x The computation of CCDMEAN failed to accumlate the last few lines causing the mean to be underestimated. (4/16/91, Valdes) ccdred$src/t_ccdinst.x + ccdred$src/ccdinst1.key + ccdred$src/ccdinst2.key + ccdred$src/ccdinst3.key + ccdred$src/hdrmap.x ccdred$src/mkpkg ccdred$ccdinstrument.par + ccdred$ccdred.cl ccdred$ccdred.hd ccdred$ccdred.men ccdred$x_ccdred.x Added the new task CCDINSTRUMENT. This also involved some changes to the header translation package hdrmap.x. (10/23/90, Valdes) ccdred$src/imcscales.x ccdred$src/imcmode.gx ccdred$src/mkpkg Added error check for incorrect mode section specification. (10/3/90, Valdes) ccdred$src/ccdred.h ccdred$src/proc.gx ccdred$src/setproc.x ccdred$ccdproc.par Added a minreplace parameter to replace flat field values less than this value by the value. This provides zero division prevention without requiring specific flat field checking. (10/3/90, Valdes) ccdred$src/t_ccdproc.x ccdred$src/ccdproc.x ccdred$src/scancor.x 1. The scan correction now computes the CCDMEAN to account for the ramp down. 2. Did a simple move of the ccdmean call from before scancor to after scancor. Since CCDMEAN is now computed in SCANCOR this has no real affect and is just cosmetic. If CCDMEAN were not computed in SCANCOR then the new placement would have computed the right value at the expense of another pass through the image. (9/21/90, Valdes) ccdred$src/t_badpixim.x The template image cannot be closed immediately after opening the NEW_COPY mask image because the STF kernel doesn't make the header copy until pixel I/O occurs. This only affects STF images. (6/19/90, Valdes) ==== V2.9 ==== ccdred$src/t_combine.x Changed: char images[SZ_FNAME-1,nimages] --> char images[SZ_FNAME,nimages-1] The incorrect declaration results in each successive image name have additional leading characters. Apparently, since this has not be found previously, the leading characters have generally been blanks. (3/30/90, Valdes) ccdred$doc/combine.hlp Clarified and documented definitions of the scale, offset, and weights. (11/30/89, Valdes) ccdred$ccdproc.par 1. All parameters now have default values. (10/31/89, Valdes) ccdred$src/cosmic/mkpkg ccdred$src/gtascale.x - ccdred$t_cosmicrays.x 1. Removed duplicate of gtools procedure. 2. Fixed transfer out of IFERR block message when input image was wrong. 3. The badpixel file was not initialized to null if the user did not want a badpixel file output. (9/21/89, Valdes) ==== V2.8 === ccdred$src/imcmode.gx Fixed bug causing infinite loop when computing mode of constant value section. (8/14/89, Valdes) ccdred$src/ccdproc.x ccdred$src/ccddelete.x ccdred$src/t_ccdproc.x ccdred$src/t_mkfringe.x ccdred$src/t_mkskyflat.x ccdred$src/t_mkskycor.x ccdred$src/t_mkillumft.x ccdred$src/t_mkillumcor.x ccdred$src/t_combine.x ccdred$src/scancor.x ccdred$src/readcor.x 1. Added error checking for procedure ccddelete. 2. Made workaround for error handling problem with procedure imrename so that specifying a bad backup prefix would result in an abort with an error message. (6/16/89, Valdes) ccdred$src/imcombine.gx Made same changes made to image.imcombine to recover from too many VOS file description error. (6/14/89, Valdes) ccdred$setinstrument.cl ccdred$setinstrument.hlp Incorrect instrument names are now reported to the user, a menu is printed if there is one, and a second opportunity is given. (6/14/89, Valdes) ccdred$ccdred.par Added an ennumerated subset for the output datatype. (5/12/89, Valdes) ccdred$src/imcombine.gx Because a file descriptor was not reserved for string buffer operations and a call to stropen in cnvdate was not error checked the task would hang when more than 115 images were combined. Better error checking was added and now an error message is printed when the maximum number of images that can be combined is exceeded. (5/9/89, Valdes) ccdred$src/sigma.gx ccdred$src/imcaverage.gx 1. Weighted sigma was being computed incorrectely. 2. Added errchk to imcaverage.gx. (5/6/89, Valdes) ccdred$src/setdark.x ccdred$src/setflat.x ccdred$src/setfringe.x ccdred$src/setillum.x ccdred$src/setoverscan.x ccdred$src/settrim.x ccdred$src/setzero.x Made the trimsec, biassec, datasec, and ccdsec error messages more informative. (3/13/89, Valdes) ccdred$src/imcmode.gx For short data a short variable was wraping around when there were a significant number of saturated pixels leading to an infinite loop. The variables were made real regardless of the image datatype. (3/1/89, Valdes) ccdred$src/t_mkskyflat.x ccdred$src/t_mkskycor.x 1. Added warning if images have not been flat fielded. 2. Allowed flat field image to be found even if flatcor=no. (2/24/89, Valdes) ccdred$src/imcthresh.gx ccdred$combine.par ccdred$doc/combine.hlp ccdred$src/imcscales.x 1. Added provision for blank value when all pixels are rejected by the threshold. 2. Fixed a bug that improperly scaled images in the threshold option. 3. The offset printed in the log now has the opposite sign so that it is the value "added" to bring images to a common level. (2/16/89, Valdes) ccdred$src/proc.gx When the data section had fewer lines than the output image (which occurs when not trimming and the overscan being along lines) pixel out of bounds errors occured. This bug was due to a sign error when reading the non-trimmed overscan lines. (2/13/89, Valdes) ccdred$src/setoverscan.gx The overscan buffer for readaxis=column was not initialized yielding unpredictable and incorrect overscan data. (3/13/89, Valdes) ccdred$src/imcmode.gx Added test for nx=1. (2/8/89, Valdes) ccdred$darkcombine.cl ccdred$flatcombine.cl Changed the default parameters to use "avsigclip" combining and no scaling or weighting. (1/27/89, Valdes) ccdred$src/ccdcheck.x ccdred$src/setillum.x ccdred$src/t_ccdproc.x 1. If the illumination image does not have CCDMEAN in its header it is calculated. 2. If an error occurs in setting up for illumination or fringe correction during processing a warning is issued and these processing steps are skipped. They can be done later if desired. Previously this caused an abort. (1/27/89, Valdes) ccdred$ccdgroups.par ccdred$src/t_ccdgroups.x ccdred$doc/ccdgroups.hlp Added two new group types; ccdtype and subset. (1/26/89, Valdes) ccdred$src/t_ccdlist.x ccdred$doc/ccdlist.hlp The exposure time and dark time are now printed in long format. This is useful to allow verifying the header translation is working correctly. (1/26/89, Valdes) ccdred$src/setfixpix.x ccdred$src/t_badpixim.x The magic word "untrimmed" no longer needs whitespace preceding it. (1/24/89, Valdes) imred$ccdred/src/imcscales.x Valdes, Dec 8, 1988 1. COMBINE now prints the scale as a multiplicative quantity. 2. The combined exposure time was not being scaled by the scaling factors resulting in a final exposure time inconsistent with the data. imred$ccdred/src/t_mkskyflat.x imred$ccdred/src/t_mkillumft.x imred$ccdred/src/t_mkskycor.x imred$ccdred/src/t_mkskyflat.x imred$ccdred/src/t_mkfringe.x imred$ccdred/doc/mkillumcor.hlp imred$ccdred/doc/mkillumflat.hlp imred$ccdred/mkillumflat.par imred$ccdred/mkillumflat.par 1. Minor typo in declaration (calimage.x) which had no effect. 2. Missing include file (t_mkskyflat.x) caused "Cannot open image" when using MKSKYFLAT. 3. Added checks for division by zero which are reported at the end as the number of divisions by zero and the replacement value. The replacement value was added as a parameter value in MKILLUMCOR and MKILLUMFLAT. 4. Updated the help pages to reflect the new division by zero parameter. 5. Modified the log strings to be more informative about what was done and which images were used. (10/20/88 Valdes) imred$ccdred/src/imcombine.gx A vops clear routine was not called generically causing a crash with double images. (10/19/88 Valdes) imred$ccdred/src/t_mkskycor.x Replaced calls to recipricol vops procedure to one with zero checking. (10/13/88 Valdes) imred$ccdred/src/imcscales.x It is now an error if the mode is not positive for mode scaling or weighting. (9/28/88 Valdes) imred$ccdred/ccdred.par imred$ccdred/doc/ccdred.hlp The plotfile parameter was changed to reflect the "" character as the new default. (9/23/88 jvb) imred$ccdred/src/imcmedian.gx The median option was selecting the n/2 value instead of (n+1)/2. Thus, for an odd number of images the wrong value was being determined for the median. (8/16/88 Valdes) imred$ccdred/src/scancor.x imred$ccdred/src/calimage.x imred$ccdred/src/ccdcmp.x + imred$ccdred/src/mkpkg 1. The shortscan correction was incorrectly writing to the input image rather than the output image causing a cannot write to file error. 2. It is now a trapped error if the input image is the same as a calibration image. (4/18/88 Valdes) imred$ccdred/src/imcmode.gx The use of a mode sections was handled incorrectly. (4/11/88 Valdes) noao$imred/ccdred/src/setoverscan.x Minor bug fix: gt_setr (gt, GTXMIN, 1.) -> gt_setr (gt, GTXMIN, x[1]) gt_setr (gt, GTXMAX, real(npts)) -> gt_setr (gt, GTXMAX, x[npts]) (2/11/88 Valdes) noao$imred/ccdred/src/t_mkillumflat.x -> t_mkillumft.x noao$imred/ccdred/src/t_mkfringecor.x -> t_mkfringe.x noao$imred/ccdred/src/t_badpiximage.x -> t_badpixim.x noao$imred/ccdred/src/imcthreshold.gx -> imcthresh.gx noao$imred/ccdred/src/generic/imcthresh.x -> imcthresh.x noao$imred/ccdred/src/mkpkg noao$imred/ccdred/src/generic/mkpkg Shortened long names. (2/10/88 Valdes) noao$imred/ccdred/src/t_mkskycor.x noao$imred/ccdred/doc/mkskycor.hlp noao$imred/ccdred/doc/mkillumcor.hlp noao$imred/ccdred/doc/mkskyflat.hlp noao$imred/ccdred/doc/mkillumflat.hlp noao$imred/ccdred/doc/mkfringecor.hlp 1. When not clipping the first 3 lines of the illumination were always zero. 2. The clipping algorithm had several errors. 3. It was unclear what a box size of 1. meant and whether one could specify the entire image as the size of the box. 4. The smoothing box has been generalize to let the user chose the minimum and maximum box size. This lets the user do straight box smoothing and the growing box smoothing. (2/2/88 Valdes) noao$imred/ccdred/src/ccdtypes.h Added the comparison CCD image type. (1/21/88 Valdes) noao$imred/ccdred/src/t_mkskycor.x noao$imred/ccdred/src/t_mkillumcor.x noao$imred/ccdred/src/t_mkskyflat.x noao$imred/ccdred/src/t_mkillumflat.x noao$imred/ccdred/src/t_mkfringecor.x Calling sequences to the set_ procedures were wrong. (1/20/88 Valdes) noao$imred/ccdred/src/imcscales.x The exposure time is now read as real. (1/15/88 Valdes) noao$imred/ccdred/src/corinput.gx Discovered an initialization bug which caused the fixing of bad lines to fail after the first image. (11/12/87 Valdes) noao$imred/ccdred/ccdtest/observe.cl noao$imred/ccdred/ccdtest/subsection.cl noao$imred/ccdred/ccdtest/demo.dat Made modification to allow the demo to work with STF format images. The change was in being more explicit with image extensions; i.e. obs* --> obs*.??h. (11/12/87 Valdes) noao$imred/ccdred/src/mkpkg noao$imred/ccdred/src/ccdmean.x + noao$imred/ccdred/src/ccdcache.h + noao$imred/ccdred/src/ccdcache.com noao$imred/ccdred/src/ccdcache.x noao$imred/ccdred/src/t_ccdproc.x noao$imred/ccdred/src/ccdproc.x noao$imred/ccdred/src/ccdcheck.x noao$imred/ccdred/src/setflat.x noao$imred/ccdred/src/setdark.x noao$imred/ccdred/src/setzero.x noao$imred/ccdred/src/setfixpix.x noao$imred/ccdred/src/setillum.x noao$imred/ccdred/src/setfringe.x noao$imred/ccdred/src/t_ccdlist.x 1. There was a recursion problem caused by the absence of the CCDPROC flag in a zero level image which did not need any processing because there was no trimming, overscan subtraction, or bad pixel correction. The procedure CCDPROC left the image unmodified (no CCDPROC flag) which meant that later another unprocessed calibration image would again try to process it leading to recursion. Since I was uncomfortable with relying on the CCDPROC flag I added the routine CCDCHECK to actually check each processing flag against the defined operations. This will also allow additional automatic processing of calibration images if the users sets new flags after an initial pass through the data. The CCDPROC flag is still set in the data but it is not used. 2. It is possible in data which has no object types for the flat field image never to have its mean computed for later scaling. There were two modifications to address this problem. If an image is processed without a ccdtype then the mean will be computed at a very small cost in time. If the image is later used as a flat field this information will then be present. Second, if a flat field calibration image does not have the mean value, even if it has been processed, the mean value will still be calculated. 3. In looking at the recursion problem I realized that some of the calibration images could be opened more than once, though READ_ONLY, once for the image being processed and later if the task has to backtrack to process a another calibration frame. I was surprise that this was not found on VMS until I realized that for OIF format images the image header is read and the file is then closed. No file is actually left open until pixel I/O is done. However, this should cause STF images to fail on VMS because VMS does not allow a file to be open more than once and the STF image header is kept open. I rewrote the image caching interface to cache the IMIO pointer even if the pixel data was not cached. This will insure any calibration image is only opened once even if it is accessed independently from different parts of the program. 4. The error message when using fringe and illumination correction images which have not been processed by MKFRINGECOR and MKILLUMCOR was misleading when refering to the absence of the MKFRINGE and MKILLUM flag. A user thought that the missing flag was FRINGCOR which refers to an image being fringe corrected. The message was made a little more clear. 5. The CCDLIST listing for fringe correction in long format was wrong. (11/12/87 Valdes) noao$imred/ccdred/src/t_combine.x noao$imred/ccdred/src/t_ccdhedit.x noao$imred/ccdred/src/setoverscan.x noao$imred/ccdred/src/setinput.x noao$imred/ccdred/src/imcscales.x noao$imred/ccdred/src/imclogsum.x noao$imred/ccdred/src/ccdlog.x noao$imred/ccdred/src/ccddelete.x Added calls to XT_STRIPWHITE to allow null strings to be recognized with whitespace. It should probably use NOWHITE but this would make it incompatible with V2.5. (11/6/87 Valdes) .endhelp mscred-5.05-2018.07.09/src/ccdred/_ccdtool.par000066400000000000000000000045661332166314300203060ustar00rootroot00000000000000input,s,a,"",,,List of input CCD images to process output,s,a,"",,,List of output processed CCD images nointerp,s,a,"",,,List of output uninterpolated images bpmasks,s,a,"",,,List of output bad pixel masks calproc,f,h,"",,,List of calibration images to be processed (output file) ccdtype,s,h,"object",,,CCD image type to select (if not null) proctype,s,h,"",,,CCD processing type (if not null) max_cache,i,h,0,0,,Maximum image caching memory (in Mbytes) noproc,b,h,no,,,"List processing steps only?" onerror,s,h,"original","abort|warn|exit|original",,"Action on error " fixpix,b,h,yes,,,Apply bad pixel interpolation? overscan,b,h,yes,,,Apply overscan strip correction? trim,b,h,yes,,,Trim the image? zerocor,b,h,yes,,,Apply zero level correction? darkcor,b,h,yes,,,Apply dark count correction? flatcor,b,h,yes,,,Apply flat field correction? sflatcor,b,h,no,,,Apply sky flat field correction? illumcor,b,h,no,,,Apply illumination correction? fringecor,b,h,no,,,Apply fringe correction? readcor,b,h,no,,,Convert zero level image to readout correction? scancor,b,h,no,,,"Convert flat field image to scan correction? " fixfile,s,h,"",,,List of input bad pixel masks saturation,s,h,INDEF,,,Saturated pixel threshold sgrow,i,h,0,0,,Saturated pixel grow radius bleed,s,h,INDEF,,,Bleed pixel threshold btrail,i,h,20,0,,Bleed trail minimum length bgrow,i,h,0,0,,Bleed pixel grow radius biassec,s,h,"",,,Overscan strip image section trimsec,s,h,"",,,Trim data section zero,s,h,"",,,List of zero level calibration images dark,s,h,"",,,List of dark count calibration images flat,s,h,"",,,List of primary flat field images sflat,s,h,"",,,List of sky flat field images illum,s,h,"",,,List of illumination correction images fringe,s,h,"",,,List of fringe correction images minreplace,r,h,1.,,,Minimum flat field value readaxis,s,h,"line","column|line",, Read out axis (column|line) scantype,s,h,"shortscan","shortscan|longscan",,Scan type (shortscan|longscan) nscan,i,h,1,1,,"Number of short scan lines " interactive,b,h,no,,,Fit overscan interactively? function,s,h,"legendre",,,Fitting function order,i,h,1,1,,Number of polynomial terms or spline pieces sample,s,h,"*",,,Sample points to fit naverage,i,h,1,,,Number of sample points to combine niterate,i,h,1,0,,Number of rejection iterations low_reject,r,h,3.,0.,,Low sigma rejection factor high_reject,r,h,3.,0.,,High sigma rejection factor grow,r,h,0.,0.,,Rejection growing radius mscred-5.05-2018.07.09/src/ccdred/ccddb/000077500000000000000000000000001332166314300170405ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/000077500000000000000000000000001332166314300177765ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/ccd.dat000066400000000000000000000006161332166314300212240ustar00rootroot00000000000000exptime itime darktime itime imagetyp data-typ subset none biassec biassec [405:425,7:572] datasec datasec [35:340,4:570] fixfile fixfile home$badpix fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 OBJECT object DARK dark "PROJECTOR FLAT" flat "SKY FLAT" other COMPARISON other BIAS zero "DOME FLAT" flat MASK other mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/cfccd.dat000066400000000000000000000005521332166314300215340ustar00rootroot00000000000000exptime exptime darktime darktime imagetyp imagetyp subset filters biassec biassec datasec datasec fixfile fixfile fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 OBJECT object DARK dark "PROJECTOR FLAT" flat "SKY FLAT" other COMPARISON other BIAS zero "DOME FLAT" flat MASK other mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/csccd.dat000066400000000000000000000005501332166314300215470ustar00rootroot00000000000000exptime exptime darktime darktime imagetyp data-typ subset none biassec biassec datasec datasec fixfile fixfile fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 OBJECT object DARK dark "PROJECTOR FLAT" flat "SKY FLAT" other COMPARISON other BIAS zero "DOME FLAT" flat MASK other mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/ech.dat000066400000000000000000000005161332166314300212310ustar00rootroot00000000000000exptime exptime darktime darktime subset none biassec biassec trimsec datasec imagetyp imagetyp 'OBJECT' object 'COMPARISON' other 'BIAS' zero 'DOME FLAT' flat 'PROJECTOR FLAT' flat fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/epi5.dat000066400000000000000000000006511332166314300213340ustar00rootroot00000000000000exptime exptime darktime darktime imagetyp imagetyp subset none biassec biassec [420:431,10:576] trimsec trimsec [15:393,10:576] fixfile fixfile home$ccds/epi5_badpix.dat fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 OBJECT object DARK dark "PROJECTOR FLAT" flat "SKY FLAT" other COMPARISON other BIAS zero "DOME FLAT" flat MASK other mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/epi5_badpix.dat000066400000000000000000000006511332166314300226630ustar00rootroot00000000000000# EPI5_BADPIX.DAT - GEC EPI5 Blue Air Schmidt untrimmed coordinates # # Map includes columns which bleed due to very poor charge transfer at low # light levels. # # SRH 8 December 87 # 37 37 396 313 37 37 510 528 46 46 482 307 77 77 148 490 129 129 21 48 154 154 346 446 262 262 199 450 284 284 493 549 307 308 196 210 307 309 395 576 312 312 480 496 347 348 88 111 347 347 112 468 352 352 127 438 378 378 515 529 mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/fpccd.dat000066400000000000000000000005461332166314300215540ustar00rootroot00000000000000EXPTIME exptime DARKTIME darktime IMAGETYP imagetyp subset FPZ biassec biassec datasec datasec fixfile fixfile fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 OBJECT object DARK dark "PROJECTOR FLAT" flat "SKY FLAT" other COMPARISON other BIAS zero "DOME FLAT" flat MASK other mscred-5.05-2018.07.09/src/ccdred/ccddb/ctio/instruments.men000066400000000000000000000002421332166314300230700ustar00rootroot00000000000000ccd CTIO genetic CCD ech CTIO generic Echelle/CCD cfccd CTIO generic CF/CCD csccd CTIO generic CS/CCD fpccd CTIO generic FP/CCD mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/000077500000000000000000000000001332166314300200075ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/Revisions000066400000000000000000000007331332166314300217160ustar00rootroot00000000000000.help revisions Dec91 ccddb$kpno .nf *.cl 1. (all) ccdred.plotfile = "". 2. (all) ccdred.pixeltype = "real real". 3. (direct,fibers) ccdproc.interactive = yes 4. (coude, specphot) ccdproc.ccdtype = "" ccdproc.flatcor = no ccdproc.trimsec = "" (12/12/91, Valdes) instruments.men Removed sunlink from the instrument menu. (12/12/91, Valdes) coude.dat Changed the subset parameter from FILTER to GRATPOS. (12/11/91, Valdes) .endhelp mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/camera.dat000066400000000000000000000005621332166314300217340ustar00rootroot00000000000000exptime otime darktime ttime imagetyp data-typ subset f1pos biassec biassec [] datasec datasec [] fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 'OBJECT (0)' object 'DARK (1)' dark 'PROJECTOR FLAT (2)' flat 'SKY FLAT (3)' other 'COMPARISON LAMP (4)' other 'BIAS (5)' zero 'DOME FLAT (6)' flat mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/coude.cl000066400000000000000000000015001332166314300214220ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/coude.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.ccdtype = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "" ccdproc.interactive = yes ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/coude.dat000066400000000000000000000002061332166314300215760ustar00rootroot00000000000000subset gratpos DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/cryocam.cl000066400000000000000000000015071332166314300217670ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/cryocam.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.ccdtype = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.interactive = yes ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/cryocam.dat000066400000000000000000000002061332166314300221340ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/demo.cl000066400000000000000000000032661332166314300212620ustar00rootroot00000000000000# Demonstration parameter setting script. # Set package parameters: ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "Demo.log" ccdred.plotfile = "Demo.plots" ccdred.backup = "B" ccdred.ssfile = "Demo.subsets" # Set processing parameters: ccdproc.overscan = yes ccdproc.trim = yes ccdproc.fixpix = yes ccdproc.zerocor = yes ccdproc.darkcor = yes ccdproc.flatcor = yes ccdproc.illumcor = no ccdproc.fringecor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.fixfile = "demos$badpix.dat" ccdproc.zero = "" ccdproc.dark = "" ccdproc.flat = "" ccdproc.illum = "" ccdproc.fringe = "" ccdproc.scantype = "shortscan" ccdproc.nscan = 1 ccdproc.interactive = yes ccdproc.function = "legendre" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3. ccdproc.high_reject = 3. ccdproc.grow = 0. flatcombine.process = no # Set demonstration observation parameters: artobs.ncols = 132 artobs.nlines = 100 artobs.filter = "" artobs.datasec = "[1:100,1:100]" artobs.trimsec = "[3:98,3:98]" artobs.biassec = "[103:130,*]" artobs.imdata = "" artobs.skyrate = 0. artobs.badpix = "demos$badpix.dat" artobs.biasval = 500. artobs.badval = 500. artobs.zeroval = 100. artobs.darkrate = 1. artobs.zeroslope = 0.01 artobs.darkslope = 0.002 artobs.flatslope = 3.0000000000000E-4 artobs.sigma = 5. artobs.seed = 0 artobs.overwrite = no # Set demonstration subsection readout parameters: subsection.ncols = 82 subsection.nlines = 50 subsection.ccdsec = "[26:75,26:75]" subsection.datasec = "[1:50,1:50]" subsection.trimsec = "" subsection.biassec = "[51:82,1:50]" subsection.overwrite = no mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/demo.dat000066400000000000000000000000571332166314300214270ustar00rootroot00000000000000imagetyp ccdtype exptime integ subset filter mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/direct.cl000066400000000000000000000014621332166314300216040ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/direct.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = yes ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.interactive = yes ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/direct.dat000066400000000000000000000002061332166314300217510ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/echelle.cl000066400000000000000000000014611332166314300217320ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/echelle.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.interactive = no ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/echelle.dat000066400000000000000000000002061332166314300221000ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/fibers.cl000066400000000000000000000023051332166314300216010ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/fibers.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.ccdtype = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.interactive = yes ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.output = "Flat" flatcombine.combine = "average" flatcombine.reject = "ccdclip" flatcombine.ccdtype = "flat" flatcombine.process = yes flatcombine.subsets = no flatcombine.delete = no flatcombine.clobber = no flatcombine.scale = "none" flatcombine.statsec = "" flatcombine.nlow = 1 flatcombine.nhigh = 1 flatcombine.mclip = yes flatcombine.lsigma = 3. flatcombine.hsigma = 3. flatcombine.rdnoise = "RDNOISE" flatcombine.gain = "GAIN" flatcombine.pclip = -0.5 mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/fibers.dat000066400000000000000000000002061332166314300217510ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/fits.dat000066400000000000000000000005661332166314300214550ustar00rootroot00000000000000exptime itime darktime itime imagetyp data-typ subset f1pos biassec biassec [] datasec datasec [] fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 'object ( 0 )' object 'dark ( 1 )' dark 'proj flat ( 2 )' flat 'sky flat ( 3 )' other 'comp ( 4 )' other 'bias ( 5 )' zero 'dome flat ( 6 )' flat mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/foe.cl000066400000000000000000000015021332166314300210760ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/foe.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.ccdtype = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.interactive = no ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/foe.dat000066400000000000000000000002061332166314300212500ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/instruments.men000066400000000000000000000013501332166314300231020ustar00rootroot00000000000000direct Current headers for Sun plus CCDPROC setup for direct CCD specphot Current headers for Sun plus CCDPROC setup for spectropho- tometry, ie GoldCam, barefoot CCD foe Current headers for Sun plus CCDPROC setup for FOE fibers Current headers for Sun plus CCDPROC setup for fiber array coude Current headers for Sun plus CCDPROC setup for Coude cyrocam Current headers for Sun plus CCDPROC setup for Cryo Cam echelle Current headers for Sun plus CCDPROC setup for Echelle kpnoheaders Current headers with no changes to CCDPROC parameters fits Mountain FITS header prior to Aug. 87 (?) camera Mountain CAMERA header for IRAF Version 2.6 and earlier mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/kpnoheaders.dat000066400000000000000000000002061332166314300230020ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/mosaic.dat000066400000000000000000000000551332166314300217540ustar00rootroot00000000000000imagetyp obstype amp imageid subset filter mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/specphot.cl000066400000000000000000000015031332166314300221530ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/specphot.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.ccdtype = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = no ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "" ccdproc.interactive = yes ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 1 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/specphot.dat000066400000000000000000000002061332166314300223240ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp 'SKY FLAT' object mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/sunlink.cl000066400000000000000000000014621332166314300220150ustar00rootroot00000000000000# Generic routine for setting parameters. ccdred.pixeltype = "real real" ccdred.verbose = yes ccdred.logfile = "logfile" ccdred.plotfile = "" ccdred.backup = "" ccdred.instrument = "ccddb$kpno/sunlink.dat" ccdred.ssfile = "subsets" ccdred.graphics = "stdgraph" ccdred.cursor = "" ccdproc.fixpix = no ccdproc.overscan = yes ccdproc.trim = yes ccdproc.zerocor = yes ccdproc.darkcor = no ccdproc.flatcor = yes ccdproc.readcor = no ccdproc.scancor = no ccdproc.readaxis = "line" ccdproc.biassec = "image" ccdproc.trimsec = "image" ccdproc.interactive = no ccdproc.function = "chebyshev" ccdproc.order = 1 ccdproc.sample = "*" ccdproc.naverage = 1 ccdproc.niterate = 1 ccdproc.low_reject = 3 ccdproc.high_reject = 3 ccdproc.grow = 0 flatcombine.reject = "crreject" flatcombine.rdnoise= "rdnoise" flatcombine.gain="gain" mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/sunlink.dat000066400000000000000000000001571332166314300221670ustar00rootroot00000000000000subset filters DARK dark BIAS zero OBJECT object 'DOME FLAT' flat 'PROJECTOR FLAT' flat 'COMPARISON' comp mscred-5.05-2018.07.09/src/ccdred/ccddb/kpno/template.cl000066400000000000000000000007731332166314300221510ustar00rootroot00000000000000# Template parameter setting script. These parameters should be # set for a particular instrument. ccdproc.overscan = ccdproc.trim = ccdproc.fixpix = ccdproc.zerocor = ccdproc.darkcor = ccdproc.flatcor = ccdproc.readcor = ccdproc.scancor = ccdproc.readaxis = ccdproc.biassec = ccdproc.datasec = ccdproc.fixfile = ccdproc.scantype = ccdproc.interactive = ccdproc.function = ccdproc.order = ccdproc.sample = ccdproc.naverage = ccdproc.niterate = ccdproc.low_reject = ccdproc.high_reject = ccdproc.grow = mscred-5.05-2018.07.09/src/ccdred/ccddelete.par000066400000000000000000000000721332166314300204200ustar00rootroot00000000000000images,s,a,"",,,List of input CCD images to delete/backup mscred-5.05-2018.07.09/src/ccdred/ccdgroups.par000066400000000000000000000007771332166314300205110ustar00rootroot00000000000000images,s,a,,,,CCD images to group output,s,a,,,,Output root group filename list,f,h,"",,,File for list of filenames (optional) group,s,h,"ccdtype","keyword|ccdtype|subset|amplifier|ccdname|ampsubset|position|",,Group type cluster,b,h,no,,,Output cluster name only? sequence,b,h,no,,,Break into sequences? keywords,s,h,"",,,List of keywords to group radius,r,h,"60",,,Group position radius (arc sec) ccdtype,s,h,"",,,CCD image types to select mingroup,i,h,1,1,,Minumum number per group verbose,b,h,no,,,Verbose? mscred-5.05-2018.07.09/src/ccdred/ccdhedit.par000066400000000000000000000002541332166314300202550ustar00rootroot00000000000000images,s,a,,,,CCD images parameter,s,a,,,,Image header parameter value,s,a,,,,Parameter value type,s,h,"string","string|real|integer",,Parameter type (string|real|integer) mscred-5.05-2018.07.09/src/ccdred/ccdinstrument.par000066400000000000000000000003661332166314300213740ustar00rootroot00000000000000images,s,a,,,,List of images instrument,s,h,)_.instrument,,,CCD instrument file ssfile,s,h,)_.ssfile,,,Subset translation file edit,b,h,yes,,,Edit instrument translation file? parameters,s,h,"basic","basic|common|all",,Parameters to be displayed mscred-5.05-2018.07.09/src/ccdred/ccdlist.par000066400000000000000000000003051332166314300201300ustar00rootroot00000000000000images,s,a,,,,CCD images to listed ccdtype,s,h,"",,,CCD image type to be listed names,b,h,no,,,List image names only? long,b,h,no,,,Long format listing? ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/ccdred/ccdmask.par000066400000000000000000000010731332166314300201130ustar00rootroot00000000000000image,f,a,,,,Input image mask,f,a,,,,Output pixel mask ncmed,i,h,7,1,,Column box size for median level calculation nlmed,i,h,7,1,,Line box size for median level calculation ncsig,i,h,15,10,,Column box size for sigma calculation nlsig,i,h,15,10,,Line box size for sigma calculation lsigma,r,h,6.,,,Low clipping sigma hsigma,r,h,6.,,,High clipping sigma ngood,i,h,5,1,,Minimum column length of good pixel seqments linterp,i,h,1,1,,Mask value for line interpolation cinterp,i,h,2,1,,Mask value for column interpolation eqinterp,i,h,3,1,,Mask value for equal interpolation mscred-5.05-2018.07.09/src/ccdred/ccdproc.par000066400000000000000000000041371332166314300201270ustar00rootroot00000000000000images,s,a,"",,,List of input CCD images to process output,s,h,"",,,List of output CCD images bpmasks,s,h,"",,,List of output bad pixel masks ccdtype,s,h,"object",,,CCD image type to correct max_cache,i,h,0,0,,Maximum image caching memory (in Mbytes) noproc,b,h,no,,,"List processing steps only? " fixpix,b,h,yes,,,Apply bad pixel interpolation? overscan,b,h,yes,,,Apply overscan strip correction? trim,b,h,yes,,,Trim the image? zerocor,b,h,yes,,,Apply zero level correction? darkcor,b,h,yes,,,Apply dark count correction? flatcor,b,h,yes,,,Apply flat field correction? sflatcor,b,h,yes,,,Apply sky flat field correction? illumcor,b,h,no,,,Apply illumination correction? fringecor,b,h,no,,,Apply fringe correction? readcor,b,h,no,,,Convert zero level image to readout correction? scancor,b,h,no,,,"Convert flat field image to scan correction? " fixfile,s,h,"",,,List of input bad pixel masks saturation,s,h,INDEF,,,Saturated pixel threshold sgrow,i,h,0,0,,Saturated pixel grow radius bleed,s,h,INDEF,,,Bleed pixel threshold btrail,i,h,20,0,,Bleed trail minimum length bgrow,i,h,0,0,,Bleed pixel grow radius biassec,s,h,"",,,Overscan strip image section trimsec,s,h,"",,,Trim data section zero,s,h,"",,,List of zero level calibration images dark,s,h,"",,,List of dark count calibration images flat,s,h,"",,,List of flat field images sflat,s,h,"",,,List of sky flat field images illum,s,h,"",,,List of illumination correction images fringe,s,h,"",,,List of fringe correction images minreplace,r,h,1.,,,Minimum flat field value readaxis,s,h,"line","column|line",, Read out axis (column|line) scantype,s,h,"shortscan","shortscan|longscan",,Scan type (shortscan|longscan) nscan,i,h,1,1,,"Number of short scan lines " interactive,b,h,no,,,Fit overscan interactively? function,s,h,"legendre",,,Fitting function order,i,h,1,1,,Number of polynomial terms or spline pieces sample,s,h,"*",,,Sample points to fit naverage,i,h,1,,,Number of sample points to combine niterate,i,h,1,0,,Number of rejection iterations low_reject,r,h,3.,0.,,Low sigma rejection factor high_reject,r,h,3.,0.,,High sigma rejection factor grow,r,h,0.,0.,,Rejection growing radius mscred-5.05-2018.07.09/src/ccdred/ccdred.cl000066400000000000000000000010721332166314300175450ustar00rootroot00000000000000#{ CCDRED -- CCD Reduction Package set ccddb = "ccdred$ccddb/" set ccdtest = "ccdred$ccdtest/" package ccdred task $ccdtest = ccdtest$ccdtest.cl task ccdgroups, ccdhedit, ccdinstrument, ccdlist, ccdmask, ccdproc, ccdtool, combine, cosmicrays, coutput, mkfringecor, mkillumcor, mkillumflat, mkskycor, mkskyflat = ccdred$xx_ccdred.e task darkcombine = ccdred$darkcombine.cl task flatcombine = ccdred$flatcombine.cl task sflatcombine = ccdred$sflatcombine.cl task setinstrument = ccdred$setinstrument.cl task zerocombine = ccdred$zerocombine.cl clbye() mscred-5.05-2018.07.09/src/ccdred/ccdred.hd000066400000000000000000000017531332166314300175500ustar00rootroot00000000000000# Help directory for the CCDRED package. $doc = "./doc/" ccdgroups hlp=doc$ccdgroups.hlp ccdhedit hlp=doc$ccdhedit.hlp ccdlist hlp=doc$ccdlist.hlp ccdmask hlp=doc$ccdmask.hlp ccdproc hlp=doc$ccdproc.hlp combine hlp=doc$combine.hlp cosmicrays hlp=doc$cosmicrays.hlp darkcombine hlp=doc$darkcombine.hlp flatcombine hlp=doc$flatcombine.hlp mkfringecor hlp=doc$mkfringecor.hlp mkillumcor hlp=doc$mkillumcor.hlp mkillumflat hlp=doc$mkillumflat.hlp mkskycor hlp=doc$mkskycor.hlp mkskyflat hlp=doc$mkskyflat.hlp setinstrument hlp=doc$setinstrument.hlp zerocombine hlp=doc$zerocombine.hlp ccdgeometry hlp=doc$ccdgeometry.hlp ccdinstrument hlp=doc$ccdinst.hlp ccdtypes hlp=doc$ccdtypes.hlp flatfields hlp=doc$flatfields.hlp guide hlp=doc$guide.hlp instruments hlp=doc$instruments.hlp package hlp=doc$ccdred.hlp subsets hlp=doc$subsets.hlp revisions sys=Revisions $ccdtest = "noao$imred/ccdred/ccdtest/" ccdtest men=ccdtest$ccdtest.men, hlp=.., sys=ccdtest$ccdtest.hlp, src=ccdtest$ccdtest.cl mscred-5.05-2018.07.09/src/ccdred/ccdred.men000066400000000000000000000025361332166314300177340ustar00rootroot00000000000000 ccdgroups - Group CCD images into image lists ccdhedit - CCD image header editor ccdinstrument - Review and edit instrument translation files ccdlist - List CCD processing information ccdmask - Create bad pixel mask from CCD flat field images ccdproc - Process CCD images ccdtest - CCD test and demonstration package combine - Combine CCD images cosmicrays - Detect and replace cosmic rays darkcombine - Combine and process dark count images flatcombine - Combine and process flat field images mkfringecor - Make fringe correction images from sky images mkillumcor - Make flat field illumination correction images mkillumflat - Make illumination corrected flat fields mkskycor - Make sky illumination correction images mkskyflat - Make sky corrected flat field images setinstrument - Set instrument parameters zerocombine - Combine and process zero level images ADDITIONAL HELP TOPICS ccdgeometry - Discussion of CCD coordinate/geometry keywords ccdtypes - Description of the CCD image types flatfields - Discussion of CCD flat field calibrations guide - Introductory guide to using the CCDRED package instruments - Instrument specific data files package - CCD image reduction package subsets - Description of CCD subsets mscred-5.05-2018.07.09/src/ccdred/ccdred.par000066400000000000000000000011551332166314300177330ustar00rootroot00000000000000# CCDRED package parameter file pixeltype,s,h,"real real",,,Output and calculation pixel datatypes verbose,b,h,no,,,Print log information to the standard output? logfile,f,h,"logfile",,,Text log file plotfile,f,h,"",,,Log metacode plot file backup,s,h,"",,,Backup directory or prefix instrument,s,h,"",,,CCD instrument file ampfile,s,h,"amps",,,Amplifier translation file ssfile,s,h,"subsets",,,Subset translation file im_bufsize,r,h,0.065536,0.001024,,Image I/O buffer size (in Mbytes) graphics,s,h,"stdgraph",,,Interactive graphics output device cursor,*gcur,h,"",,,Graphics cursor input version,s,h,"2: October 1987" mscred-5.05-2018.07.09/src/ccdred/ccdtest/000077500000000000000000000000001332166314300174325ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/ccdtest/artobs.cl000066400000000000000000000103741332166314300212510ustar00rootroot00000000000000# ARTOBS -- Make a CCD observation procedure artobs (image, exptime, ccdtype) string image {prompt="Image name"} real exptime {prompt="Exposure time"} string ccdtype {prompt="CCD type"} string title="" {prompt="Title"} file header="" {prompt="Header template"} int ncols=132 {prompt="Number of columns"} int nlines=100 {prompt="Number of lines"} string filter="" {prompt="Filter"} string datasec="[1:100,1:100]" {prompt="Data section"} string trimsec="[3:98,3:98]" {prompt="Trim section"} string biassec="[103:130,*]" {prompt="Bias section"} file imdata="" {prompt="Image data"} real skyrate=0. {prompt="Sky count rate"} file badpix="" {prompt="Bad pixel mask"} real biasval=500. {prompt="Bias value"} real badval=500. {prompt="Bad pixel value"} real zeroval=100. {prompt="Zero level value"} real darkrate=1. {prompt="Dark count rate"} real zeroslope=0.01 {prompt="Slope of zero level"} real darkslope=0.002 {prompt="Slope of dark count rate"} real flatslope=0.0003 {prompt="Flat field slope"} real sigma=5. {prompt="Gaussian sigma"} int seed=0 {prompt="Random number seed"} bool overwrite=no {prompt="Overwrite existing image?"} begin int c1, c2, l1, l2 real exp, value1, value2, valslope string im, obstype, s im = image exp = exptime obstype = ccdtype if (access (im//".imh") == yes) im = im // ".imh" if (access (im//".hhh") == yes) im = im // ".hhh" if (access (im) == yes) { if (overwrite == yes) imdelete (im, verify=no) else return } # Create the image. mkpattern (im, output="", pattern="constant", option="replace", v1=0., v2=1., size=1, title=title, pixtype="short", ndim=2, ncols=ncols, nlines=nlines, header=header) # Add a data image. if (access (imdata//".imh") == yes) imdata = imdata // ".imh" if (access (imdata//".hhh") == yes) imdata = imdata // ".hhh" if (access (imdata) == yes) imcopy (imdata//datasec, im//datasec, verbose=no) # Add sky. value1 = exp * skyrate if (value1 != 0.) mkpattern (im//datasec, output="", pattern="constant", option="add", v1=value1, v2=1., size=1) # Add flat field response. if (flatslope != 0.) { valslope = (ncols + nlines) / 2. * flatslope value1 = 1 - valslope value2 = 1 + valslope mkpattern (im//datasec, output="", pattern="slope", option="multiply", v1=value1, v2=value2, size=1) } # Add zero level and dark count. value2 = zeroval + exp * darkrate valslope = (ncols + nlines) / 2. * (zeroslope + exp * darkslope) value1 = value2 - valslope value2 = value2 + valslope if ((value1 != 0.) && (value2 != 0.)) mkpattern (im//datasec, output="", pattern="slope", option="add", v1=value1, v2=value2, size=1) # Add bias. if (biasval != 0.) mkpattern (im, output="", pattern="constant", option="add", v1=biasval, v2=1., size=1) # Add noise. mknoise (im, output="", header="", background=0., gain=1., rdnoise=sigma, poisson=no, seed=seed, cosrays="", ncosrays=0, energy=30000., radius=0.5, ar=1., pa=0., comments=no) # Set bad pixels. if (access (badpix)) { list = badpix while (fscan (list, c1, c2, l1, l2) != EOF) { if (nscan() != 4) next c1 = max (1, c1) c2 = min (ncols, c2) l1 = max (1, l1) l2 = min (nlines, l2) s = "["//c1//":"//c2//","//l1//":"//l2//"]" mkpattern (im//s, output="", pattern="constant", option="replace", v1=badval, v2=1., size=1) } } # # Set bad pixels. # if (access (badpix) || access (badpix//".pl")) { # imcopy (im//datasec, "tmp$", verbose=no) # imexpr ("c ? a : b", im//datasec, badval, "tmp$"//im, # badpix//datasec, verbose=no) # imdelete ("tmp$"//im, verify=no) # hedit (im, "BPM", badpix, add=yes, verify=no, show=no, update=yes) # } # Set image header ccdhedit (im, "exptime", exp, type="real") if (obstype != "") ccdhedit (im, "imagetyp", obstype, type="string") if (datasec != "") ccdhedit (im, "datasec", datasec, type="string") if (trimsec != "") ccdhedit (im, "trimsec", trimsec, type="string") if (biassec != "") ccdhedit (im, "biassec", biassec, type="string") if (filter != "") ccdhedit (im, "subset", filter, type="string") end mscred-5.05-2018.07.09/src/ccdred/ccdtest/artobs.hlp000066400000000000000000000101541332166314300214320ustar00rootroot00000000000000.help artobs Oct87 noao.imred.ccdred.ccdtest .ih NAME artobs -- Make a demonstration CCD observation .ih USAGE artobs image exptime ccdtype .ih PARAMETERS .ls image Observation to be created. .le .ls exptime Exposure time of observation. .le .ls ccdtype CCD image type of observation. This type is one of the standard types for the CCDRED package. .le .ls ncols = 132, nlines = 100 The number of columns and lines in the full image created including bias section. .le .ls filter = "" Filter string for the observation. .le .ls datasec = "[1:100,1:100]" Data section of the observation. .le .ls trimsec = "[3:98,3:98]" Trim section for later processing. .le .ls biassec = "[103:130,*]" Prescan or overscan bias section. .le .ls imdata = "" Image to be used as source of observation if specified. The image must be at least as large as the data section. .le .ls skyrate = 0. Sky counting rate. The total sky value will be scaled by the exposure time. .le .ls badpix = "" Bad pixel region file in the standard CCDRED bad pixel file format. .le .ls biasval = 500. Mean bias value of the entire image. .le .ls badval = 500. Bad pixel value placed at the specified bad pixel regions. .le .ls zeroval = 100. Zero level of the data section. .le .ls darkrate = 1. Dark count rate. The total dark count will be scaled by the exposure time .le .ls zeroslope = 0.01 Slope of the zero level per pixel. .le .ls darkslope = 0.002 Slope of the dark count rate per pixel. This is also scaled by the exposure time. .le .ls flatslope = 3.0000000000000E-4 The mean flat field response is 1 with a slope given by this value. .le .ls sigma = 5. Gaussian noise sigma per pixel. .le .ls seed = 0 Random number seed. If zero new values are used for every observation. .le .ls overwrite = no Overwrite an existing image? If no a new observation is not created. There is no warning message. .le .ih DESCRIPTION This script task generates artificial CCD observations which include bad pixels, bias and zero levels, dark counts, flat field response variations and sky brightness levels. Optionally, image data from a reference image may be included. This task is designed to be used with the \fBccdred\fR package and includes appropriate image header information. First the task checks whether the requested image exists. If it does exist and the overwrite flag is no then a new observations is not created. If the overwrite flag is set then the old image is deleted and a new observation is created. An empty image of the specified size and of pixel data type short is first created. If a noise sigma is specified it is added to the entire image. If a reference image is specified then image section given by the \fIdatasec\fR parameter is copied into the data section of the observation. Next a sky level, specified by the \fIskyrate\fR parameter times the exposure time, is added to the data section. The flat field response with a mean of one and a slope given by the \fIflatslope\fR parameter is multiplied into the data section. If a dark count rate and/or a zero level is specified then these effects are added to the data section. Then the specified bias level is added to the entire image; i.e. including the bias section. Finally, the pixels specified in the bad pixel region file, if one is specified, are set to the bad pixel value. The CCD reduction parameters for the data section, the trim section, the bias section, exposure time, the CCD image type, and the filter are added to the image header (if they are specified) using \fBccdhedit\fR to apply any keyword translation. .ih EXAMPLES 1. To create some test CCD images first set the task parameters such as number of columns and lines, data, bias, and trim sections, and data values. The images are then created as follows: cl> artobs.filter = "V" # Set the filter cl> artobs zero 0. zero # Zero level image cl> artobs dark 1000. dark skyrate=0. # Dark count image cl> artobs flat 1. flat skyrate=1000. # Flat field image cl> artobs obj 10. object # Object image Note that the CCD image type is not used explicitly so that for a dark count image you must set the sky count rate to zero. .ih SEE ALSO mkimage, subsection, demo .endhelp mscred-5.05-2018.07.09/src/ccdred/ccdtest/ccdtest.cl000066400000000000000000000003211332166314300213770ustar00rootroot00000000000000#{ CCDTEST -- CCDRED Test package artdata package ccdtest set demos = "ccdtest$demos/" task artobs = "ccdtest$artobs.cl" task subsection = "ccdtest$subsection.cl" task demos = "demos$demos.cl" clbye() mscred-5.05-2018.07.09/src/ccdred/ccdtest/ccdtest.hd000066400000000000000000000002031332166314300213730ustar00rootroot00000000000000# Help directory for the CCDTEST package. artobs hlp=artobs.hlp, src=artobs.cl subsection hlp=subsection.hlp, src=subsection.cl mscred-5.05-2018.07.09/src/ccdred/ccdtest/ccdtest.men000066400000000000000000000002661332166314300215700ustar00rootroot00000000000000 artobs - Create an artificial CCD observation demos - Run demonstrations or tests of the CCD reduction package subsection - Create an artificial subsection CCD observation mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/000077500000000000000000000000001332166314300205415ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/Revisions000066400000000000000000000010631332166314300224450ustar00rootroot00000000000000.help revisions Aug96 noao.imred.ccdred.ccdtest.demos .nf ccdred$ccdtest/demos/demos.cl + ccdred$ccdtest/demos/demos.men + ccdred$ccdtest/demos/demos.par + ccdred$ccdtest/demos/badpix.dat + ccdred$ccdtest/demos/ccdred.cl + ccdred$ccdtest/demos/ccdred.dat + ccdred$ccdtest/demos/qccdred.cl + ccdred$ccdtest/demos/qccdred.dat + The initial "demos" are ccdred and qccdred. The former is the same as the earlier demo and the latter is a very shorttened version which creates only a few images and skips the combining step. (8/14/96, Valdes) .endhelp mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/badpix.dat000066400000000000000000000000641332166314300225020ustar00rootroot0000000000000010 10 1 10000 20 20 1 20 30 30 50 100 1 10000 50 50 mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/ccdred.cl000066400000000000000000000001511332166314300223020ustar00rootroot00000000000000# Full demo of CCDRED developed originally for AAS demo. stty (playback="demos$ccdred.dat", verify=yes) mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/ccdred.dat000066400000000000000000000156251332166314300224700ustar00rootroot00000000000000\O=NOAO/IRAF V2.5 valdes@lyra Mon 15:42:35 12-Oct-87 \T=vt640 \G=vt640 clear\n\{%V-%!200\} \n\{%10000 CCD REDUCTION DEMONSTRATION In this demonstration we are going to make some (artificial) CCD observations which we will reduce using the CCDRED package. The dome is opening and we are ready to begin observing...\} \n\{%V-\} unlearn\sccdred;unlearn\sccdtest\n\{ # Initialize parameters and data...\} imdelete\s%B%%*.??h\sv-\n\{%V-\} imrename\sB*.??h\s%B%%*.??h\sv-\n\{%V-\} imdelete\sZero*.??h,Flat*.??h\n\{%V-\} delete\sDemo*\sv-\n\{%V-\} \n\{%V-\} setinstrument\sdemo\sreview-\n\{ # Set instrument parameters...\} lpar\sartobs\n\{ # List observing parameters...\} artobs\sobs001\s0.\szero\n\{%15000 # Observe zero level images...\} artobs\sobs002\s0.\szero\n\{%V-\} artobs\sobs003\s0.\szero\n\{%V-\} artobs\sobs004\s0.\szero\n\{%V-\} artobs\sobs005\s0.\szero\n\{%V-\} \n\{%V-\} artobs.skyrate=0\n\{ # Observe a long dark count...\} artobs\sobs006\s1000.\sdark\n\{%V-\} \n\{%V-\} artobs.filter="V"\n\{ # Observe V flat fields...\} artobs.skyrate=2000\n\{%V-\} artobs\sobs007\s1.\sflat\n\{%V-\} artobs\sobs008\s1.\sflat\n\{%V-\} artobs\sobs009\s1.\sflat\n\{%V-\} artobs\sobs010\s1.\sflat\n\{%V-\} artobs\sobs011\s2.\sflat\n\{%V-\} artobs\sobs012\s2.\sflat\n\{%V-\} \n\{%V-\} artobs.filter="B"\n\{ # Observe B flat fields...\} artobs.skyrate=1000\n\{%V-\} artobs\sobs013\s1.\sflat\n\{%V-\} artobs\sobs014\s2.\sflat\n\{%V-\} artobs\sobs015\s3.\sflat\n\{%V-\} artobs\sobs016\s3.\sflat\n\{%V-\} artobs\sobs017\s3.\sflat\n\{%V-\} artobs\sobs018\s3.\sflat\n\{%V-\} \n\{%V-\} artobs.filter="V"\n\{ # Observe objects...\} artobs.skyrate=100\n\{%V-\} artobs\sobs019\s10.\sobject\simdata=dev$pix\n\{%V-\} artobs\sobs020\s20.\sobject\simdata=dev$pix\n\{%V-\} artobs.filter="B"\n\{%V-\} artobs\sobs021\s30.\sobject\simdata=dev$pix\n\{%V-\} artobs\sobs022\s40.\sobject\simdata=dev$pix\n\{%V-\} \n\{%V-\} lpar\ssubsection\n\{ # Subsection readout parameters...\} subsection\sobs023\sobs019\n\{%5000 # Readout a subsection of the CCD...\} dir\n\{ # Check directory of observations...\} clear\n\{%10000 # Continue...\} \n\{%15000 INSTRUMENT SETUP Because there are a variety of instruments, observatories, and data formats there are many parameters. To set all of these conveniently there is a task which reads setup files prepared by the observing staff. The setup task: 1. Defines an instrument header translation file which translates the image header parameters to something the CCDRED package understands. This is an important feature of the package. 2. It runs a setup script which sets parameters and performs other functions desired by the observing staff. 3. The user is then given the opportunity to modify the package and processing parameters...\} \n\{%V-\} setinstrument\smode=m\n\{ # Set demo instrument parameters...\} demo\r \{%5000\}^Z \{%5000\}^Z \{%5000\}\r \r \r \r \r \r \r \r \r \r \r \r \r \r \r \r \r \r Zero\r \r Flat*.??h\r ^Z clear\n\{%5000 # Continue...\} \n\{%20000 IMAGE HEADERS The CCDRED package uses image header information if present. This includes the type of data (object, flat field, etc.), exposure time, region of image containing the data, processing status, and more. To make this more general there is a instrument header translation file to translate image header keywords to the standard names used by the package. In this example the image header keywords are identical to the package except that the image type is CCDTYPE, the exposure time is INTEG and the subset parameter is FILTER. Let's look at the image header using the the standard image header lister and the special one in the CCDRED package. This special lister provides additional information about image types and processing status...\} \n\{%V-\} imheader\sobs023\sl+\n\{ # List object image header...\} ccdlist\sobs*.??h\n\{%5000 # List short CCD status...\} ccdlist\sobs023\sl+\n\{%5000 # List long CCD status...\} clear\n\{%5000 # Continue...\} \n\{%20000 COMBINE CALIBRATION IMAGES In order to reduce calibration noise and eliminate cosmic ray events we combine many zero level and flat field calibration images. The combining task provides many options. We will combine the images by scaling each image to the same exposure time, rejecting the highest pixel at each image point, and taking a weighted average of the remainder. Flat field images must be combined separately for each filter. We will simply specify all the images and the task automatically selects the appropriate images to combine! ...\} \n\{%V-\} zerocombine\smode=m\n\{ # Combine zero level images...\} obs*.??h\r \{%5000\}^Z flatcombine\smode=m\n\{ # Combine flat field images...\} obs*.??h\r \{%5000\}^Z clear\n\{%5000 # Continue...\} \n\{%15000 PROCESS OBSERVATIONS We are now ready to process our observations. The processing steps we have selected are to replace bad pixels by interpolation, fit and subtract a readout bias given by an overscan strip, subtract the zero level calibration image, scale and subtract a dark count calibration, divide by a flat field, trim the image of the overscan strip and border columns and lines. The task which does this is "ccdproc". The task is expert at reducing CCD observations easily and efficiently. It checks the image types, applies the proper filter flat field, applies the proper part of the calibration images to subsection readouts, does only the processing steps selected if not done previously, and automatically processes the calibration images as needed. As before we simply specify all the images and the task selects the appropriate images to process including finding the one dark count image "obs006". Watch the log messages to see what the task is doing...\} \n\{%V-\} ccdproc\sobs*.??h\n\{ # Process object images...\} \n\{%V-\} \{%V-\}q0,+,\r NO\n\{%V-\} \n\{%10000 That's it! We're done. Now lets check the results. The "ccdlist" listing will show the processing status and the images are now smaller and of pixel datatype real. The CCDSEC parameter identifies the relation of the image to the actual CCD pixels of the detector...\} \n\{%V-\} ccdlist\sobs*.??h\sccdtype=object\n\{ # List short CCD status...\} ccdlist\sobs023\sl+\n\{%5000 # List long CCD status...\} imhead\sobs023\sl+\n\{%5000 # List object image header...\} dir\n\{%5000 # Check the data directory...\} \n\{%V- We specified that the original images be saved by using the prefix B. We are also left with a text log file, a metacode file containing the fits to the overscan regions, and a file which maps the filter subset strings to short identifiers used in CCDLIST and when creating the combined images "FlatV" and "FlatB". You may look through these files, or use GKIMOSAIC to examine the metacode file, now if you want. \} mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/demos.cl000066400000000000000000000005551332166314300221750ustar00rootroot00000000000000# DEMOS -- Run specified demo provided a demo file exists. procedure demos (demoname) file demoname {prompt="Demo name"} begin file demo, demofile if ($nargs == 0 && mode != "h") type ("demos$demos.men") demo = demoname demofile = "demos$" // demo // ".cl" if (access (demofile)) cl (< demofile) else error (1, "Unknown demo " // demo) end mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/demos.men000066400000000000000000000004351332166314300223530ustar00rootroot00000000000000 MENU of CCDRED Demonstrations ccdred - Full demo of CCDRED mkqdata - Make some quick test data for CCDPROC qccdproc - Quick test of CCDPROC mkmosaic - Make NOAO CCD Mosaic test data mkmosaic1 - Make NOAO CCD Mosaic test data with ASCII and binary tables mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/demos.par000066400000000000000000000000571332166314300223560ustar00rootroot00000000000000demoname,f,a,"",,,"Demo name" mode,s,h,"ql",,, mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mkmosaic.cl000066400000000000000000000172331332166314300226720ustar00rootroot00000000000000# Make CCD Mosaic data. ccdred.instrument = "ccddb$kpno/mosaic.dat" s1 = mktemp ("tmp") // ".fits" s2 = mktemp ("tmp") // ".fits" j = 0 # Number of table extensions k = 8 # Number of image extensions if (access ("Zero.fits") == no) { print ("Making zero image `Zero' ...") artobs (s2, 0., "zero", filter="V", skyrate=0., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "zero", type="string") ccdhedit (s3, "exptime", 0., type="real") ccdhedit (s3, "darktime", 0., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "Zero") imdelete (s2, verify=no) } else ; if (access ("Dark.fits") == no) { print ("Making dark count image `Dark' ...") artobs (s2, 1000., "dark", filter="V", skyrate=0., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "dark", type="string") ccdhedit (s3, "exptime", 1000., type="real") ccdhedit (s3, "darktime", 1000., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "Dark") imdelete (s2, verify=no) } else ; if (access ("FlatV.fits") == no) { print ("Making flat field image `FlatV' ...") artobs (s2, 1., "flat", filter="V", skyrate=2000., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "flat", type="string") ccdhedit (s3, "exptime", 1., type="real") ccdhedit (s3, "darktime", 1., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "FlatV") imdelete (s2, verify=no) } else ; if (access ("FlatB.fits") == no) { print ("Making flat field image `FlatB' ...") artobs (s2, 2., "flat", filter="B", skyrate=1000., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "flat", type="string") ccdhedit (s3, "exptime", 2., type="real") ccdhedit (s3, "darktime", 2., type="real") ccdhedit (s3, "subset", "B", type="string") } imrename (s1, "FlatB") imdelete (s2, verify=no) } else ; if (access ("obs001.fits") == no) { print ("Making object image `obs001' ...") artobs (s2, 10., "object", filter="V", skyrate=200., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "object", type="string") ccdhedit (s3, "exptime", 10., type="real") ccdhedit (s3, "darktime", 10., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "obs001") imdelete (s2, verify=no) } else ; if (access ("obs002.fits") == no) { print ("Making object image `obs002' ...") artobs (s2, 20., "object", filter="B", skyrate=100., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "object", type="string") ccdhedit (s3, "exptime", 20., type="real") ccdhedit (s3, "darktime", 20., type="real") ccdhedit (s3, "subset", "B", type="string") } imrename (s1, "obs002") imdelete (s2, verify=no) } else ; mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mkmosaic1.cl000066400000000000000000000172331332166314300227530ustar00rootroot00000000000000# Make CCD Mosaic data. ccdred.instrument = "ccddb$kpno/mosaic.dat" s1 = mktemp ("tmp") // ".fits" s2 = mktemp ("tmp") // ".fits" j = 2 # Number of table extensions k = 8 # Number of image extensions if (access ("Zero.fits") == no) { print ("Making zero image `Zero' ...") artobs (s2, 0., "zero", filter="V", skyrate=0., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "zero", type="string") ccdhedit (s3, "exptime", 0., type="real") ccdhedit (s3, "darktime", 0., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "Zero") imdelete (s2, verify=no) } else ; if (access ("Dark.fits") == no) { print ("Making dark count image `Dark' ...") artobs (s2, 1000., "dark", filter="V", skyrate=0., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "dark", type="string") ccdhedit (s3, "exptime", 1000., type="real") ccdhedit (s3, "darktime", 1000., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "Dark") imdelete (s2, verify=no) } else ; if (access ("FlatV.fits") == no) { print ("Making flat field image `FlatV' ...") artobs (s2, 1., "flat", filter="V", skyrate=2000., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "flat", type="string") ccdhedit (s3, "exptime", 1., type="real") ccdhedit (s3, "darktime", 1., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "FlatV") imdelete (s2, verify=no) } else ; if (access ("FlatB.fits") == no) { print ("Making flat field image `FlatB' ...") artobs (s2, 2., "flat", filter="B", skyrate=1000., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "flat", type="string") ccdhedit (s3, "exptime", 2., type="real") ccdhedit (s3, "darktime", 2., type="real") ccdhedit (s3, "subset", "B", type="string") } imrename (s1, "FlatB") imdelete (s2, verify=no) } else ; if (access ("obs001.fits") == no) { print ("Making object image `obs001' ...") artobs (s2, 10., "object", filter="V", skyrate=200., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "object", type="string") ccdhedit (s3, "exptime", 10., type="real") ccdhedit (s3, "darktime", 10., type="real") ccdhedit (s3, "subset", "V", type="string") } imrename (s1, "obs001") imdelete (s2, verify=no) } else ; if (access ("obs002.fits") == no) { print ("Making object image `obs002' ...") artobs (s2, 20., "object", filter="B", skyrate=100., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no, title="M51", header="demos$mosaic/mosaic1.dat") mkpattern (s1, output="", title="M51", pixtype="short", ndim=0, header="demos$mosaic/mosaic0a.dat") if (j > 0) concatenate ("demos$mosaic/atable.dat", s1, out_type="binary", append=yes) if (j > 1) concatenate ("demos$mosaic/btable.dat", s1, out_type="binary", append=yes) for (i=1; i<=k; i+=1) imcopy (s2, s1//"[inherit]", verbose=no) for (i=k; i>=0; i-=1) { if (i == 0) s3 = s1 // "[0]" else s3 = s1 // "[" // i+j // "]" mkheader (s3, "demos$mosaic/mosaic"//i//".dat", append=no, verbose=no) ccdhedit (s3, "imagetyp", "object", type="string") ccdhedit (s3, "exptime", 20., type="real") ccdhedit (s3, "darktime", 20., type="real") ccdhedit (s3, "subset", "B", type="string") } imrename (s1, "obs002") imdelete (s2, verify=no) } else ; mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mkqdata.cl000066400000000000000000000052421332166314300225060ustar00rootroot00000000000000# Make some data. s1 = "." // envget ("imtype") if (access ("Zero" // s1) == no) { print ("Making zero image `Zero' ...") artobs ("Zero", 0., "zero", filter="V", skyrate=0., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no) } else ; if (access ("Dark" // s1) == no) { print ("Making dark count image `Dark' ...") artobs ("Dark", 1000., "dark", filter="V", skyrate=0., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no) } else ; if (access ("FlatV" // s1) == no) { print ("Making flat field image `FlatV' ...") artobs ("FlatV", 1., "flat", filter="V", skyrate=2000., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no) } else ; if (access ("FlatB" // s1) == no) { print ("Making flat field image `FlatB' ...") artobs ("FlatB", 1., "flat", filter="B", skyrate=1000., imdata="", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no) } else ; if (access ("obs001" // s1) == no) { print ("Making object image `obs001' ...") artobs ("obs001", 10., "object", filter="V", skyrate=100., imdata="dev$pix", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no) } else ; if (access ("obs002" // s1) == no) { print ("Making object image `obs002' ...") artobs ("obs002", 30., "object", filter="B", skyrate=100., imdata="dev$pix", ncols=132, nlines=100, datasec="[1:100,1:100]", trimsec="[3:98,3:98]", biassec="[103:130,*]", badpix="demos$badpix.dat", biasval=500., badval=500., zeroval=100., darkrate=1., zeroslope=0.01, darkslope=0.002, flatslope=3.0000000000000E-4, sigma=5., seed=0, overwrite=no) } else ; mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/000077500000000000000000000000001332166314300220145ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/acols.dat000066400000000000000000000000141332166314300236020ustar00rootroot00000000000000COLUMN1 A20 mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/adata.dat000066400000000000000000000000301332166314300235510ustar00rootroot00000000000000# Table data file Value mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/ahdr.dat000066400000000000000000000001101332166314300234140ustar00rootroot00000000000000# Header information COMMENT Possible CCD Mosaic ASCII Table Extension mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/bcols.dat000066400000000000000000000000141332166314300236030ustar00rootroot00000000000000COLUMN1 20A mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/bdata.dat000066400000000000000000000000301332166314300235520ustar00rootroot00000000000000# Table data file Value mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/bhdr.dat000066400000000000000000000001111332166314300234160ustar00rootroot00000000000000# Header information COMMENT Possible CCD Mosaic Binary Table Extension mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mkextns.cl000066400000000000000000000013411332166314300240240ustar00rootroot00000000000000# Make data file of ASCII and binary table extensions using FTOOLS package. # The data files are created as appendable extensions since users # may not have FTOOLS installed. ftools > dev$null futils > dev$null fcreate ("acols.dat", "adata.dat", "atable.fits", headfile="ahdr.dat", tbltype="ASCII", nskip=0, nrows=0, history=yes, morehdr=0, extname="atable", anull=" ", inull=0, clobber=yes) !tail +2881c atable.fits > atable.dat delete ("atable.fits", verify=no) fcreate ("bcols.dat", "bdata.dat", "btable.fits", headfile="bhdr.dat", tbltype="binary", nskip=0, nrows=0, history=yes, morehdr=0, extname="btable", anull=" ", inull=0, clobber=yes) !tail +2881c btable.fits > btable.dat delete ("btable.fits", verify=no) mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic0.dat000066400000000000000000000133741332166314300240510ustar00rootroot00000000000000OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPREQ = 600. / Requested exposure time (sec) RADECSYS= 'FK5 ' / Default coordinate system EQUINOX = 2000.0 / Default coordinate equinox OBJNAME = 'M51 ' / Target object OBJTYPE = 'galaxy ' / Type of object OBJRA = '13:29:24.00' / Right ascension of object (hours) OBJDEC = '47:15:34.00' / Declination of object (deg) OBJEPOCH= 1950.0 / Epoch of object coordinates TIMESYS = 'UTC ' / Default time system MJDHDR = 46890.393982 / MJD of header creation MJD-OBS = 46890.394063 / MJD of observation DATE-OBS= '05/04/87' / UTC date of observation UTC = '09:27:27.00' / UTC of observation LST = '14:53:42.00' / LST of observation OBSERVAT= 'KPNO ' / Observatory WEATHER = 'clear ' / Weather conditions PHOTOMET= 'photometric' / Photometric conditions SEEING = 0.90 / FWHM (arc sec) ENVTEM = 61.10 / Site temperature (deg C) ENVPRE = 972.1 / Air pressure (mbars) ENVHUM = 22.2 / Relative humidity ENVDIR = 84.1 / Average wind direction (deg) ENVWIN = 10.21 / Average wind speed (km/s) ENVGUS = 18.20 / Maximum gust speed (km/s) ENVPER = 60.0 / Wind sampling period (sec) DMETEM = 63.4 / Dome temperature (deg C) DMEWIN = 3.22 / Average dome wind speed (km/s) DMEGUS = 8.20 / Maximum dome wind speed (km/s) DMEPER = 60.0 / Dome wind sampling (sec) DOMSTAT = 'open tracking' / Dome status TELESCOP= '4m ' / Telescope TELCONF = 'prime ' / Telescope configuration TELTCS = 'TCS V1.0' / Telescope control system TELRA = '13:29:24.00' / Telescope right ascension (hours) TELDEC = '47:15:34.00' / Telescope declination (hours) TELEPOCH= 1987.123456 / Telescope coordinate epoch TELFOCUS= 1430 / Telescope focus TELTEM = 63.2 / Telescope temperature TELSTAT = 'tracking' / Telescope status ZD = 42.359 / Zenith distance (deg) HA = '-01:33:55.21' / Hour angle (hours) CORRECT = 'doublet ' / Corrector ADC = '4m ADC ' / ADC ADCPAN = 130.0 / ADC position angle (deg) ADAPTER = 'prime ' / Adapter ADAPAN = 0.0 / Adpater position angle (deg) TV = 'Mosaic TV #1' / TV TVFILT = 'V ' / Filter name TVFTYP = 'KP1408 2x2 6mm DDO Set' / Filter type TVFPOS = 5. / Filter system position TVFILT02= 'ND3 ' / Insert filter name GUIDER = '4m guider' / Guider name GUIRA = '13:29:24.00' / Guider right ascension (hours) GUIDEC = '47:15:34.00' / Guider declination (deg) GUIPOS = 12.312 -3.121 / Guide probe position GUIRATE = 10.0 / Guider rate (hz) CAMERA = 'Mosaic V1' / Camera name CAMFOCUS= -0.054 / Camera focus CAMPAN = 0.0 / Camera position angle (deg) DEWAR = 'Mosaic dewar V1' / Dewar hardware DEWTEM = -91. / Dewar temperature (deg C) DEWSTAT = 'ok ' / Dewar status SHUTSTAT= 'ccd open, tv open' / Shutter status SHUTOPEN= 2.0 / Shutter open time (ms) SHUTCLOS= 2.0 / Shutter close time (ms) FILTER = 'V ' / Filter name FILTYP = 'KP1408 2x2 6mm DDO Set' / Filter type FILPOS = 5. / Filter system position DETECTOR= 'Mosaic V1' / Detector name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) RAPANGL = -90.0 / Position angle of RA axis (deg) DECPANGL= 0.0 / Position angle of Dec axis (deg) PIXSCAL1= 15.9 / Pixel scale (arcsec/pixel) PIXSCAL2= 15.9 / Pixel scale (arcsec/pixel) CONTROLR= 'Arcon V1.0' / Detector controller CONSWV = 'Arcon V1.0' / Controller software version AMPINTEG= 15000. / Amplifier integration time (ns) AMPREAD = 39480. / Unbinned pixel read time (ns) AMPSAMPL= 'fast mode - dual correlated sampling' / Amplifier sampling method ARCONWM = 'OverlapXmit EarlyReset' / Arcon waveform options enabled ARCONWF = 'Obs Fri Nov 10 22:50:17 1995' / Arcon Wavefile DETSIZE = '[1:400,1:400]' / Detector size NCCDS = 8 / Number of CCDs PREFLASH= 2.0 / Preflash time (sec) EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) OBSERVER= 'G. Jacoby, D. Tody, F. Valdes' / Observers PROPOSER= 'G. Jacoby, D. Tody, F. Valdes' / Proposers PROPOSAL= 'Search for primeval galaxies' / Proposal title PROPID = 'KPNO 12345' / Proposal identification FILENAME= 'obs001.fit' / Original filename DATAHWV = 'Solaris Telescope System V1' / Data system hardware version DATAACQ = 'ICE Version 3.1' / Data system software version PROCSTAT= 'unprocessed' / Processing status PHOTCAL = F / Data proportional to photons? ARCHIVE = 'KPNO STB' / Archive ARCHSTAT= 'archived' / Archive status ARCHSWV = 'STB Version 2' / Archive software version ARCHHWV = 'Exabyte EXB8500' / Archive hardware CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version KWDICT = 'NOAO FITS Keyword Dictionary: V0.0' / Keyword dictionary mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic0a.dat000066400000000000000000000133751332166314300242130ustar00rootroot00000000000000 XOBSID = 'kpno.4m.961225.257752' / Observation identification XOBJECT = 'M51 ' / Observation title XOBSTYPE= 'OBJECT ' / Observation type EXPREQ = 600. / Requested exposure time (sec) RADECSYS= 'FK5 ' / Default coordinate system EQUINOX = 2000.0 / Default coordinate equinox OBJNAME = 'M51 ' / Target object OBJTYPE = 'galaxy ' / Type of object OBJRA = '13:29:24.00' / Right ascension of object (hours) OBJDEC = '47:15:34.00' / Declination of object (deg) OBJEPOCH= 1950.0 / Epoch of object coordinates TIMESYS = 'UTC ' / Default time system MJDHDR = 46890.393982 / MJD of header creation MJD-OBS = 46890.394063 / MJD of observation DATE-OBS= '05/04/87' / UTC date of observation UTC = '09:27:27.00' / UTC of observation LST = '14:53:42.00' / LST of observation OBSERVAT= 'KPNO ' / Observatory WEATHER = 'clear ' / Weather conditions PHOTOMET= 'photometric' / Photometric conditions SEEING = 0.90 / FWHM (arc sec) ENVTEM = 61.10 / Site temperature (deg C) ENVPRE = 972.1 / Air pressure (mbars) ENVHUM = 22.2 / Relative humidity ENVDIR = 84.1 / Average wind direction (deg) ENVWIN = 10.21 / Average wind speed (km/s) ENVGUS = 18.20 / Maximum gust speed (km/s) ENVPER = 60.0 / Wind sampling period (sec) DMETEM = 63.4 / Dome temperature (deg C) DMEWIN = 3.22 / Average dome wind speed (km/s) DMEGUS = 8.20 / Maximum dome wind speed (km/s) DMEPER = 60.0 / Dome wind sampling (sec) DOMSTAT = 'open tracking' / Dome status TELESCOP= '4m ' / Telescope TELCONF = 'prime ' / Telescope configuration TELTCS = 'TCS V1.0' / Telescope control system TELRA = '13:29:24.00' / Telescope right ascension (hours) TELDEC = '47:15:34.00' / Telescope declination (hours) TELEPOCH= 1987.123456 / Telescope coordinate epoch TELFOCUS= 1430 / Telescope focus TELTEM = 63.2 / Telescope temperature TELSTAT = 'tracking' / Telescope status ZD = 42.359 / Zenith distance (deg) HA = '-01:33:55.21' / Hour angle (hours) CORRECT = 'doublet ' / Corrector ADC = '4m ADC ' / ADC ADCPAN = 130.0 / ADC position angle (deg) ADAPTER = 'prime ' / Adapter ADAPAN = 0.0 / Adpater position angle (deg) TV = 'Mosaic TV #1' / TV TVFILT = 'V ' / Filter name TVFTYP = 'KP1408 2x2 6mm DDO Set' / Filter type TVFPOS = 5. / Filter system position TVFILT02= 'ND3 ' / Insert filter name GUIDER = '4m guider' / Guider name GUIRA = '13:29:24.00' / Guider right ascension (hours) GUIDEC = '47:15:34.00' / Guider declination (deg) GUIPOS = 12.312 -3.121 / Guide probe position GUIRATE = 10.0 / Guider rate (hz) CAMERA = 'Mosaic V1' / Camera name CAMFOCUS= -0.054 / Camera focus CAMPAN = 0.0 / Camera position angle (deg) DEWAR = 'Mosaic dewar V1' / Dewar hardware DEWTEM = -91. / Dewar temperature (deg C) DEWSTAT = 'ok ' / Dewar status SHUTSTAT= 'ccd open, tv open' / Shutter status SHUTOPEN= 2.0 / Shutter open time (ms) SHUTCLOS= 2.0 / Shutter close time (ms) XFILTER = 'V ' / Filter name FILTYP = 'KP1408 2x2 6mm DDO Set' / Filter type FILPOS = 5. / Filter system position DETECTOR= 'Mosaic V1' / Detector name XDETRA = '13:29:24.00' / Detector right ascension (hours) XDETDEC = '47:15:34.00' / Detector declination (deg) RAPANGL = -90.0 / Position angle of RA axis (deg) DECPANGL= 0.0 / Position angle of Dec axis (deg) PIXSCAL1= 15.9 / Pixel scale (arcsec/pixel) PIXSCAL2= 15.9 / Pixel scale (arcsec/pixel) CONTROLR= 'Arcon V1.0' / Detector controller CONSWV = 'Arcon V1.0' / Controller software version AMPINTEG= 15000. / Amplifier integration time (ns) AMPREAD = 39480. / Unbinned pixel read time (ns) AMPSAMPL= 'fast mode - dual correlated sampling' / Amplifier sampling method ARCONWM = 'OverlapXmit EarlyReset' / Arcon waveform options enabled ARCONWF = 'Obs Fri Nov 10 22:50:17 1995' / Arcon Wavefile DETSIZE = '[1:400,1:400]' / Detector size NCCDS = 8 / Number of CCDs PREFLASH= 2.0 / Preflash time (sec) XEXPTIME= 600.15 / Exposure time (sec) XDARKTIM= 600.21 / Dark time (sec) OBSERVER= 'G. Jacoby, D. Tody, F. Valdes' / Observers PROPOSER= 'G. Jacoby, D. Tody, F. Valdes' / Proposers PROPOSAL= 'Search for primeval galaxies' / Proposal title PROPID = 'KPNO 12345' / Proposal identification FILENAME= 'obs001.fit' / Original filename DATAHWV = 'Solaris Telescope System V1' / Data system hardware version DATAACQ = 'ICE Version 3.1' / Data system software version PROCSTAT= 'unprocessed' / Processing status PHOTCAL = F / Data proportional to photons? ARCHIVE = 'KPNO STB' / Archive ARCHSTAT= 'archived' / Archive status ARCHSWV = 'STB Version 2' / Archive software version ARCHHWV = 'Exabyte EXB8500' / Archive hardware XCHECKSU= '0WDA3T940TA90T99' / Header checksum XDATASUM= 'aMmjbMkhaMkhaMkh' / Data checksum XCHECKVE= 'complement' / Checksum version KWDICT = 'NOAO FITS Keyword Dictionary: V0.0' / Keyword dictionary mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic1.dat000066400000000000000000000037331332166314300240500ustar00rootroot00000000000000EXTNAME = 'im1 ' / Extension name IMAGEID = 1 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 1 [1,1]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 1-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[1:100,1:100]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 1. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 1. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = 1. / Coordinate scale matrix CD2_2 = 1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic2.dat000066400000000000000000000037331332166314300240510ustar00rootroot00000000000000EXTNAME = 'im2 ' / Extension name IMAGEID = 2 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 2 [2,1]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 2-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[101:200,1:100]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 101. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 1. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = 1. / Coordinate scale matrix CD2_2 = 1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic3.dat000066400000000000000000000037331332166314300240520ustar00rootroot00000000000000EXTNAME = 'im3 ' / Extension name IMAGEID = 3 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 3 [3,1]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 3-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[201:300,1:100]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 201. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 1. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = 1. / Coordinate scale matrix CD2_2 = 1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic4.dat000066400000000000000000000037331332166314300240530ustar00rootroot00000000000000EXTNAME = 'im4 ' / Extension name IMAGEID = 4 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 4 [4,1]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 4-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[301:400,1:100]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 301. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 1. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = 1. / Coordinate scale matrix CD2_2 = 1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic5.dat000066400000000000000000000037331332166314300240540ustar00rootroot00000000000000EXTNAME = 'im5 ' / Extension name IMAGEID = 5 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 5 [1,2]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 5-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[100:1,200:101]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 100. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 200. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = -1. / Coordinate scale matrix CD2_2 = -1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic6.dat000066400000000000000000000037331332166314300240550ustar00rootroot00000000000000EXTNAME = 'im6 ' / Extension name IMAGEID = 6 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 6 [2,2]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 6-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[200:101,200:101]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 200. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 200. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = -1. / Coordinate scale matrix CD2_2 = -1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic7.dat000066400000000000000000000037331332166314300240560ustar00rootroot00000000000000EXTNAME = 'im7 ' / Extension name IMAGEID = 7 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 7 [3,2]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 7-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[300:201,200:101]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 300. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 200. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = -1. / Coordinate scale matrix CD2_2 = -1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/mosaic/mosaic8.dat000066400000000000000000000037331332166314300240570ustar00rootroot00000000000000EXTNAME = 'im8 ' / Extension name IMAGEID = 8 / Image identification OBSID = 'kpno.4m.961225.257752' / Observation identification OBJECT = 'M51 ' / Observation title OBSTYPE = 'OBJECT ' / Observation type EXPTIME = 600.15 / Exposure time (sec) DARKTIME= 600.21 / Dark time (sec) FILTER = 'V ' / Filter name DETRA = '13:29:24.00' / Detector right ascension (hours) DETDEC = '47:15:34.00' / Detector declination (deg) CCDNAME = 'Mosaic 8 [4,2]' / CCD identification CCDNAMPS= 1 / Number of amplifiers used AMPNAME = 'Amplifier 8-1' / Amplifier identification CCDSUM = '1 1 ' / CCD on-chip summing DETSEC = '[400:301,200:101]' / Section of detector CCDSIZE = '[1:100,1:100]' / CCD size CCDSEC = '[1:100,1:100]' / Region of CCD read BIASSEC = '[103:130,1:100]' / Bias section DATASEC = '[1:100,1:100]' / Data section TRIMSEC = '[3:98,3:98]' / Section of useful data GAIN = 3.2 / Amplifier gain (e/ADU) RDNOISE = 3.9 / Readout noise (e) ARCONGI = 2 / Gain selection (index into Gain Table) ARCONPG = 3.2 / Predicted gain (e/ADU) ARCONPRN= 3.9 / Predicted readout noise (e) CCDTEM = -104. / CCD temperature (deg C) CTYPE1 = 'PIXEL ' / Coordinate type CRVAL1 = 400. / Coordinate reference value CRPIX1 = 1. / Coordinate reference pixel CTYPE2 = 'PIXEL ' / Coordinate type CRVAL2 = 200. / Coordinate reference value CRPIX2 = 1. / Coordinate reference pixel CD1_1 = -1. / Coordinate scale matrix CD2_2 = -1. / Coordinate scale matrix CHECKSUM= '0WDA3T940TA90T99' / Header checksum DATASUM = 'aMmjbMkhaMkhaMkh' / Data checksum CHECKVER= 'complement' / Checksum version mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/qccdproc.cl000066400000000000000000000001121332166314300226510ustar00rootroot00000000000000# Quick test of CCDRED. stty (playback="demos$qccdproc.dat", verify=yes) mscred-5.05-2018.07.09/src/ccdred/ccdtest/demos/qccdproc.dat000066400000000000000000000104101332166314300230250ustar00rootroot00000000000000\O=NOAO/IRAF V2.5 valdes@lyra Mon 15:42:35 12-Oct-87 \T=vt640 \G=vt640 clear\n\{%V-%!200\} \n\{ CCD REDUCTION DEMONSTRATION In this demonstration we are going to make some (artificial) CCD observations which we will reduce using the CCDRED package. The dome is opening and we are ready to begin observing...\} \n\{%V-\} unlearn\sccdred;unlearn\sccdtest\n\{ # Initialize parameters and data...\} imdelete\s%B%%*.??h\sv-\n\{%V-\} imrename\sB*.??h\s%B%%*.??h\sv-\n\{%V-\} delete\sDemo*\sv-\n\{%V-\} \n\{%V-\} setinstrument\sdemo\sreview-\n\{ # Set instrument parameters...\} lpar\sartobs\n\{ # List observing parameters...\} artobs\sZero\s0.\szero\n\{ # Observe zero level images...\} \n\{%V-\} artobs.skyrate=0\n\{ # Observe a long dark count...\} artobs\sDark\s1000.\sdark\n\{%V-\} \n\{%V-\} artobs.filter="V"\n\{ # Observe V flat fields...\} artobs.skyrate=2000\n\{%V-\} artobs\sFlatV\s1.\sflat\n\{%V-\} \n\{%V-\} artobs.filter="B"\n\{ # Observe B flat fields...\} artobs.skyrate=1000\n\{%V-\} artobs\sFlatB\s1.\sflat\n\{%V-\} \n\{%V-\} artobs.filter="V"\n\{ # Observe objects...\} artobs.skyrate=100\n\{%V-\} artobs\sobs001\s10.\sobject\simdata=dev$pix\n\{%V-\} artobs.filter="B"\n\{%V-\} artobs\sobs002\s30.\sobject\simdata=dev$pix\n\{%V-\} dir\n\{ # Check directory of observations...\} clear\n\{%5000 # Continue...\} \n\{ INSTRUMENT SETUP Because there are a variety of instruments, observatories, and data formats there are many parameters. To set all of these conveniently there is a task which reads setup files prepared by the observing staff. The setup task: 1. Defines an instrument header translation file which translates the image header parameters to something the CCDRED package understands. This is an important feature of the package. 2. It runs a setup script which sets parameters and performs other functions desired by the observing staff. 3. The user is then given the opportunity to modify the package and processing parameters...\} \n\{%V-\} setinstrument\smode=m\n\{ # Set demo instrument parameters...\} demo\r \{%1000\}^Z \{%1000\}^Z \{%1000\}\r \r \r \r \r \r \r \r \r \r \r \r \r \r \r \r \r \r Zero\r Dark\r Flat*.??h\r ^Z clear\n\{%5000 # Continue...\} \n\{ PROCESS OBSERVATIONS We are now ready to process our observations. The processing steps we have selected are to replace bad pixels by interpolation, fit and subtract a readout bias given by an overscan strip, subtract the zero level calibration image, scale and subtract a dark count calibration, divide by a flat field, trim the image of the overscan strip and border columns and lines. The task which does this is "ccdproc". The task is expert at reducing CCD observations easily and efficiently. It checks the image types, applies the proper filter flat field, applies the proper part of the calibration images to subsection readouts, does only the processing steps selected if not done previously, and automatically processes the calibration images as needed. As before we simply specify all the images and the task selects the appropriate images to process. Watch the log messages to see what the task is doing...\} \n\{%V-\} ccdproc\sobs*.??h\n\{ # Process object images...\} \n\{%V-\} \{%V-\}q0,+,\r NO\n\{%V-\} \n\{ That's it! We're done. Now lets check the results. The "ccdlist" listing will show the processing status and the images are now smaller and of pixel datatype real. The CCDSEC parameter identifies the relation of the image to the actual CCD pixels of the detector...\} \n\{%V-\} ccdlist\sobs*.??h\sccdtype=object\n\{ # List short CCD status...\} ccdlist\sobs001\sl+\n\{ # List long CCD status...\} imhead\sobs001\sl+\n\{ # List object image header...\} dir\n\{ # Check the data directory...\} \n\{%V- We specified that the original images be saved by using the prefix B. We are also left with a text log file, a metacode file containing the fits to the overscan regions, and a file which maps the filter subset strings to short identifiers used in CCDLIST and when creating the combined images "FlatV" and "FlatB". You may look through these files, or use GKIMOSAIC to examine the metacode file, now if you want. \} mscred-5.05-2018.07.09/src/ccdred/ccdtest/subsection.cl000066400000000000000000000026021332166314300221300ustar00rootroot00000000000000# SUBSECTION -- Make a subsection CCD observation procedure subsection (subimage, image) string subimage {prompt="Subsection image name"} string image {prompt="Full image name"} int ncols=82 {prompt="Number of columns"} int nlines=50 {prompt="Number of lines"} string ccdsec="[26:75,26:75]" {prompt="CCD section"} string datasec="[1:50,1:50]" {prompt="Data section"} string trimsec="" {prompt="Trim section"} string biassec="[51:82,1:50]" {prompt="Bias section"} bool overwrite=no {prompt="Overwrite existing image?"} begin string im, imdata, s real biasval, sigma im = subimage imdata = image biasval = artobs.biasval sigma = artobs.sigma if (access (im//".imh") == yes) im = im // ".imh" if (access (im//".hhh") == yes) im = im // ".hhh" if (access (im) == yes) { if (overwrite == yes) imdelete (im, verify=no) else return } # Create the image. s = "[1:" // str (ncols) // ",1:" // str(nlines) // "]" imcopy (imdata//s, im, verbose=no) # Copy subsection image. imcopy (imdata//ccdsec, im//datasec, verbose=no) # Add bias. if (biasval != 0.) mkimage (im//biassec, "replace", biasval, slope=0., sigma=sigma, seed=0) # Set image header ccdhedit (im, "ccdsec", ccdsec, type="string") ccdhedit (im, "datasec", datasec, type="string") ccdhedit (im, "trimsec", trimsec, type="string") ccdhedit (im, "biassec", biassec, type="string") end mscred-5.05-2018.07.09/src/ccdred/ccdtest/subsection.hlp000066400000000000000000000045061332166314300223220ustar00rootroot00000000000000.help subsection Oct87 noao.imred.ccdred.ccdtest .ih NAME subsection -- Make a subsection readout CCD image .ih USAGE subsection subimage image .ih PARAMETERS .ls subimage Subsection image to be created. .le .ls image Full image from which to take the subsection readout. .le .ls ncols = 82, nlines = 50 Number of image columns and lines in the full subsection image including bias regions. .le .ls ccdsec="[26:75,26:75]" CCD section of the subsection. This is the image section of the full image to be used. .le .ls datasec = "[1:50,1:50]" Data section of the image. .le .ls trimsec = "" Trim section for later processing. .le .ls biassec="[51:82,1:50]" Prescan or overscan bias section. .le .ls overwrite = no Overwrite an existing image? If no a new observation is not created. There is no warning message. .le .ih DESCRIPTION This script task generates artificial CCD subsection observations which include bad pixels, bias and zero levels, dark counts, flat field response variations and sky brightness levels. It creates an subsection image which includes a bias section from a previously created image (created by the task \fBartobs\fR). This task is designed to be used with the \fBccdred\fR package and includes appropriate image header information. First the task checks whether the requested image exists. If it does exist and the overwrite flag is no then a new observations is not created. If the overwrite flag is set then the old image is deleted and a new observation is created. The image section give by the parameter \fIccdsec\fR of the reference image is copied to the new image. It is assumed the reference image contains any desired zero level, bias, flat field, and dark count effects. The bias section is then added with a bias value given by \fBartobs.biasval\fR with noise given by \fBartobs.sigma\fR. Also the image image header parameters from the reference image are copied and the data, bias, trim, and ccd section parameters are updated. .ih EXAMPLES 1. To create some test CCD images first create full frame observations with the task \fBartobs\fR. Then set the subsection parameters for the size of the subsection observation, the data section, trim section, bias section, and the CCD section of the subsection observation. cl> artobs obj 5 object filter=V cl> subsection obj1 object .ih SEE ALSO mkimage, artobs, demo .endhelp mscred-5.05-2018.07.09/src/ccdred/cosmicrays.par000066400000000000000000000012661332166314300206660ustar00rootroot00000000000000input,s,a,,,,List of images in which to detect cosmic rays output,s,a,,,,List of cosmic ray replaced output images (optional) badpix,s,h,"",,,"List of bad pixel files (optional) " ccdtype,s,h,"",,,CCD image type to select (optional) threshold,r,h,25.,,,Detection threshold above mean fluxratio,r,h,2.,,,Flux ratio threshold (in percent) npasses,i,h,5,1,,Number of detection passes window,s,h,"5","5|7",,"Size of detection window " interactive,b,h,yes,,,Examine parameters interactively? train,b,h,no,,,Use training objects? objects,*imcur,h,"",,,Cursor list of training objects savefile,f,h,"",,,File to save train objects answer,s,q,,"no|yes|NO|YES",,Review parameters for a particular image? mscred-5.05-2018.07.09/src/ccdred/darkcombine.cl000066400000000000000000000043061332166314300206020ustar00rootroot00000000000000# DARKCOMBINE -- Process and combine dark count CCD images. procedure darkcombine (input) string input {prompt="List of dark images to combine"} file output="Dark" {prompt="Output dark image root name"} string combine="average" {prompt="Type of combine operation", enum="average|median"} string reject="minmax" {prompt="Type of rejection", enum="none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip"} string ccdtype="dark" {prompt="CCD image type to combine"} bool process=yes {prompt="Process images before combining?"} bool delete=no {prompt="Delete input images after combining?"} string scale="exposure" {prompt="Image scaling", enum="none|mode|median|mean|exposure"} string statsec="" {prompt="Image section for computing statistics"} int nlow=0 {prompt="minmax: Number of low pixels to reject"} int nhigh=1 {prompt="minmax: Number of high pixels to reject"} int nkeep=1 {prompt="Minimum to keep (pos) or maximum to reject (neg)"} bool mclip=yes {prompt="Use median in sigma clipping algorithms?"} real lsigma=3. {prompt="Lower sigma clipping factor"} real hsigma=3. {prompt="Upper sigma clipping factor"} string rdnoise="0." {prompt="ccdclip: CCD readout noise (electrons)"} string gain="1." {prompt="ccdclip: CCD gain (electrons/DN)"} string snoise="0." {prompt="ccdclip: Sensitivity noise (fraction)"} real pclip=-0.5 {prompt="pclip: Percentile clipping parameter"} real blank=0. {prompt="Value if there are no pixels"} begin string ims, out ims = input out = output # Process images first if desired. if (process == YES) ccdproc (ims, output="", bpmasks="", ccdtype=ccdtype, noproc=no) # Combine the flat field images. combine (ims, output=out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigma="", imcmb="$I", combine=combine, reject=reject, ccdtype=ccdtype, amps=yes, subsets=no, delete=delete, project=no, outtype="real", outlimits="", offsets="none", masktype="none", blank=blank, scale=scale, zero="none", weight=no, statsec=statsec, lthreshold=INDEF, hthreshold=INDEF, nlow=nlow, nhigh=nhigh, nkeep=nkeep, mclip=mclip, lsigma=lsigma, hsigma=hsigma, rdnoise=rdnoise, gain=gain, snoise=snoise, sigscale=0.1, pclip=pclip, grow=0) end mscred-5.05-2018.07.09/src/ccdred/doc/000077500000000000000000000000001332166314300165465ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/doc/Notes000066400000000000000000000120371332166314300175640ustar00rootroot0000000000000012/15/93: I have modified CCDPROC to more fully support scan table observations. In combination with the ability to have the number of scan rows encoded in the image header automatically, this allows such data to be processed in a fairly foolproof and documented way. First if ccdproc.scancor=no then the NSCANROW keyword and nscan parameter are ignored. For actual scanned data this may be useful to override things. Otherwise the following steps are taken. The logic is slightly complex so that everything is done in the right order and only as needed. The task wants to apply dark count and flat field calibration images which have been scanned by the same number of rows. [Zero calibration images are assumed not to be scanned. This made sense to me but if desired the zero images can also be treated like the darks and flats.] This is similar to the way flat fields are checked for subset (filter/grating). If the appropriate dark or flat has not been scanned then it is scanned in software; i.e. a moving average is taken over the unscanned image. The number of scan rows is determined for each object being processed from the NSCANROW keyword or appropriate translation in the header translation file. If this keyword is not found the nscan parameter value is used; i.e. it is assumed the object image has been scanned by the specified amount. This allows using the software in cases where the number of scan rows is not encoded in the header. In the case of dark and flat images if NSCANROW is not found a value of 1 (unscanned) is assumed. The set of possible calibration images (from the zero and flat parameters or the list of input images) is searched for one which has been scanned with the same number of lines as the object being processed. If one is found it is processed as needed before applying to the object. If one is not found then an unscanned one is sought. It is an error if neither can be found. An unscanned image is first processed as necessary (overscan, trim, etc.) and then scanned in software to create a new image. The new image has the name of the unscanned image with the number of scan lines appended, for example Flat1.32. It also has the NSCANROW keyword added as well as a comment indicating the image from which it was created. This approach allows the calibration image to be created only once for each different scan format and the number of scan lines may be changed for different observations and the appropriate calibration made from the unscanned image. The following example shows how this all works. There are four object images using two filters and two scan row values and unscanned zero, dark, and flats. cc> dir Dark.imh FlatV.imh obs019.imh obs021.imh pixels FlatB.imh Zero.imh obs020.imh obs022.imh cc> hselect obs* $I,filter,nscanrow yes obs019.imh V 24 obs020.imh V 32 obs021.imh B 24 obs022.imh B 32 cc> ccdproc obs* overscan+ trim+ zerocor+ darkcor+ flatcor+ scancor+ obs019.imh: Dec 15 17:53 Zero level correction image is Zero Dark.imh: Dec 15 17:53 Zero level correction image is Zero Dark.24.imh: Dec 15 17:53 Converted to shortscan from Dark.imh with nscan=24 obs019.imh: Dec 15 17:53 Dark count correction image is Dark.24.imh FlatV.imh: Dec 15 17:53 Zero level correction image is Zero FlatV.imh: Dec 15 17:53 Dark count correction image is Dark.imh FlatV.24.imh: Dec 15 17:53 Converted to shortscan from FlatV.imh with nscan=24 obs019.imh: Dec 15 17:53 Flat field image is FlatV.24.imh obs020.imh: Dec 15 17:53 Zero level correction image is Zero Dark.32.imh: Dec 15 17:53 Converted to shortscan from Dark.imh with nscan=32 obs020.imh: Dec 15 17:53 Dark count correction image is Dark.32.imh FlatV.32.imh: Dec 15 17:53 Converted to shortscan from FlatV.imh with nscan=32 obs020.imh: Dec 15 17:53 Flat field image is FlatV.32.imh obs021.imh: Dec 15 17:53 Zero level correction image is Zero obs021.imh: Dec 15 17:53 Dark count correction image is Dark.24.imh FlatB.imh: Dec 15 17:53 Zero level correction image is Zero FlatB.imh: Dec 15 17:53 Dark count correction image is Dark.imh FlatB.24.imh: Dec 15 17:53 Converted to shortscan from FlatB.imh with nscan=24 obs021.imh: Dec 15 17:53 Flat field image is FlatB.24.imh obs022.imh: Dec 15 17:53 Zero level correction image is Zero obs022.imh: Dec 15 17:53 Dark count correction image is Dark.32.imh FlatB.32.imh: Dec 15 17:53 Converted to shortscan from FlatB.imh with nscan=32 obs022.imh: Dec 15 17:53 Flat field image is FlatB.32.imh cc> ccdlist *.imh cc> ccdlist *.imh Dark.24.imh[96,96][real][dark][][OTZ]: Dark.32.imh[96,96][real][dark][][OTZ]: Dark.imh[96,96][real][dark][][OTZ]: FlatB.24.imh[96,96][real][flat][B][OTZD]: FlatB.32.imh[96,96][real][flat][B][OTZD]: FlatB.imh[96,96][real][flat][B][OTZD]: FlatV.24.imh[96,96][real][flat][V][OTZD]: FlatV.32.imh[96,96][real][flat][V][OTZD]: FlatV.imh[96,96][real][flat][V][OTZD]: Zero.imh[96,96][real][zero][][OT]: obs019.imh[96,96][real][object][V][OTZDF]: obs020.imh[96,96][real][object][V][OTZDF]: obs021.imh[96,96][real][object][B][OTZDF]: obs022.imh[96,96][real][object][B][OTZDF]: Frank mscred-5.05-2018.07.09/src/ccdred/doc/ccdgeometry.hlp000066400000000000000000000074231332166314300215660ustar00rootroot00000000000000.help ccdgeometry Sep87 noao.imred.ccdred .ih NAME ccdgeometry - Discussion of CCD geometry and header parameters .ih DESCRIPTION The \fBccdred\fR package maintains and updates certain geometry information about the images. This geometry is described by four image header parameters which may be present. These are defined below by the parameter names used in the package. Note that these names may be different in the image header using the image header translation feature of the package. .ls DATASEC The section of the image containing the CCD data. If absent the entire image is assumed to be data. Only the pixels within the data section are modified during processing. Therefore, there may be additional calibration or observation information in the image. If after processing, the data section is the entire image it is not recorded in the image header. .le .ls CCDSEC The section of the CCD to corresponding to the data section. This refers to the physical format, columns and lines, of the detector. This is the coordinate system used during processing to relate calibration data to the image data; i.e. image data pixels are calibrated by calibration pixels at the same CCD coordinates regardless of image pixel coordinates. This allows recording only parts of the CCD during data taking and calibrating with calibration frames covering some or all of the CCD. The CCD section is maintained during trimming operations. Note that changing the format of the images by image operators outside of the \fBccdred\fR package will invalidate this coordinate system. The size of the CCD section must agree with that of the data section. If a CCD section is absent then it defaults to the data section such that the first pixel of the data section has CCD coordinate (1,1). .le .ls BIASSEC The section of the image containing prescan or overscan bias information. It consists of a strip perpendicular to the readout axis. There may be both a prescan and overscan but the package currently only uses one. This parameter may be overridden during processing by the parameter \fIccdproc.biassec\fR. Only the part of the bias section along the readout is used and the length of the bias region is determined by the trim section. If one wants to limit the region of the bias strip used in the fit then the \fIsample\fR parameter should be used. .le .ls TRIMSEC The section of the image extracted during processing when the trim operation is selected (\fIccdproc.trim\fR). If absent when the trim operation is selected it defaults to the data section; i.e. the processed image consists only of the data section. This parameter may be overridden during processing by the parameter \fIccdproc.trimsec\fR. After trimming this parameter, if present, is removed from the image header. The CCD section, data section, and bias section parameters are also modified by trimming. .le The geometry is as follows. When a CCD image is recorded it consists of a data section corresponding to part or all of the CCD detector. Regions outside of the data section may contain additional information which are not affected except by trimming. Most commonly this consists of prescan and overscan bias data. When recording only part of the full CCD detector the package maintains information about that part and correctly applies calibrations for that part of the detector. Also any trimming operation updates the CCD coordinate information. If the images include the data section, bias section, trim section, and ccd section the processing may be performed entirely automatically. The sections are specified using the notation [c1:c2,l1:l2] where c1 and c2 are the first and last columns and l1 and l2 are the first and last lines. Currently c1 and l1 must be less than c2 and l2 respectively and no subsampling is allowed. This may be added later. .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdgroups.hlp000066400000000000000000000136571332166314300212600ustar00rootroot00000000000000.help ccdgroups Nov96 noao.imred.ccdred .ih NAME ccdgroups -- Group CCD images into image lists .ih USAGE ccdgroups images output .ih PARAMETERS .ls images List of CCD images to be grouped. .le .ls output Output root group filename. The image group lists will be put in files with this root name followed by a numeric or character suffix. .le .ls group = "ccdtype" Group type. The group types are: .ls "keyword" Group by an arbitrary header keyword. The keyword is specified by the \fIkeyword\fR parameter. The keyword will be translated by the header translation file if there is an entry for the specified keyword. A missing keyword forms a valid group. The group file suffix is numeric. .le .ls "ccdtype" Group by the CCD image type. The ccdtypes are the standard strings with the header values translated to the standard types. The group file suffix is the ccdtype. .le .ls "subset" Group by the subset parameter. The subset is translated by the header translation file and the value is the mapped value set by the \fIsubset\fR file. The group file suffix is the mapped subset value. .le .ls "amplifier" Group by the amplifier parameter. The amplifier is translated by the header translation file and the value is the mapped value set by the \fIamp\fR file. The group file suffix is the mapped amplifier value. .le .ls "ampsubset" Group by both the amplifier and subset parameters. The group file suffix is the concatenation of the mapped amplifier and subset values. .le .ls "position" Group by position in right ascension (in hours) and declination (in degrees). The groups are defined by a radius parameter (in arc seconds). The group file suffix is numeric. .le .le .ls radius = 60. Grouping radius when grouping by positions. This is given in arc seconds. .le .ls ccdtype = "" CCD image types to select from the input image list. If null ("") then all image types are used. .le .ih DESCRIPTION The input images, possible restricted to a particular CCD image type, are grouped into image lists. The "ccdtype", "amplifier, "subset" or "ampsubset" groups produce output image lists with the given root name and the CCD type or subset as a suffix. For the other group types the image lists have file names given by the root output name and a numeric suffix. If the package parameter \fIccdred.verbose\fR is yes then the image name and output group list is printed for each image. The image lists can be used with the @ list feature for processing separate groups of observations. Note that grouping by CCD image type, amplifier, and subset is often not necessary since the \fBccdred\fR tasks automatically use this information (see \fBccdtypes\fR and \fBsubsets\fR). Besides CCD image type, amplifier, and subsets there are currently two other ways to group images. These are by position in the sky or by an arbitrary header keyword. The position grouping finds observations within a given radius on the sky of the first member of the group (this is not a clustering algorithm). The right ascension and declination coordinates must be in standard units, hours and degrees respectively. The grouping radius is in arc seconds. This grouping type is useful for making sets of data in which separate calibration images are taken at each position. The keyword grouping translates the specified keyword through the instrument translation file if an entry is found. Otherwise the keyword is used directly. Unique keyword values are then assign numeric suffixes for the grouping. Note that a missing keyword is a valid group. Some use keywords to use for grouping are "title" and "data-obs". .ih EXAMPLES 1. For each object 5 exposures were taken to be combined in order to remove cosmic rays. If the titles are the same then (with ccdred.verbose=yes): .nf cl> ccdgroups *.imh group group=keyword keyword=title ccdtype=object ccd005.imh --> group1 ccd006.imh --> group1 ccd007.imh --> group1 ccd008.imh --> group1 ccd009.imh --> group1 ccd012.imh --> group2 ccd013.imh --> group2 ccd014.imh --> group2 ccd015.imh --> group2 ccd016.imh --> group2 [... etc ...] cl> combine @group1 obj1 proc+ cl> combine @group2 obj2 proc+ [... etc ...] .fi Note the numeric suffixes to the output root name "group". 2. CCD observations were made in groups with a flat field, the object, and a comparison spectrum at each position. To group and process this data: .nf cl> ccdgroups *.imh obs group=position >> logfile cl> ccdproc @obs1 cl> ccdproc @obs2 cl> ccdproc @obs3 .fi Since no flat field is specified for the parameter \fIccdproc.flat\fR the flat field is taken from the input image list. 3. If for some reason you want to group by date and position it is possible to use two steps. .nf cl> ccdgroups *.imh date group=keyword keyword="date-obs" cl> ccdgroups @data1 pos1 cl> ccdgroups @data2 pos2 .fi 4. To get groups by CCD image type: .nf cl> ccdgroups *.imh "" group=ccdtype ccd005.imh --> zero ccd006.imh --> zero ccd007.imh --> zero ccd008.imh --> dark ccd009.imh --> flat ccd012.imh --> flat ccd013.imh --> object ccd014.imh --> object ccd015.imh --> object ccd016.imh --> object [... etc ...] .fi Note the use of a null root name and the extension is the standard CCDRED types (not necessarily those used in the image header). 5. To get groups by subset: .nf cl> ccdgroups *.imh filt group=subset ccd005.imh --> filt ccd006.imh --> filtB ccd007.imh --> filtB ccd008.imh --> filtB ccd009.imh --> filtV ccd012.imh --> filtV ccd013.imh --> filtV ccd014.imh --> filtB ccd015.imh --> filtB ccd016.imh --> filtB [... etc ...] .fi .ih REVISIONS .ls CCDGROUPS V2.11 New "amplifier" and "ampsubsets" grouping types have been added. The "title" and "date" groupings have been eliminated and a new general keyword grouping option has been added. .le .ih SEE ALSO ccdlist, ccdtypes, instruments, subsets .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdhedit.hlp000066400000000000000000000071631332166314300210310ustar00rootroot00000000000000.help ccdhedit Jun87 noao.imred.ccdred .ih NAME ccdhedit -- CCD image header editor .ih USAGE ccdhedit images parameter value .ih PARAMETERS .ls images List of CCD images to be edited. .le .ls parameter Image header parameter. The image header parameter will be translated by the header translation file for the images. .le .ls value The parameter value. If the null string ("") is specified then the parameter is deleted from the image header, otherwise it is added or modified. If the parameter is "imagetyp" then the value string giving the CCD image type is translated from the package CCD type to the instrument specific string. .le .ls type = "string" The parameter type. The parameter types are "string", "real", or "integer". .le .ih DESCRIPTION The image headers of the specified CCD images are edited to add, modify, or delete a parameter. The parameters may be those used by the \fBccdred\fR package. The parameter name is translated to an image header parameter by the instrument translation file (see \fBinstruments\fR) if a translation is given. Otherwise the parameter is that in the image header. If the parameter is "imagetyp" the parameter value for the CCD image type may be that used by the package; i.e. dark, object, flat, etc. The value string will be translated to the instrument image string in this case. The translation facility allows use of this task in an instrument independent way. The value string is used to determine whether to delete or modify the image parameter. If the null string, "", is given the specified parameter is deleted. If parameters are added the header type must be specified as a string, real, or integer parameter. The numeric types convert the value string to a number. .ih EXAMPLES The \fBccdred\fR package is usable even with little image header information. However, if desired the header information can be added to images which lack it. In all the examples the parameters used are those of the package and apply equally well to any image header format provided there is an instrument translation file. .nf 1. cl> ccdhedit obj* imagetyp object 2. cl> ccdhedit flat* imagetyp flat 3. cl> ccdhedit zero* imagetyp zero 4. cl> ccdhedit obj0![1-3]* subset "V filter" 5. cl> ccdhedit obj0![45]* subset "R filter" 6. cl> ccdhedit flat001 subset "R filter" 7. cl> ccdhedit obj* exptime 500 type=integer .fi 8. The following is an example of a CL script which sets the CCD image type, the subset, and the exposure time simultaneously. The user may expand on this example to include other parameters or other initialization operations. .nf cl> edit ccdheader.cl ---------------------------------------------------------------- # Program to set CCD header parameters. procedure ccdheader (images) string images {prompt="CCD images"} string imagetyp {prompt="CCD image type"} string subset {prompt="CCD subset"} string exptime {prompt="CCD exposure time"} begin string ims ims = images ccdhedit (ims, "imagetyp", imagetyp, type="string") ccdhedit (ims, "subset", subset, type="string") ccdhedit (ims, "exptime", exptime, type="real") end ---------------------------------------------------------------- cl> task ccdheader=ccdheader.cl cl> ccdheader obj* imagetyp=object subset="V" exptime=500 .fi 9. The image header may be changed to force processing a calibration image as an object. For example to flatten a flat field: .nf cl> ccdhedit testflat imagetyp other cl> ccdproc testflat .fi 10. To delete processing flags: cl> ccdhedit obj042 flatcor "" .ih SEE ALSO hedit, instruments, ccdtypes, subsets .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdinst.hlp000066400000000000000000000360501332166314300207060ustar00rootroot00000000000000.help ccdinstrument Aug96 noao.imred.ccdred .ih NAME ccdinstrument -- Setup and verify CCD instrument translation files .ih USAGE ccdinstrument images .ih PARAMETERS .ls images List of images to be verified or used to setup a CCD instrument translation file. .le .ls instrument = ")_.instrument" CCD instrument translation file. The default is to use the translation file defined in the \fBccdred\fR package parameters. Note that one would need write permission to update this file though the task has a write command to save any changes to a different file. .le .ls ampfile = ")_.ampfile" Amplifier translation file. The default is to use the file defined in the \Bccdred\fR package parameters. .ls ssfile = ")_.ssfile" Subset translation file. The default is to use the file defined in the \fBccdred\fR package parameters. .le .ls edit = yes Edit the instrument translation file? If "yes" an interactive mode is entered allowing translation parameters to be modified while if "no" the task is simply used to verify the translations noninteractively. .le .ls parameters = "basic" Parameters to be displayed. The choices are "basic" to display only the most basic parameters (those needed for the simplest automation of \fBccdred\fR tasks), "common" to display the common parameters used by the package (most of these are keywords to be written to the image rather than translated), and "all" to display all the parameters referenced by the package including the most obscure. For most uses the "basic" set is all that is important and the other options are included for completeness. .le .ih DESCRIPTION The purpose of this task is to provide an interface to simplify setting up CCD instrument translation files and to verify the translations for a set of images. Before this task was written users who needed to set up translation files for new instruments and observatories had to directly create the files with an editor. Many people encountered difficulties and were prone to errors. Also there was no task that directly verified the translations though \fBccdlist\fR provided some clues. The \fBccdred\fR package was designed to make intelligent use of information in image headers for determining things such as image calibration or object type and exposure times. While the package may be used without this capability it is much more convenient to be able to use information from the image. The package was also intended to be used with many different instruments, detectors, and observatories. The key to providing image header access across different observatories is the ability to translate the needs of the package to the appropriate keywords in the image header. This is done through a file called an "instrument translation file". For a complete description of this file and other instrument setup features of the package see \fBccdred.instruments\fR. The instrument translation file translates the parameter names used by the \fBccdred\fR package into image specific parameters and also supplies default values for parameters. The translation proceeds as follows. When a package task needs a parameter for an image, for example "imagetyp", it looks in the instrument translation file. If the file is not found or none is specified then the image header keyword that is requested is assumed to have the same name. If an instrument translation file is defined then the requested parameter is translated to an image header keyword, provided a translation entry is given. If no translation is given the package name is used. For example the package parameter "imagetyp" might be translated to "data-typ" (the old NOAO CCD keyword). If the parameter is not found then the default value specified in the translation file, if present, is returned. For recording parameter information in the header, such as processing flags, translation is also used. For example, if the flag specifying that the image has been corrected by a flat field is to be set then the package parameter name "flatcor" might be translated to "ff-flag". If no translation is given then the new image header parameter is entered as "flatcor". The CCD image type requires a second level of translation also defined in the translation file. Once the image keyword which identifies the type of CCD image, for example a flat field or object, is translated to an imahe keyword the specific string value must be translated to one of the CCD image types used by the package. The translation works in the same way, the specific string found is translated to the \fBccdred\fR type and returned to the task. This translation is tricky in that the exact string including all spaces and capitalizations must be correctly defined in the translation file. The \fBccdinstrument\fR allows doing this automatically thus minimizing typing errors. The basic display format of the task is a table of five columns giving the parameter name used by the package, the image keyword to which it is translated, the default value (if any), the value the task will receive for the current image after translation, and the actual keyword value in the image. A "?" is printed if a value cannot be determined. The idea of the task is to make sure that the value a \fBccdred\fR task sees is the correct one and if not to modify the translation appropriately. In verify mode when the \fBedit\fR parameter is not set the translation table is simply printed for each input image. In edit mode the user interactively gives commands at the ccdinstrument prompt to display or modify keywords. The modifications can then be written to the instrument file or saved in a private copy. The list of commands is shown below and may be printed using ? or help. .in 4 .nf 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 .fi 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. .nf BASIC PARAMETERS imagetyp Image type parameter (see also translate) amplifier Amplifier parameter subset Subset or filter parameter exptime Exposure time darktime Dark time (may be same as the exposure time) .fi .in -4 The commands may be followed by values such as file names for some of the general commands or the keyword and default value for the parameters to be translated. Note this is the only way to specify a default value. If no arguments are given the user is prompted with the current value which may then be changed. The set of parameters shown above are only those considered "basic". In order to avoid confusion the task can limit the set of parameters displayed. Without going into great detail, it is only the basic parameters which are generally required to have valid translations to allow the package to work well. However, for completeness, and if someone wants to go wild with translations, further parameters may be displayed and changed. The parameters displayed is controlled by the \fIparameters\fR keyword. The additional parameters not shown above are: .in 4 .nf 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 fringcor Fringe correction flag illumcor Ilumination correction flag readcor One dimensional zero level read out correction scancor Scan mode correction flag nscanrow Number of scan rows illumflt Ilumination flat image mkfringe Fringe image mkillum Illumination image skyflat Sky flat image ccdmean Mean value ccdmeant Mean value compute time fringscl Fringe scale factor ncombine Number of images combined date-obs Date of observations dec Declination ra Right Ascension title Image title .fi .in -4 .ih EXAMPLES 1. To verify the translations for a set of images using the default translation file: .nf cl> setinst "" review- cl> ccdinst dev$pix edit- Image: dev$pix Instrument file: Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE -------------------------------- imagetyp imagetyp none ? amp ampid ? subset subset ? exptime exptime ? ? darktime darktime ? ? cl> setinst "" site=kpno dir=ccddb$ review- cl> ccdinst dev$pix edit- Image: dev$pix Instrument file: ccddb$kpno/camera.dat Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE -------------------------------- imagetyp data-typ object OBJECT (0) amp ampid 1 1 subset f1pos 2 2 exptime otime 600 600 darktime ttime 600 600 .fi 2. Set up an instrument translation file from scratch. .nf ccdinst ech???.imh instr=myccd edit+ Warning: OPEN: File does not exist (myccd) Image: ech001.imh Instrument file: myccd Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE ------------------------------------------------------ imagetyp imagetyp none ? amp ampid ? subset subset ? exptime exptime ? ? darktime darktime ? ? ccdinstrument> imagetyp Image keyword for image type (imagetyp): ccdtype imagetyp ccdtype unknown BIAS ccdinstrument> translate CCDRED image type for 'BIAS' (unknown): zero imagetyp ccdtype zero BIAS ccdinstrument> subset Image keyword for subset parameter (subset): filters subset filters 1 1 0 ccdinstrument> exptime integ exptime integ 0. 0. ccdinstrument> darktime integ darktime integ 0. 0. ccdinstrument> show Image: ech001.imh Instrument file: myccd Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE ------------------------------------------------------ imagetyp ccdtype zero BIAS amp ampid ? subset filters 1 1 0 exptime integ 0. 0. darktime integ 0. 0. ccdinstrument> next Image: ech002.imh Instrument file: myccd Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE ------------------------------------------------------ imagetyp ccdtype unknown PROJECTOR FLAT amp ampid ? subset filters 1 1 0 exptime integ 20. 20. darktime integ 20. 20. ccdinstrument> trans CCDRED image type for 'PROJECTOR FLAT' (unknown): flat imagetyp ccdtype flat PROJECTOR FLAT ccdinstrument> next Image: ech003.imh Instrument file: myccd Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE ------------------------------------------------------ imagetyp ccdtype unknown COMPARISON amp ampid ? subset filters 1 1 0 exptime integ 300 300 darktime integ 300 300 ccdinstrument> translate comp imagetyp ccdtype comp COMPARISON ccdinstrument> next Image: ech004.imh Instrument file: myccd Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE ------------------------------------------------------ imagetyp ccdtype unknown OBJECT amp ampid ? subset filters 1 1 0 exptime integ 3600 3600 darktime integ 3600 3600 ccdinstrument> translate object imagetyp ccdtype object OBJECT ccdinstrument> inst imagetyp ccdtype BIAS zero subset filters exptime integ darktime integ 'PROJECTOR FLAT' flat COMPARISON comp OBJECT object ccdinstrument> next Update instrument file myccd (yes)? .fi 3. Set default geometry parameters. Note that to set a default the arguments must be on the command line. .nf cc> ccdinst ech001 instr=myccd param=common edit+ Image: ech001 Instrument file: myccd Amplifier file: ampfile Subset file: subsets CCDRED IMAGE DEFAULT CCDRED IMAGE PARAM KEYWORD VALUE VALUE VALUE ------------------------------------------------------ imagetyp ccdtype zero BIAS amp ampid ? subset filters 1 1 0 exptime integ 0. 0. darktime integ 0. 0. biassec biassec ? ? trimsec trimsec ? ? fixpix fixpix no ? overscan overscan no ? trim trim no ? zerocor zerocor no ? darkcor darkcor no ? flatcor flatcor no ? ccdinstrument> biassec biassec [803:830,*] biassec biassec [803:830,*] [803:830,*] ? ccdinstrument> trimsec trimsec [2:798,2:798] trimsec trimsec [2:798,2:798] [2:798,2:798] ? ccdinstrument> instr trimsec trimsec [2:798,2:798] biassec biassec [803:830,*] imagetyp ccdtype BIAS zero subset filters exptime integ darktime integ 'PROJECTOR FLAT' flat COMPARISON comp OBJECT object ccdinstrument> q Update instrument file myccd (yes)? .fi .ih REVISIONS .ls CCDINSTRUMENT V2.11 Added support for the amplifier parameter. .le .ih SEE ALSO instruments, setinstrument .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdlist.hlp000066400000000000000000000106201332166314300206770ustar00rootroot00000000000000.help ccdlist Aug96 noao.imred.ccdred .ih NAME ccdlist -- List CCD processing information .ih USAGE ccdlist images .ih PARAMETERS .ls images CCD images to be listed. A subset of the these may be selected using the CCD image type parameter. .le .ls ccdtype = "" CCD image type to be listed. If no type is specified then all the images are listed. If an image type is specified then only images of that type are listed. See \fBccdtypes\fR for a list of the package image types. .le .ls names = no List the image names only? Used with the CCD image type parameter to make a list of the images of the specified type. .le .ls long = no Long format listing? The images are listed in a long format containing some image parameters and the processing history. .le .ls ccdproc (pset) CCD processing parameter set. .le .ih DESCRIPTION Information from the specified input images is listed on the standard output. A specific CCD image type may be selected from the input images by the parameter \fIccdtype\fR. There are three list formats; the default one line per image format, an image name only format, and a multi-line long format. The default one line format consists of the image name, image size, image pixel type, CCD image type, amplifier ID (if defined), subset ID (if defined), processing flags, and title. This format contains the same information as that produced by \fBimheader\fR as well as CCD specific information. The processing flags identifying the processing operations performed on the image are given by the following single letter codes. .nf B - Bad pixel replacement O - Overscan bias subtraction T - Trimming Z - Zero level subtraction D - Dark count subtraction F - Flat field calibration I - Illumination correction Q - Fringe correction .fi The long format has the same first line as the default format plus additional instrument information such as the exposure time and the full processing history. In addition to listing the completed processing, the operations not yet done (as specified by the \fBccdproc\fR parameters) are also listed. The image name only format is intended to be used to generate lists of images of the same CCD image type. These lists may be used as "@" file lists in IRAF tasks. .ih EXAMPLES 1. To list the default format for all images: .nf cl> ccdlist *.imh ccd001.imh[544,512][short][unknown][][V]:FOCUS L98-193 ccd007.imh[544,512][short][object][][V]:N2968 V 600s ccd015.imh[544,512][short][object][][B]:N3098 B 500s ccd024.imh[544,512][short][object][][R]:N4036 R 600s ccd045.imh[544,512][short][flat][][V]:dflat 6v+blue 5s ccd066.imh[544,512][short][flat][][B]:dflat 6v+blue 5s ccd103.imh[544,512][short][flat][][R]:dflat 6v+blue 5s ccd104.imh[544,512][short][zero][][]:bias ccd105.imh[544,512][short][dark][][]:dark 3600s .fi These images have not been processed. 2. To restrict the listing to just the object images: .nf cl> ccdlist *.imh ccdtype=object ccd007.imh[544,512][short][object][][V]:N2968 V 600s ccd015.imh[544,512][short][object][][B]:N3098 B 500s ccd024.imh[544,512][short][object][][R]:N4036 R 600s .fi 3. The long list for image "ccd007" is obtained by: .nf cl> ccdlist ccd007 l+ ccd007[544,512][short][object][][V]:N2968 R 600s exptime = 200. darktime = 200. [TO BE DONE] Overscan strip is [520:540,*] [TO BE DONE] Trim image section is [3:510,3:510] [TO BE DONE] Flat field correction .fi 4. After processing the images have the short listing: .nf cl> ccdlist *.imh ccdtype=object ccd007.imh[508,508][real][object][][V][OTF]:N2968 V 600s ccd015.imh[508,508][real][object][][B][OTF]:N3098 B 500s ccd024.imh[544,512][short][object][][R][OTF]:N4036 R 600s .fi The processing indicated is overscan subtraction, trimming, and flat fielding. 5. The long listing for "ccd007" after processing is: .nf cl> ccdlist ccd007 l+ ccd007[508,508][real][object][][V][OTF]:N2968 R 600s exptime = 200. darktime = 200. Jun 2 18:18 Overscan section is [520:540,*] with mean=481.8784 Jun 2 18:18 Trim data section is [3:510,3:510] Jun 2 18:19 Flat field image is FlatV.imh with scale=138.2713 .fi 6. To make a list file containing all the flat field images: cl> ccdlist *.imh ccdtype=flat name+ > flats This file can be used as an @ file for processing. .ih REVISIONS .ls CCDLIST V2.11 Added amplifier field in listing. .le .ih SEE ALSO ccdtypes ccdgroups .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdmask.hlp000066400000000000000000000135441332166314300206670ustar00rootroot00000000000000.help ccdmask Jun96 noao.imred.ccdred .ih NAME ccdmask -- create a pixel mask from a CCD image .ih USAGE .nf ccdmask image mask .fi .ih PARAMETERS .ls image CCD image to use in defining bad pixels. Typically this is a flat field image or, even better, the ratio of two flat field images of different exposure levels. .le .ls mask Pixel mask name to be created. A pixel list image, .pl extension, is created so no extension is necessary. .le .ls ncmed = 7, nlmed = 7 The column and line size of a moving median rectangle used to estimate the uncontaminated local signal. The column median size should be at least 3 pixels to span single bad columns. .le .ls ncsig = 15, nlsig = 15 The column and line size of regions used to estimate the uncontaminated local sigma using a percentile. The size of the box should contain of order 100 pixels or more. .le .ls lsigma = 6, hsigma = 6 Positive sigma factors to use for selecting pixels below and above the median level based on the local percentile sigma. .le .ls ngood = 5 Gaps of undetected pixels along the column direction of length less than this amount are also flagged as bad pixels. .le .ls linterp = 1 Mask code for pixels having a bounding good pixel separation which is smaller along lines; i.e. to use line interpolation along the narrower dimension. .le .ls cinterp = 2 Mask code for pixels having a bounding good pixel separation which is smaller along columns; i.e. to use columns interpolation along the narrower dimension. .le .ls eqinterp = 1 Mask code for pixels having a bounding good pixel separation which is equal along lines and columns. .le .ih DESCRIPTION \fBCcdmask\fR makes a pixel mask from pixels deviating by a specified statistical amount from the local median level. The input images may be of any type but this task was designed primarily for detecting column oriented CCD defects such as charge traps that cause bad columns and non-linear sensitivities. The ideal input is a ratio of two flat fields having different exposure levels so that all features which would normally flat field properly are removed and only pixels which are not corrected by flat fielding are found to make the pixel mask. A single flat field may also be used but pixels of low or high sensitivity may be included as well as true bad pixels. The input image is first subtracted by a moving box median. The median is unaffected by bad pixels provided the median size is larger that twice the size of a bad region. Thus, if 3 pixel wide bad columns are present then the column median box size should be at least 7 pixels. The median box can be a single pixel wide along one dimension if needed. This may be appropriate for spectroscopic long slit data. The median subtracted image is then divided into blocks of size \fInclsig\fR by \fInlsig\fR. In each block the pixel values are sorted and the pixels nearest the 30.9 and 69.1 percentile points are found; this would be the one sigma points in a Gaussian noise distribution. The difference between the two count levels divided by two is then the local sigma estimate. This algorithm is used to avoid contamination by the bad pixel values. The block size must be at least 10 pixels in each dimension to provide sufficient pixels for a good estimate of the percentile sigma. The sigma uncertainty estimate of each pixel in the image is then the sigma from the nearest block. The deviant pixels are found by comparing the median subtracted residual to a specified sigma threshold factor times the local sigma above and below zero (the \fIlsigma\fR and \fIhsigma\fR parameters). This is done for individual pixels and then for column sums of pixels (excluding previously flagged bad pixels) from two to the number of lines in the image. The sigma of the sums is scaled by the square root of the number of pixels summed so that statistically low or high column regions may be detected even though individual pixels may not be statistically deviant. For the purpose of this task one would normally select large sigma threshold factors such as six or greater to detect only true bad pixels and not the extremes of the noise distribution. As a final step each column is examined to see if there are small segments of unflagged pixels between bad pixels. If the length of a segment is less than that given by the \fIngood\fR parameter all the pixels in the segment are also marked as bad. The bad pixel mask is created with good pixels identified by zero values and the bad pixels by non-zero values. The nearest good pixels along the columns and lines for each bad pixel are located and the separation along the columns and lines between those pixels is computed. The smaller separation is used to select the mask value. If the smaller separation is along lines the \fIlinterp\fR value is set, if the smaller separation is along columns the \fIcinterp\fR value is set, and if the two are equal the \fIeqinterp\fR value is set. The purpose of this is to allow interpolating across bad pixels using the narrowest dimension. The task \fBfixpix\fR can select the type of pixel replacement to use for each mask value. So one can chose, for example, line interpolation for the linterp values and the eqinterp values, and column interpolation for the cinterp values. In addition to this task, pixel mask images may be made in a variety of ways. Any task which produces and modifies image values may be used. Some useful tasks are \fBimexpr, imreplace, imcopy, text2mask\fR and \fBmkpattern\fR. If a new image is specified with an explicit ".pl" extension then the pixel mask format is produced. .ih EXAMPLES 1. Two flat fields of exposures 1 second and 3 seconds are taken, overscan and zero corrected, and trimmed. These are then used to generate a CCD mask. .nf cl> imarith flat1 / flat2 ratio cl> ccdmask ratio mask .fi .ih REVISIONS .ls CCDMASK V2.11 This task is new. .le .ih SEE ALSO imreplace, imexpr, imcopy, imedit, fixpix, text2mask .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdproc.hlp000066400000000000000000001176041332166314300207010ustar00rootroot00000000000000.help ccdproc Aug96 noao.imred.ccdred .ih NAME ccdproc -- Process CCD images .ih USAGE ccdproc images .ih PARAMETERS .ls images List of input CCD images to process. The list may include processed images and calibration images. .le .ls ccdtype = "" CCD image type to select from the input image list. If no type is given then all input images will be selected. The recognized types are described in \fBccdtypes\fR. .le .ls max_cache = 0 Maximum image caching memory (in Mbytes). If there is sufficient memory the calibration images, such as zero level, dark count, and flat fields, will be cached in memory when processing many input images. This reduces the disk I/O and makes the task run a little faster. If the value is zero image caching is not used. .le .ls noproc = no List processing steps only? .le .ce PROCESSING SWITCHES .ls overscan = yes Apply overscan or prescan bias correction? If yes then the overscan image section and the readout axis must be specified. .le .ls trim = yes Trim the image of the overscan region and bad edge lines and columns? If yes then the data section must be specified. .le .ls fixpix = yes Apply bad pixel mask correction? If yes a bad pixel mask must be specified. .le .ls zerocor = yes Apply zero level correction? If yes a zero level image must be specified. .le .ls darkcor = yes Apply dark count correction? If yes a dark count image must be specified. .le .ls flatcor = yes Apply flat field correction? If yes flat field images must be specified. .le .ls illumcor = no Apply illumination correction? If yes illumination images must be specified. .le .ls fringecor = no Apply fringe correction? If yes fringe images must be specified. .le .ls readcor = no Convert zero level images to readout correction images? If yes then zero level images are averaged across the readout axis to form one dimensional zero level readout correction images. .le .ls scancor = no Convert zero level, dark count and flat field images to scan mode flat field images? If yes then the form of scan mode correction is specified by the parameter \fIscantype\fR. .le .ce PROCESSING PARAMETERS .ls readaxis = "line" Read out axis specified as "line" or "column". .le .ls biassec Overscan bias strip image section. An arbitrary header keyword containing the value of the bias section may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file and the default value mechanism of the translation file may be used. The old special value "image" is still allowed and is equivalant to "!biassec". Only the part of the bias section along the readout axis is used. The length of the bias region fit is defined by the trim section. If one wants to limit the region of the overscan used in the fit to be less than that of the trim section then the sample region parameter, \fIsample\fR, should be used. It is an error if no section or the whole image is specified. .le .ls trimsec Image section for trimming. An arbitrary header keyword containing the value of the trim section may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file and the default value mechanism of the translation file may be used. The old special value "image" is still allowed and is equivalant to "!trimsec". .le .ls fixfile = "" List of bad pixel masks. These may be pixel list (.pl) masks, images, or a text file description. If "BPM" is specified then the mask is specified in the image header under the keyword "BPM". An arbitrary image header keyword containing the name of the mask may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file. .le .ls zero = "" Zero level calibration images. The zero level image may be one or two dimensional. The CCD image type and subset are not checked for these images and they take precedence over any zero level calibration images given in the input list. The zero level image with the same amplifier identification as the input image being processed is selected. An arbitrary image header keyword containing the name of the image may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file. .le .ls dark = "" Dark count calibration images. The CCD image type and subset are not checked for these images and they take precedence over any dark count calibration images given in the input list. The dark count image with the same amplifier identification as the input image being processed is selected. An arbitrary image header keyword containing the name of the image may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file. .le .ls flat = "" Flat field calibration images. The flat field images may be one or two dimensional. The CCD image type is not checked for these images and they take precedence over any flat field calibration images given in the input list. The flat field image with the same amplifier identification and subset as the input image being processed is selected. An arbitrary image header keyword containing the name of the image may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file. .le .ls illum = "" Illumination correction images. The CCD image type is not checked for these images and they take precedence over any illumination correction images given in the input list. The illumination image with the same amplifier identification and subset as the input image being processed is selected. An arbitrary image header keyword containing the name of the image may be selected by giving the name of the keyword prefixed with '!'; i.e. !. The keyword may be translated to another keyword with the header translation file. .le .ls fringe = "" Fringe correction images. The CCD image type is not checked for these images and they take precedence over any fringe correction images given in the input list. The fringe image with the same amplifier identification and subset as the input image being processed is selected. An arbitrary image header keyword containing the name of the image may be selected by giving the name of the keyword prefixed with '!'; i.e. !. .le .ls minreplace = 1. When processing flat fields, pixel values below this value (after all other processing such as overscan, zero, and dark corrections) are replaced by this value. This allows flat fields processed by \fBccdproc\fR to be certain to avoid divide by zero problems when applied to object images. .le .ls scantype = "shortscan" Type of scan format used in creating the CCD images. The modes are: .ls "shortscan" The CCD is scanned over a number of lines and then read out as a regular two dimensional image. In this mode unscanned zero level, dark count and flat fields are numerically scanned to form scanned flat fields comparable to the observations. .le .ls "longscan" In this mode the CCD is clocked and read out continuously to form a long strip. Flat fields are averaged across the readout axis to form a one dimensional flat field readout correction image. This assumes that all recorded image lines are clocked over the entire active area of the CCD. .le .le .ls nscan Number of object scan readout lines used in short scan mode. This parameter is used when the scan type is "shortscan" and the number of scan lines cannot be determined from the object image header (using the keyword nscanrows or it's translation). .le .ce OVERSCAN FITTING PARAMETERS .ls interactive = no Fit the overscan vector interactively? If yes the overscan vector is fit interactively using the \fBicfit\fR package. If no then the fitting parameters given below are used. .le .ls function = "legendre" Overscan fitting function. The function types are "legendre" polynomial, "chebyshev" polynomial, "spline1" linear spline, and "spline3" cubic spline. .le .ls order = 1 Number of polynomial terms or spline pieces in the overscan fit. .le .ls sample = "*" Sample points to use in the overscan fit. The string "*" specified all points otherwise an \fBicfit\fR range string is used. .le .ls naverage = 1 Number of points to average or median to form fitting points. Positive numbers specify averages and negative numbers specify medians. .le .ls niterate = 1 Number of rejection interations to remove deviant points from the overscan fit. If 0 then no points are rejected. .le .ls low_reject = 3., high_reject = 3. Low and high sigma rejection factors for rejecting deviant points from the overscan fit. .le .ls grow = 0. One dimensional growing radius for rejection of neighbors to deviant points. .le .ih DESCRIPTION \fBCcdproc\fR processes CCD images to correct and calibrate for detector defects, readout bias, zero level bias, dark counts, response, illumination, and fringing. It also trims unwanted lines and columns and changes the pixel datatype. It is efficient and easy to use; all one has to do is set the parameters and then begin processing the images. The task takes care of most of the record keeping and automatically does the prerequisite processing of calibration images. Beneath this simplicity there is much that is going on. In this section a simple description of the usage is given. The following sections present more detailed discussions on the different operations performed and the order and logic of the processing steps. For a user's guide to the \fBccdred\fR package see \fBguide\fR. Much of the ease of use derives from using information in the image header. If this information is missing see section 13. One begins by setting the task parameters. There are many parameters but they may be easily reviewed and modified using the task \fBeparam\fR. The input CCD images to be processed are given as an image list. Previously processed images are ignored and calibration images are recognized, provided the CCD image types are in the image header (see \fBinstruments\fR and \fBccdtypes\fR). Therefore it is permissible to use simple image templates such as "*.imh". The \fIccdtype\fR parameter may be used to select only certain types of CCD images to process (see \fBccdtypes\fR). The processing operations are selected by boolean (yes/no) parameters. Because calibration images are recognized and processed appropriately, the processing operations for object images should be set. Any combination of operations may be specified and the operations are performed simultaneously. While it is possible to do operations in separate steps this is much less efficient. Two of the operation parameters apply only to zero level and flat field images. These are used for certain types of CCDs and modes of operation. The processing steps selected have related parameters which must be set. These are things like image sections defining the overscan and trim regions and calibration images. There are a number of parameters used for fitting the overscan or prescan bias section. These are parameters used by the standard IRAF curve fitting package \fBicfit\fR. The parameters are described in more detail in the following sections. In addition to the task parameters there are package parameters which affect \fBccdproc\fR. These include the instrument, amplifier and subset files, the text and plot log files, the output pixel datatype, the amount of memory available for calibration image caching, the verbose parameter for logging to the terminal, and the backup prefix. These are described in \fBccdred\fR. Calibration images are specified by task parameters and/or in the input image list. If more than one calibration image is specified then the first one encountered is used and a warning is issued for the extra images. Calibration images specified by task parameters take precedence over calibration images in the input list. These images also need not have a CCD image type parameter since the task parameter identifies the type of calibration image. This method is best if there is only one calibration image for all images to be processed. This is almost always true for zero level and dark count images. If no calibration image is specified by task parameter then calibration images in the input image list are identified and used. This requires that the images have CCD image types recognized by the package. This method is useful if one may simply say "*.imh" as the image list to process all images or if the images are broken up into groups, in "@" files for example, each with their own calibration frames. It is also possibly to specify calibration images defined in the image header of the images to be processed. This is done with the special syntax ! where is the name of the image header keyword whose value is the calibration image name. Note that if you want to use a calibration image defined in the header if there one but default to another image if there isn't one then a list such as "!flatcal,Flat" may be used. When an input image is processed the task first determines the processing parameters and calibration images. If a requested operation has been done it is skipped and if all requested operations have been completed then no processing takes place. When it determines that a calibration image is required it checks for the image from the task parameter and then for a calibration image of the proper type in the input list. Having selected a calibration image it checks if it has been processed by looking for the image header flag CCDPROC. If it is not present then the calibration image is processed. When any image has been processed the CCDPROC flag is added. For images processed directly by \fBccdproc\fR the individual processing flags are checked even if the CCDPROC flag is present. However, the automatic processing of the calibration images is only done if the CCDPROC flag is absent! This is to make the task more efficient by not having to check every flag for every calibration image for every input image. Thus, if additional processing steps are added after images have been partially reduced then input images will be processed for the new steps but calibration images will not be processed automatically. After the calibration images have been identified, and processed if necessary, the images may be cached in memory. This is done when there are more than two input images (it is actually less efficient to cache the calibration images for one or two input images) and the parameter \fImax_cache\fR is greater than zero. When caching, as many calibration images as allowed by the specified memory are read into memory and kept there for all the input images. Cached images are, therefore, only read once from disk which reduces the amount of disk I/O. This makes a modest decrease in the execution time. It is not dramatic because the actual processing is fairly CPU intensive. Once the processing parameters and calibration images have been determined the input image is processed for all the desired operations in one step; i.e. there are no intermediate results or images. This makes the task efficient. The corrected image is output as a temporary image until the entire image has been processed. When the image has been completely processed then the original image is deleted (or renamed using the specified backup prefix) and the corrected image replaces the original image. Using a temporary image protects the data in the event of an abort or computer failure. Keeping the original image name eliminates much of the record keeping and the need to generate new image names. .sh 1. Overscan If an overscan or prescan correction is specified (\fIoverscan\fR parameter) then the image section (\fIbiassec\fR parameter) is averaged along the readout axis (\fIreadaxis\fR parameter) to form a correction vector. A function is fit to this vector and for each readout line (image line or column) the function value for that line is subtracted from the image line. The fitting function is generally either a constant (polynomial of 1 term) or a high order function which fits the large scale shape of the overscan vector. Bad pixel rejection is also used to eliminate cosmic ray events. The function fitting may be done interactively using the standard \fBicfit\fR iteractive graphical curve fitting tool. Regardless of whether the fit is done interactively, the overscan vector and the fit may be recorded for later review in a metacode plot file named by the parameter \fIccdred.plotfile\fR. The mean value of the bias function is also recorded in the image header and log file. .sh 2. Trim When the parameter \fItrim\fR is set the input image will be trimmed to the image section given by the parameter \fItrimsec\fR. This trim should, of course, be the same as that used for the calibration images. .sh 3. Fixpix Regions of bad lines and columns may be replaced by linear interpolation from neighboring lines and columns when the parameter \fIfixpix\fR is set. This algorithm is the same as used in the task \fBfixpix\fR. The bad regions are specified by bad pixel masks. Several types of masks are allowed. A pixel list (.pl) format file consists of zero for good pixels and positive non-zero for bad pixels. A regular image file may also be used. It will be treated as an integer image (i.e. real values will be truncated) and zero values denote good pixels and positive non-zero values denote bad pixels. The final format is a text file specifying individual pixels or rectangular regions. Each line of the file has either two values, a column and line for a single pixel, or four values, a starting and ending column and a starting and ending line. A region may have the starting and ending values be the same to specify a pixel, line, or column. The bad pixel masks may be specified explicitly by the parameter \fIfixfile\fR or indirectly if the parameter has the value "BPM". In the latter case the keyword "BPM" will be used to define the bad pixel mask. As with other calibration images the bad pixel mask must have the same amplifier identification as the image being processed. .sh 4. Zerocor After the readout bias is subtracted, as defined by the overscan or prescan region, there may still be a zero level bias. This level may be two dimensional or one dimensional (the same for every readout line). A zero level calibration is obtained by taking zero length exposures; generally many are taken and combined. To apply this zero level calibration the parameter \fIzerocor\fR is set. In addition if the zero level bias is only readout dependent then the parameter \fIreadcor\fR is set to reduce two dimensional zero level images to one dimensional images. The zero level images may be specified by the parameter \fIzero\fR or given in the input image list (provided the CCD image type is defined). If there are multiple amplifiers used the matching amplifier from the zero images is automatically selected by an amplifier parameter (see \fBsubsets\fR). When the zero level image is needed to correct an input image it is checked to see if it has been processed and, if not, it is processed automatically. Processing of zero level images consists of bad pixel replacement, overscan correction, trimming, and averaging to one dimension if the readout correction is specified. .sh 5. Darkcor Dark counts are subtracted by scaling a dark count calibration image to the same exposure time as the input image and subtracting. The exposure time used is the dark time which may be different than the actual integration or exposure time. A dark count calibration image is obtained by taking a very long exposure with the shutter closed; i.e. an exposure with no light reaching the detector. The dark count correction is selected with the parameter \fIdarkcor\fR and the dark count calibration image is specified either with the parameter \fIdark\fR or as one of the input images. The dark count image is automatically processed as needed. Processing of dark count images consists of bad pixel replacement, overscan and zero level correction, and trimming. If there are multiple amplifiers used the matching amplifier from the dark images is automatically selected by an amplifier parameter (see \fBsubsets\fR). .sh 6. Flatcor The relative detector pixel response is calibrated by dividing by a scaled flat field calibration image. A flat field image is obtained by exposure to a spatially uniform source of light such as an lamp or twilight sky. Flat field images may be corrected for the spectral signature in spectroscopic images (see \fBresponse\fR and \fBapnormalize\fR), or for illumination effects (see \fBmkillumflat\fR or \fBmkskyflat\fR). For more on flat fields and illumination corrections see \fBflatfields\fR. The flat field response is dependent on the wavelength of light so if different filters or spectroscopic wavelength coverage are used a flat field calibration for each one is required. The different flat fields are automatically selected by an amplifier and subset parameter (see \fBsubsets\fR). Flat field calibration is selected with the parameter \fBflatcor\fR and the flat field images are specified with the parameter \fBflat\fR or as part of the input image list. The appropriate subset is automatically selected for each input image processed. The flat field image is automatically processed as needed. Processing consists of bad pixel replacement, overscan subtraction, zero level subtraction, dark count subtraction, and trimming. Also if a scan mode is used and the parameter \fIscancor\fR is specified then a scan mode correction is applied (see below). The processing also computes the mean of the flat field image which is used later to scale the flat field before division into the input image. For scan mode flat fields the ramp part is included in computing the mean which will affect the level of images processed with this flat field. Note that there is no check for division by zero in the interest of efficiency. If division by zero does occur a fatal error will occur. The flat field can be fixed by replacing small values using a task such as \fBimreplace\fR or during processing using the \fIminreplace\fR parameter. Note that the \fIminreplace\fR parameter only applies to flat fields processed by \fBccdproc\fR. .sh 7. Illumcor CCD images processed through the flat field calibration may not be completely flat (in the absence of objects). In particular, a blank sky image may still show gradients. This residual nonflatness is called the illumination pattern. It may be introduced even if the detector is uniformly illuminated by the sky because the flat field lamp illumination may be nonuniform. The illumination pattern is found from a blank sky, or even object image, by heavily smoothing and rejecting objects using sigma clipping. The illumination calibration image is divided into the data being processed to remove the illumination pattern. The illumination pattern is a function of the amplifier and subset so there must be an illumination correction image for each amplifier and subset to be processed. The tasks \fBmkillumcor\fR and \fBmkskycor\fR are used to create the illumination correction images. For more on illumination corrections see \fBflatfields\fR. An alternative to treating the illumination correction as a separate operation is to combine the flat field and illumination correction into a corrected flat field image before processing the object images. This will save some processing time but does require creating the flat field first rather than correcting the images at the same time or later. There are two methods, removing the large scale shape of the flat field and combining a blank sky image illumination with the flat field. These methods are discussed further in the tasks which create them; \fBmkillumcor\fR and \fBmkskycor\fR. .sh 8. Fringecor There may be a fringe pattern in the images due to the night sky lines. To remove this fringe pattern a blank sky image is heavily smoothed to produce an illumination image which is then subtracted from the original sky image. The residual fringe pattern is scaled to the exposure time of the image to be fringe corrected and then subtracted. Because the intensity of the night sky lines varies with time an additional scaling factor may be given in the image header. The fringe pattern is a function of the amplifier and subset so there must be a fringe correction image for each amplifier and subset to be processed. The task \fBmkfringecor\fR is used to create the fringe correction images. .sh 9. Readcor If a zero level correction is desired (\fIzerocor\fR parameter) and the parameter \fIreadcor\fR is yes then a single zero level correction vector is applied to each readout line or column. Use of a readout correction rather than a two dimensional zero level image depends on the nature of the detector or if the CCD is operated in longscan mode (see below). The readout correction is specified by a one dimensional image (\fIzero\fR parameter) and the readout axis (\fIreadaxis\fR parameter). If the zero level image is two dimensional then it is automatically processed to a one dimensional image by averaging across the readout axis. Note that this modifies the zero level calibration image. .sh 10. Scancor CCD detectors may be operated in several modes in astronomical applications. The most common is as a direct imager where each pixel integrates one point in the sky or spectrum. However, the design of most CCD's allows the sky to be scanned across the CCD while shifting the accumulating signal at the same rate. \fBCcdproc\fR provides for two scanning modes called "shortscan" and "longscan". The type of scan mode is set with the parameter \fIscanmode\fR. In "shortscan" mode the detector is scanned over a specified number of lines (not necessarily at sideral rates). The lines that scroll off the detector during the integration are thrown away. At the end of the integration the detector is read out in the same way as an unscanned observation. The advantage of this mode is that the small scale, zero level, dark count and flat field responses are averaged in one dimension over the number of lines scanned. A zero level, dark count or flat field may be observed in the same way in which case there is no difference in the processing from unscanned imaging and the parameter \fIscancor\fR may be no. If it is yes, though, checking is done to insure that the calibration image used has the same number of scan lines as the object being processed. However, one obtains an increase in the statistical accuracy of if they are not scanned during the observation but digitally scanned during the processing. In shortscan mode with \fIscancor\fR set to yes, zero level, dark count and flat field images are digitally scanned, if needed, by the same number of scan lines as the object. The number of scan lines is determined from the object image header using the keyword nscanrow (or it's translation). If not found the object is assumed to have been scanned with the value given by the \fInscan\fR parameter. Zero, dark and flat calibration images are assumed to be unscanned if the header keyword is not found. If a scanned zero level, dark count or flat field image is not found matching the object then one may be created from the unscanned calibration image. The image will have the root name of the unscanned image with an extension of the number of scan rows; i.e. Flat1.32 is created from Flat1 with a digital scanning of 32 lines. In "longscan" mode the detector is continuously read out to produce an arbitrarily long strip. Provided data which has not passed over the entire detector is thrown away, the zero level, dark count, and flat field corrections will be one dimensional. If \fIscancor\fR is specified and the scan mode is "longscan" then a one dimensional zero level, dark count, and flat field correction will be applied. .sh 11. Processing Steps The following describes the steps taken by the task. This detailed outline provides the most detailed specification of the task. .ls 5 (1) An image to be processed is first checked that it is of the specified CCD image type. If it is not the desired type then go on to the next image. .le .ls (2) A temporary output image is created of the specified pixel data type (\fBccdred.pixeltype\fR). The header parameters are copied from the input image. .le .ls (3) If trimming is specified and the image has not been trimmed previously, the trim section is determined. .le .ls (4) If bad pixel replacement is specified and this has not been done previously, the bad pixel file is determined either from the task parameter or the instrument translation file. The bad pixel regions are read. If the image has been trimmed previously and the bad pixel file contains the word "untrimmed" then the bad pixel coordinates are translated to those of the trimmed image. .le .ls (5) If an overscan correction is specified and this correction has not been applied, the overscan section is averaged along the readout axis. If trimming is to be done the overscan section is trimmed to the same limits. A function is fit either interactively or noninteractively to the overscan vector. The function is used to produce the overscan vector to be subtracted from the image. This is done in real arithmetic. .le .ls (6) If the image is a zero level image go to processing step 12. If a zero level correction is desired and this correction has not been performed, find the zero level calibration image of the appropriate amplifier. If the zero level calibration image has not been processed it is processed at this point. This is done by going to processing step 1 for this image. After the calibration image has been processed, processing of the input image continues from this point. The processed calibration image may be cached in memory if it has not been previously and if there is enough memory. .le .ls (7) If the image is a dark count image go to processing step 12. If a dark count correction is desired and this correction has not been performed, find the dark count calibration image of the appropriate amplifier. If the dark count calibration image has not been processed it is processed at this point. This is done by going to processing step 1 for this image. After the calibration image has been processed, processing of the input image continues from this point. The ratio of the input image dark time to the dark count image dark time is determined to be multiplied with each pixel of the dark count image before subtracting from the input image. The processed calibration image may be cached in memory if it has not been previously and if there is enough memory. .le .ls (8) If the image is a flat field image go to processing step 12. If a flat field correction is desired and this correction has not been performed, find the flat field calibration image of the appropriate amplifier and subset. If the flat field calibration image has not been processed it is processed at this point. This is done by going to processing step 1 for this image. After the calibration image has been processed, processing of the input image continues from this point. The mean of the image is determined from the image header to be used for scaling. If no mean is found then a unit scaling is used. The processed calibration image may be cached in memory if it has not been previously and if there is enough memory. .le .ls (9) If the image is an illumination image go to processing step 12. If an illumination correction is desired and this correction has not been performed, find the illumination calibration image of the appropriate amplifier and subset. The illumination image must have the "mkillum" processing flag or the \fBccdproc\fR will abort with an error. The mean of the image is determined from the image header to be used for scaling. If no mean is found then a unit scaling is used. The processed calibration image may be cached in memory if it has not been previously and there is enough memory. .le .ls (10) If the image is a fringe image go to processing step 12. If a fringe correction is desired and this correction has not been performed, find the fringe calibration image of the appropriate amplifier and subset. The illumination image must have the "mkfringe" processing flag or the \fBccdproc\fR will abort with an error. The ratio of the input image exposure time to the fringe image exposure time is determined. If there is a fringe scaling in the image header then this factor is multiplied by the exposure time ratio. This factor is used for scaling. The processed calibration image may be cached in memory if it has not been previously and there is enough memory. .le .ls (11) If there are no processing operations flagged, delete the temporary output image, which has been opened but not used, and go to 14. .le .ls (12) The input image is processed line by line with trimmed lines ignored. A line of the input image is read. Bad pixel replacement and trimming is applied to the image. Image lines from the calibration images are read from disk or the image cache. If the calibration is one dimensional (such as a readout zero level correction or a longscan flat field correction) then the image vector is read only once. Note that IRAF image I/O is buffered for efficiency and accessing a line at a time does not mean that image lines are read from disk a line at a time. Given the input line, the calibration images, the overscan vector, and the various scale factors a special data path for each combination of corrections is used to perform all the processing in the most efficient manner. If the image is a flat field any pixels less than the \fIminreplace\fR parameter are replaced by that minimum value. Also a mean is computed for the flat field and stored as the CCDMEAN keyword and the time, in a internal format, when this value was calculated is stored in the CCDMEANT keyword. The time is checked against the image modify time to determine if the value is valid or needs to be recomputed. .le .ls (13) The input image is deleted or renamed to a backup image. The temporary output image is renamed to the input image name. .le .ls (14) If the image is a zero level image and the readout correction is specified then it is averaged to a one dimensional readout correction. .le .ls (15) If the image is a zero level, dark count, or flat field image and the scan mode correction is specified then the correction is applied. For shortscan mode a modified two dimensional image is produced while for longscan mode a one dimensional average image is produced. .le .ls (16) The processing is completed and either the next input image is processed beginning at step 1 or, if it is a calibration image which is being processed for an input image, control returns to the step which initiated the calibration image processing. .le .sh 12. Processing Arithmetic The \fBccdproc\fR task has two data paths, one for real image pixel datatypes and one for short integer pixel datatype. In addition internal arithmetic is based on the rules of FORTRAN. For efficiency there is no checking for division by zero in the flat field calibration. The following rules describe the processing arithmetic and data paths. .ls (1) If the input, output, or any calibration image is of type real the real data path is used. This means all image data is converted to real on input. If all the images are of type short all input data is kept as short integers. Thus, if all the images are of the same type there is no datatype conversion on input resulting in greater image I/O efficiency. .le .ls (2) In the real data path the processing arithmetic is always real and, if the output image is of short pixel datatype, the result is truncated. .le .ls (3) The overscan vector and the scale factors for dark count, flat field, illumination, and fringe calibrations are always of type real. Therefore, in the short data path any processing which includes these operations will be coerced to real arithmetic and the result truncated at the end of the computation. .le .sh 13. In the Absence of Image Header Information The tasks in the \fBccdred\fR package are most convenient to use when the CCD image type, amplifier, subset, and exposure time are contained in the image header. The ability to redefine which header parameters contain this information makes it possible to use the package at many different observatories (see \fBinstruments\fR). However, in the absence of any image header information the tasks may still be used effectively. There are two ways to proceed. One way is to use \fBccdhedit\fR to place the information in the image header. The second way is to specify the processing operations more explicitly than is needed when the header information is present. The parameter \fIccdtype\fR is set to "" or to "none". The calibration images are specified explicitly by task parameter since they cannot be recognized in the input list. Only one amplifier and subset at a time may be processed. If dark count and fringe corrections are to be applied the exposure times must be added to all the images. Alternatively, the dark count and fringe images may be scaled explicitly for each input image. This works because the exposure times default to 1 if they are not given in the image header. .ih EXAMPLES The user's \fBguide\fR presents a tutorial in the use of this task. 1. In general all that needs to be done is to set the task parameters and enter cl> ccdproc *.imh & This will run in the background and process all images which have not been processed previously. .ih TIME REQUIREMENTS .nf o SUN-3, 15 MHz 68020 with 68881 floating point hardware (no FPA) o 8 Mb RAM, 2 Fuji Eagle disks. o Input images = 544 x 512 short o Output image = 500 x 500 real o Operations are overscan subtraction (O), trimming to 500x500 (T), zero level subtraction (Z), dark count scaling and subtraction (D), and flat field scaling and subtraction (F). o UNIX statistics (user, system, and clock time, and misc. memory and i/o statistics): [OTF] One calibration image and 9 object images: No caching: 110.6u 25.5s 3:18 68% 28+ 40K 3093+1645io 9pf+0w Caching: 111.2u 23.0s 2:59 74% 28+105K 2043+1618io 9pf+0w [OTZF] Two calibration images and 9 object images: No caching: 119.2u 29.0s 3:45 65% 28+ 50K 4310+1660io 9pf+0w Caching: 119.3u 23.0s 3:07 75% 28+124K 2179+1601io 9pf+0w [OTZDF] Three calibration images and 9 object images: No caching: 149.4u 31.6s 4:41 64% 28+ 59K 5501+1680io 19pf+0w Caching: 151.5u 29.0s 4:14 70% 27+227K 2346+1637io 148pf+0w [OTZF] 2 calibration images and 20 images processed: No caching: 272.7u 63.8u 8:47 63% 28+ 50K 9598+3713io 12pf+0w Caching: 271.2u 50.9s 7:00 76% 28+173K 4487+3613io 51pf+0w .fi .ih REVISIONS .ls CCDPROC V2.11 The data is now grouped by amplifier. This is analogous to the subset grouping except it applies to all calibration types. Bad pixel fixing can now be done with bad pixel masks in addition to the old text file description. The biassec, trimsec, and calibration images may be given as ! to use an image name given by the specified image header keyword. .le .ls CCDPROC: V2.10.3 The output pixel datatypes (specified by the package parameter \fIpixeltype\R have been extended to include unsigned short integers. Also it was previously possible to have the output pixel datatype be of lower precision than the input. Now the output pixel datatype is not allowed to lose precision; i.e. a real input image may not be processed to a short datatype. For short scan data the task now looks for the number of scan lines in the image header. Also when a calibration image is software scanned a new image is created. This allows processing objects with different numbers of scan lines and preserving the unscanned calibration image. It is an error if no biassec is specified rather than defaulting to the whole image. The time, in a internal format, when the CCDMEAN value is calculated is stored in the CCDMEANT keyword. The time is checked against the image modify time to determine if the value is valid or needs to be recomputed. .le .ih SEE ALSO .nf instruments, ccdtypes, flatfields, icfit, ccdred, guide, mkillumcor, mkskycor, mkfringecor .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdred.hlp000066400000000000000000000114761332166314300205100ustar00rootroot00000000000000.help package Aug96 noao.imred .ih NAME ccdred -- CCD image reduction package .ih USAGE ccdred .ih PARAMETERS .ls pixeltype = "real real" Output pixel datatype and calculation datatype. When images are processed or created the output pixel datatype is determined by this parameter if the specified datatype is of equal or higher precision otherwise the input image datatype is preserved. For example if the output datatype is specified as "input" then input images which are "short" or "ushort" will be output as integer but any real datatype input images will remain real. The allowed types and order of precision are "short", "ushort", "int", "long", "real", or "double", for short signed integer, short unsigned integer, integer, long integers, and real or double floating point. Note that if short input images are processed into real images the disk space required will generally increase. The calculation datatypes may only be short and real with a default of real if none is specified. .le .ls verbose = no Print log information to the standard output? .le .ls logfile = "logfile" Text log file. If no filename is specified then no log file is kept. .le .ls plotfile = "" Log metacode plot file for the overscan bias vector fits. If no filename is specified then no metacode plot file is kept. .le .ls backup = "" Backup prefix for backup images. If no prefix is specified then no backup images are kept when processing. If specified then the the backup image has the specified prefix. .le .ls instrument = "" CCD instrument translation file. This is usually set with \fBsetinstrument\fR. .le .ls ampfile = "amps" Subset translation file used to define the amplifier identifier. See \fBsubsets\fR for more. .le .ls ssfile = "subsets" Subset translation file used to define the subset identifier. See \fBsubsets\fR for more. .le .ls graphics = "stdgraph" Interactive graphics output device when fitting the overscan bias vector. .le .ls cursor = "" Graphics cursor input. The default is the standard graphics cursor. .le .ls version = "June 1987" Package version. .le .ih DESCRIPTION The CCD reduction package is loaded when this command is entered. The package contains parameters which affect the operation of the tasks it defines. When images are processed or new image are created the output pixel datatype is that specified by the parameter \fBpixeltype\fR. Note that CCD processing replaces the original image by the processed image so the pixel type of the CCD images may change during processing. The output pixel type is not allowed to change to a lower precision but it is common for input short images to be processed to real images. Processing images from short to real pixel datatypes will generally increase the amount of disk space required (a factor of 2 on most computers). The tasks produce log output which may be printed on the standard output (the terminal unless redirected) and appended to a file. The parameter \fIverbose\fR determines whether processing information is printed. This may be desirable initially, but when using background jobs the verbose output should be turned off. The user may look at the end of the log file (for example with \fBtail\fR) to determine the status of the processing. The package was designed to work with data from many different observatories and instruments. In order to accomplish this an instrument translation file is used to define a mapping between the package parameters and the particular image header format. The instrument translation file is specified to the package by the parameter \fIinstrument\fR. This parameter is generally set by the task \fBsetinstrument\fR. Two other files used are an amplifier file and a subset file. This is generally created and maintained by the package and the user need not do anything. For more sophisticated users see \fBinstruments\fR and \fBsubsets\fR. The package has very little graphics output. The exception is the overscan bias subtraction. The bias vector is logged in the metacode plot file if given. The plot file may be examined with the tasks in the \fBplot\fR package such as \fBgkimosaic\fR. When interactively fitting the overscan vector the graphics input and output devices must be specified. The defaults should apply in most cases. Because processing replaces the input image by the processed image it may be desired to save the original image. This may be done by specifying a backup prefix with the parameter \fIbackup\fR. For example, if the prefix is "orig" and the image is "ccd001", the backup image will be "origccd001". The prefix may be a directory but it must end with '/' or '$' (for logical directories). .ih REVISIONS .ls CCDRED V2.11 Grouping by amplifier is now included. A new \fIampfile\fR package parameter was added for mapping amplifier names to short identifiers. .le .ih SEE ALSO ccdproc, instruments, setinstrument, subsets .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/ccdred.ms000066400000000000000000001225631332166314300203440ustar00rootroot00000000000000.RP .TL The IRAF CCD Reduction Package -- CCDRED .AU Francisco Valdes .AI IRAF Group - Central Computer Services .K2 P.O. Box 26732, Tucson, Arizona 85726 September 1987 .AB The IRAF\(dg CCD reduction package, \fBccdred\fR, provides tools for the easy and efficient reduction of CCD images. The standard reduction operations are replacement of bad pixels, subtraction of an overscan or prescan bias, subtraction of a zero level image, subtraction of a dark count image, division by a flat field calibration image, division by an illumination correction, subtraction of a fringe image, and trimming unwanted lines or columns. Another common operation provided by the package is scaling and combining images with a number of algorithms for rejecting cosmic rays. Data in the image header is used to make the reductions largely automated and self-documenting though the package may still be used in the absence of this data. Also a translation mechanism is used to relate image header parameters to those used by the package to allow data from a variety of observatories and instruments to be processed. This paper describes the design goals for the package and the main tasks and algorithms which satisfy these goals. .PP This paper is to be published as part of the proceedings of the Santa Cruz Summer Workshop in Astronomy and Astrophysics, \fIInstrumentation for Ground-Based Optical Astronomy: Present and Future\fR, edited by Lloyd B. Robinson and published by Springer-Verlag. .LP \(dgImage Reduction and Analysis Facility (IRAF), a software system distributed by the National Optical Astronomy Observatories (NOAO). .AE .NH Introduction .PP The IRAF CCD reduction package, \fBccdred\fR, provides tools for performing the standard instrumental corrections and calibrations to CCD images. The major design goals were: .IP .nf \(bu To be easy to use \(bu To be largely automated \(bu To be image header driven if the data allows \(bu To be usable for a variety of instruments and observatories \(bu To be efficient and capable of processing large volumes of data .fi .LP This paper describes the important tasks and algorithms and shows how these design goals were met. It is not intended to describe every task, parameter, and usage in detail; the package has full documentation on each task plus a user's guide. .PP The standard CCD correction and calibration operations performed are replacement of bad columns and lines by interpolation from neighboring columns and lines, subtraction of a bias level determined from overscan or prescan columns or lines, subtraction of a zero level using a zero length exposure calibration image, subtraction of a dark count calibration image appropriately scaled to the dark time exposure of the image, division by a scaled flat field calibration image, division by an illumination image (derived from a blank sky image), subtraction of a scaled fringe image (also derived from a blank sky image), and trimming the image of unwanted lines or columns such as the overscan strip. The processing may change the pixel datatype on disk (IRAF allows seven image datatypes); usually from 16 bit integer to real format. Two special operations are also supported for scan mode and one dimensional zero level and flat field calibrations; i.e. the same calibration is applied to each CCD readout line. Any set of operations may be done simultaneously over a list of images in a highly efficient manner. The reduction operations are recorded in the image header and may also be logged on the terminal and in a log file. .PP The package also provides tools for combining multiple exposures of object and calibration images to improve the statistical accuracy of the observations and to remove transient bad pixels. The combining operation scales images of different exposure times, adjusts for variable sky background, statistically weights the images by their signal-to-noise, and provides a number of useful algorithms for detecting and rejecting transient bad pixels. .PP Other tasks are provided for listing reduction information about the images, deriving secondary calibration images (such as sky corrected flat fields or illumination correction images), and easily setting the package parameters for different instruments. .PP This paper is organized as follows. There is a section giving an overview of how the package is used to reduce CCD data. This gives the user's perspective and illustrates the general ease of use. The next section describes many of the features of the package contributing to its ease of use, automation, and generality. The next two sections describe the major tools and algorithms in some detail. This includes discussions about achieving high efficiency. Finally the status of the package and its use at NOAO is given. References to additional documentation about IRAF and the CCD reduction package and an appendix listing the individual tasks in the package are found at the end of this paper. .NH A User's Overview .PP This section provides an overview of reducing data with the IRAF CCD reduction package. There are many variations in usage depending on the type of data, whether the image headers contain information about the data which may be used by the tasks, and the scientific goal. Only a brief example is given. A more complete discussion of usage and examples is given in \fIA User's Guide to the IRAF CCDRED Package\fR. The package was developed within the IRAF system and so makes use of all the sophisticated features provided. These features are also summarized here for those not familiar with IRAF since they are an important part of using the package. .PP Since the IRAF system is widely distributed and runs on a wide variety of computers, the site of the CCD reductions might be at the telescope, a system at the observatory provided for this purpose, or at the user's home computer. The CCD images to be processed are either available immediately as the data is taken, transferred from the data taking computer via a network link (the method adopted at NOAO), or transferred to the reduction computer via a medium such as magnetic tape in FITS format. The flexibility in reduction sites and hardware is one of the virtues of the IRAF-based CCD reduction package. .PP IRAF tasks typically have a number of parameters which give the user control over most aspects of the program. This is possible since the parameters are kept in parameter files so that the user need not enter a large number of parameters every time the task is run. The user may change any of these parameters as desired in several ways, such as by explicit assignment and using an easy to learn and use, fill-in-the-value type of screen editor. The parameter values are \fIlearned\fR so that once a user sets the values they are maintained until the user changes them again; even between login sessions. .PP The first step in using the CCD reduction package is to set the default processing parameters for the data to be reduced. These parameters include a database file describing the image header keyword translations and default values, the processing operations desired (operations required vary with instrument and observer), the calibration image names, and certain special parameters for special types of observations such as scan mode. A special script task (a command procedure) is available to automatically set the default values, given the instrument name, to standard values defined by the support staff. Identifying the instrument in this way may be all the novice user need do though most people quickly learn to adjust parameters at will. .PP As an example suppose there is an instrument identified as \fLrca4m\fR for an RCA CCD at the NOAO 4 meter telescope. The user gives the command .ft L cl> setinstrument rca4m .ft R which sets the default parameters to values suggested by the support staff for this instrument. The user may then change these suggested values if desired. In this example the processing switches are set to perform overscan bias subtraction, zero level image subtraction, flat fielding, and trimming. .PP The NOAO image headers contain information identifying the type of image, such as object, zero level, and flat field, the filter used to match flat fields with object images, the location of the overscan bias data, the trim size for the data, and whether the image has been processed. With this information the user need not worry about selecting images, pairing object images with calibration images, or inadvertently reprocessing an image. .PP The first step is to combine multiple zero level and flat field observations to reduce the effects of statistical noise. This is done by the commands .nf .ft L cl> zerocombine *.imh cl> flatcombine *.imh .ft R .fi The "cl> " is the IRAF command language prompt. The first command says look through all the images and combine the zero level images. The second command says look through all the images and combine the flat field images by filter. What could be simpler? Some \fIhidden\fR (default) parameters the user may modify are the combined image name, whether to process the images first, and the type of combining algorithm to use. .PP The next step is to process the images using the combined calibration images. The command is .ft L cl> ccdproc *.imh .ft R This command says look through all the images, find the object images, find the overscan data based on the image header and subtract the bias, subtract the zero level calibration image, divide by the flat field calibration image, and trim the bias data and edge lines and columns. During this operation the task recognizes that the zero level and flat field calibration images have not been processed and automatically processes them when they are needed. The log output of this task, which may be to the terminal, to a file, or both, shows how this works. .nf .ft L ccd003: Jun 1 15:12 Trim data section is [3:510,3:510] ccd003: Jun 1 15:12 Overscan section is [520:540,*], mean=485.0 Dark: Jun 1 15:12 Trim data section is [3:510,3:510] Dark: Jun 1 15:13 Overscan section is [520:540,*], mean=484.6 ccd003: Jun 1 15:13 Dark count image is Dark.imh FlatV: Jun 1 15:13 Trim data section is [3:510,3:510] FlatV: Jun 1 15:14 Overscan section is [520:540,*], mean=486.4 ccd003: Jun 1 15:15 Flat field image is FlatV.imh, scale=138.2 ccd004: Jun 1 15:16 Trim data section is [3:510,3:510] ccd004: Jun 1 15:16 Overscan section is [520:540,*], mean=485.2 ccd004: Jun 1 15:16 Dark count image is Dark.imh ccd004: Jun 1 15:16 Flat field image is FlatV.imh, scale=138.2 \fI<... more ...>\fL ccd013: Jun 1 15:22 Trim data section is [3:510,3:510] ccd013: Jun 1 15:23 Overscan section is [520:540,*], mean=482.4 ccd013: Jun 1 15:23 Dark count image is Dark.imh FlatB: Jun 1 15:23 Trim data section is [3:510,3:510] FlatB: Jun 1 15:23 Overscan section is [520:540,*], mean=486.4 ccd013: Jun 1 15:24 Flat field image is FlatB.imh, scale=132.3 \fI<... more ...>\fL .ft R .fi .PP The log gives the name of the image and a time stamp for each entry. The first image is ccd003. It is to be trimmed to the specified size given as an \fIimage section\fR, an array notation used commonly in IRAF to specify subsections of images. The location of the overscan data is also given by an image section which, in this case, was found in the image header. The mean bias level of the overscan is also logged though the overscan is actually a function of the readout line with the order of the function selected by the user. .PP When the task comes to subtracting the zero level image it first notes that the calibration image has not been processed and switches to processing the zero level image. Since it knows it is a zero level image the task does not attempt to zero level or flat field correct this image. After the zero level image has been processed the task returns to the object image only to find that the flat field image also has not been processed. It determines that the object image was obtained with a V filter and selects the flat field image having the same filter. The flat field image is processed through the zero level correction and then the task again returns to the object image, ccd003, which it finishes processing. .PP The next image, ccd004, is also a V filter observation. Since the zero level and V filter flat field have been processed the object image is processed directly. This continues for all the object images except for a detour to process the B filter flat field when the task first encounters a B filter object image. .PP In summary, the basic usage of the CCD reduction package is quite simple. First, the instrument is identified and some parameters for the data are set. Calibration images are then combined if needed. Finally, the processing is done with the simple command .ft L cl> ccdproc *.imh& .ft R where the processing is performed as a \fIbackground job\fR in this example. This simplicity was a major goal of the package. .NH Features of the Package .PP This section describes some of the special features of the package which contribute to its ease of use, generality, and efficiency. The major criteria for ease of use are to minimize the user's record keeping involving input and output image names, the types of images, subset parameters such as filters which must be kept separate, and the state of processing of each image. The goal is to allow input images to be specified using simple wildcards, such as "*.imh" to specify all images, with the knowledge that the task will only operate on images for which it makes sense. To accomplish this the tasks must be able to determine the type of image, subset, and the state of processing from the image itself. This is done by making use of image header parameters. .PP For generality the package does not require any image header information except the exposure time. It is really not very much more difficult to reduce such data. Mainly, the user must be more explicit about specifying images and setting task parameters or add the information to the image headers. Some default header information may also be set in the image header translation file (discussed below). .PP One important image header parameter is the image type. This discriminates between object images and various types of calibration images such as flat field, zero level, dark count, comparison arcs, illumination, and fringe images. This information is used in two ways. For most of the tasks the user may select that only one type of image be considered. Thus, all the flat field images may be selected for combining or only the processing status of the object images be listed. The second usage is to allow the processing tasks to identify the standard calibration images and apply only those operations which make sense. For example, flat field images are not divided by a flat field. This allows the user to set the processing operations desired for the object images without fear of misprocessing the calibration images. The image type is also used to automatically select calibration images from a list of images to be processed instead of explicitly identifying them. .PP A related parameter specifies the subset. For certain operations the images must have a common value for this parameter. This parameter is often the filter but it may also apply to a grating or aperture, for example. The subset parameter is used to identify the appropriate flat field image to apply to an image or to select common flat fields to be combined into a higher quality flat field. This is automatic and the user need not keep track of which image was taken with which filter or grating. .PP The other important image header parameters are the processing flags. These identify when an image has been processed and also act as a history of the operation including calibration images used and other parameter information. The usage of these parameters is obvious; it allows the user to include processed images in a wildcard list knowing that the processing will not be repeated and to quickly determine the processing status of the image. .PP Use of image header parameters often ties the software to the a particular observatory. To maintain generality and usefulness for data other than that at NOAO, the CCD reduction package was designed to provide a translation between parameters requested by the package and those actually found in the image header. This translation is defined in a simple text file which maps one keyword to another and also gives a default value to be used if the image header does not include a value. In addition the translation file maps the arbitrary strings which may identify image types to the standard types which the package recognizes. This is a relatively simple scheme and does not allow for forming combinations or for interpreting values which are not simple such as embedding an exposure time as part of a string. A more complex translation scheme may prove desirable as experience is gained with other types of image header formats, but by then a general header translation ability and/or new image database structure may be a standard IRAF feature. .PP This feature has proven useful at NOAO. During the course of developing the package the data taking system was modernized by updating keywords and adding new information in the image headers, generally following the lines laid out by the \fBccdred\fR package. However, there is a period of transition and it is also desirable to reduce preexisting data. There are several different formats for this data. The header translation files make coping with these different formats relatively easy. .PP A fundamental aspect of the package is that the processing modifies the images. In other words, the reduction operations are performed directly on the image. This "feature" further simplifies record keeping, frees the user from having to form unique output image names, and minimizes the amount of disk space required. There are two safety features in this process. First, the modifications do not take effect until the operation is completed on the image. This allows the user to abort the task without leaving the image data in a partially processed state and protects data if the computer crashes. The second feature is that there is a parameter which may be set to make a backup of the input data with a particular prefix; for example "b", "orig", or "imdir$" (a logical directory prefix). This backup feature may be used when there is sufficient disk space, when learning to use the package, or just to be cautious. .PP In a similar effort to efficiently manage disk space, when combining images into a master object or calibration image, there is an option to delete the input images upon completion of the combining operation. Generally this is desirable when there are many calibration exposures, such as zero level or flat field images, which are not used after they are combined into a final calibration image. .PP The goal of generality for many instruments at different observatories inherently conflicts with the goal of ease of use. Generality requires many parameters and options. This is feasible in the CCD reduction package, as well as the other IRAF packages, because of the IRAF parameter handling mechanism. In \fBccdred\fR there still remains the problem of setting the parameters appropriately for a particular instrument, image header format, and observatory. .PP To make this convenient there is a task, \fBsetinstrument\fR, that, based on an instrument name, runs a setup script for the instrument. An example of this task was given in the previous section. The script may do any type of operation but mainly it sets default parameters. The setup scripts are generally created by the support staff for the instrument. The combination of the setup script and the instrument translation file make the package, in a sense, programmable and achieves the desired instrument/observatory generality with ease of use. .NH CCD Processing .PP This section describes in some detail how the CCD processing is performed. The task which does the basic CCD processing is call \fBccdproc\fR. From the point of view of usage the task is very simple but a great deal is required to achieve this simplicity. The approach we take in describing the task is to follow the flow of control as the task runs with digressions as appropriate. .PP The highest level of control is a loop over the input images; all the operations are performed successively on each image. It is common for IRAF tasks which operate on individual images to allow the operation to be repeated automatically over a list of input images. This is important in the \fBccdred\fR package because data sets are often large and the processing is generally the same for each image. It would be tedious to have to give the processing command for each image to be processed. If an error occurs while processing an image the error is printed as a warning and processing continues with the next image. This provides protection primarily against mistyped or nonexistent images. .PP Before the first image is processed the calibration images are identified. There are two ways to specify calibration images; explicitly via task parameters or implicitly as part of the list of images to be processed. Explicitly identifying calibration images takes precedence over calibration images in the input list. Specifying calibration images as part of the input image list requires that the image types can be determined from the image header. Using the input list provides a mechanism for breaking processing up into sets of images (possibly using files containing the image names for each set) each having their own calibration images. One can, of course, selectively specify input and calibration images, but whenever possible one would like to avoid having to specify explicit images to process since this requires record keeping by the user. .PP The first step in processing an image is to check that it is of the appropriate image type. The user may select to process images of only one type. Generally this is object images since calibration images are automatically processed as needed. Images which are not of the desired type are skipped and the next image is considered. .PP A temporary output image is created next. The output pixel datatype on disk may be changed at this point as selected by the user. For example it is common for the raw CCD images to be digitized as 16 bit integers but after calibration it is sometimes desirable to have real format pixels. If no output pixel datatype is specified the output image takes the same pixel datatype as the input image. The processing is done by operating on the input image and writing the results to a temporary output image. When the processing is complete the output image replaces the input image. This gives the effect of processing the images in place but with certain safeguards. If the computer crashes or the processing is interrupted the integrity of the input image is maintained. The reasons for chosing to process the images in this way are to avoid having to generate new image names (a tiresome record keeping process for the user), to minimize disk usage, and generally the unprocessed images are not used once they have been processed. When dealing with large volumes of data these reasons become fairly important. However, the user may specify a backup prefix for the images in which case, once the processing is completed, the original input image is renamed by appending it to the prefix (or with an added digit if a previous backup image of the same name exits) before the processed output image takes the original input name. .PP The next step is to determine the image geometry. Only a subsection of the raw image may contain the CCD data. If this region is specified by a header parameter then the processing will affect only this region. This allows calibration and other data to be part of the image. Normally, the only other data in a image is overscan or prescan data. The location of this bias data is determined from the image header or from a task parameter (which overrides the image header value). To relate calibration images of different sizes and to allow for readout of only a portion of the CCD detector, a header parameter may relate the image data coordinates to the full CCD coordinates. Application of calibration image data and identifying bad pixel regions via a bad pixel file is done in this CCD coordinate system. The final geometrical information is the region of the input image to be output after processing; an operation called trimming. This is defined by an image header parameter or a task parameter. Trimming of the image is selected by the user. Any or all of this geometry information may be absent from the image and appropriate defaults are used. .PP Each selected operation which is appropriate for the image type is then considered. If the operation has been performed previously it will not be repeated. If all selected operations have been performed then the temporary output image is deleted and the input image is left unchanged. The next image is then processed. .PP For each selected operation to be performed the pertinent data is determined. This consists of such things as the name of the calibration image, scaling factors, the overscan bias function, etc. Note that at this point only the parameters are determined, the operation is not yet performed. This is because operations are not performed sequentially but simultaneously as described below. Consider flat fielding as an example. First the input image is checked to see if it has been flat fielded. Then the flat field calibration image is determined. The flat field image is checked to see if it has been processed. If it has not been processed then it is processed by calling a procedure which is essentially a copy of the main processing program. After the flat field image has been processed, parameters affecting the processing, such as the flat field scale factor (essentially the mean of the flat field image), are determined. A log of the operation is then printed if desired. .PP Once all the processing operations and parameters have been defined the actual processing begins. One of the key design goals was that the processing be efficient. There are two primary methods used to achieve this goal; separate processing paths for 16 bit integer data and floating point data and simultaneous operations. If the image, the calibration images, and the output image (as selected by the user) are 16 bit integer pixel datatypes then the image data is read and written as integer data. This eliminates internal datatype conversions both during I/O and during computations. However, many operations include use of real factors such as the overscan bias, dark count exposure scaling, and flat field scaling which causes the computation to be done in real arithmetic before the result is stored again as an integer value. In any case there is never any loss of precision except when converting the output pixel to short integer. If any of the images are not integer then a real internal data path is used in which input and output image data are converted to real as necessary. .PP For each data path the processing proceeds line-by-line. For each line in the output image data region (ignoring pixels outside the data area and pixels which are trimmed) the appropriate input data and calibration data are obtained. The calibration data is determined from the CCD coordinates of the output image and are not necessarily from the same image line or columns. The input data is copied to the output array while applying bad pixel corrections and trimming. The line is then processed using a specially optimized procedure. This procedure applies all operations simultaneously for all combinations of operations. As an example, consider subtracting an overscan bias, subtracting a zero level, and dividing by a flat field. The basic kernel of the task, where the bulk of the CPU time is used, is .nf .ft L do i = 1, n out[i] = (out[i] - overscan - zero[i]) * flatscale / flat[i] .ft R .fi Here, \fIn\fR is the number of pixels in the line, \fIoverscan\fR is the overscan bias value for the line, \fIzero\fR is the zero level data from the zero level image, \fIflatscale\fR is the mean of the flat field image, and \fIflat\fR is the flat field data from the flat field image. Note the operations are not applied sequentially but in a single statement. This is the most efficient method and there is no need for intermediate images. .PP Though the processing is logically performed line-by-line in the program, the image I/O from the disk is not done this way. The IRAF virtual operating system image interface automatically provides multi-line buffering for maximal I/O efficiency. .PP In many image processing systems it has been standard to apply operations sequentially over an image. This requires producing intermediate images. Since this is clearly inefficient in terms of I/O it has been the practice to copy the images into main memory and operate upon them there until the final image is ready to be saved. This has led to the perception that in order to be efficient an image processing system \fImust\fR store images in memory. This is not true and the IRAF CCD reduction package illustrates this. The CCD processing does not use intermediate images and does not need to keep the entire image in main memory. Furthermore, though of lesser importance than I/O, the single statement method illustrated above is more efficient than multiple passes through the images even when the images are kept in main memory. Finally, as CCD detectors increase in size and small, fast, and cheap processors become common it is a distinct advantage to not require the large amounts of memory needed to keep entire images in memory. .PP There is one area in which use of main memory can improve performance and \fBccdproc\fR does take advantage of it if desired. The calibration images usually are the same for many input images. By specifying the maximum amount of memory available for storing images in memory the calibration images may be stored in memory up to that amount. By parameterizing the memory requirement there is no builtin dependence on large memory! .PP After processing the input image the last steps are to log the operations in the image header using processing keywords and replace the input image by the output image as described earlier. The CCD coordinates of the data are recorded in the header, even if not there previously, to allow further processing on the image after the image has been trimmed. .NH Combining Images .PP The second important tool in the CCD reduction package is a task to combine many images into a single, higher quality image. While this may also be done with more general image processing tools (the IRAF task \fBimsum\fR for example) the \fBccdred\fR tasks include special CCD dependent features such as recognizing the image types and using the image header translation file. Combining images is often done with calibration images, which are easy to obtain in number, where it is important to minimize the statistical noise so as to not affect the object images. Sometimes object images also are combined. The task is called \fBcombine\fR and there are special versions of this task called \fBzerocombine, darkcombine\fR, and \fBflatcombine\fR for the standard calibration images. .PP The task takes a list of input images to be combined. As output there is the combined image, an optional sigma image, and optional log output either to the terminal, to a log file, or both. A subset or subsets of the input images may be selected based on the image type and a subset parameter such as the filter. As with the processing task, this allows selecting images without having to explicitly list each image from a large data set. When combining based on a subset parameter there is an output image, and possibly a sigma image, for each separate subset. The output image pixel datatype may also be changed during combining; usually from 16 bit integer input to real output. The sigma image is the standard deviation of the input images about the output image. .PP Except for summing the images together, combining images may require correcting for variations between the images due to differing exposure times, sky background, extinctions, and positions. Currently, extinction corrections and registration are not included but scaling and shifting corrections are included. The scaling corrections may be done by exposure times or by computing the mode in each image. Additive shifting is also done by computing the mode in the images. The region of the image in which the mode is computed can be specified but by default the whole image is used. A scaling correction is used when the flux level or sensitivity is varying. The offset correction is used when the sky brightness is varying independently of the object brightness. If the images are not scaled then special data paths combine the images more efficiently. .PP Except for medianing and summing, the images are combined by averaging. The average may be weighted by .nf .ft L weight = (N * scale / mode) ** 2 .ft R .fi where \fIN\fR is the number of images previously combined (the task records the number of images combined in the image header), \fIscale\fR is the relative scale (applied by dividing) from the exposure time or mode, and \fImode\fR is the background mode estimate used when adding a variable offset. .PP The combining operation is the heart of the task. There are a number algorithms which may be used as well as applying statistical weights. The algorithms are used to detect and reject deviant pixels, such as cosmic rays. The choice of algorithm depends on the data, the number of images, and the importance of rejecting cosmic rays. The more complex the algorithm the more time consuming the operation. The list below summarizes the algorithms. Further algorithms may be added in time. .IP "Sum - sum the input images" .br The input images are combined by summing. Care must be taken not to exceed the range of the 16 bit integer datatype when summing if the output datatype is of this type. Summing is the only algorithm in which scaling and weighting are not used. Also no sigma image is produced. .IP "Average - average the input images" .br The input images are combined by averaging. The images may be scaled and weighted. There is no pixel rejection. A sigma image is produced if more than one image is combined. .IP "Median - median the input images" .br The input images are combined by medianing each pixel. Unless the images are at the same exposure level they should be scaled. The sigma image is based on all the input images and is only an approximation to the uncertainty in the median estimates. .IP "Minreject, maxreject, minmaxreject - reject extreme pixels" .br At each pixel the minimum, maximum, or both are excluded from the average. The images should be scaled and the average may be weighted. The sigma image requires at least two pixels after rejection of the extreme values. These are relatively fast algorithms and are a good choice if there are many images (>15). .IP "Threshold - reject pixels above and below specified thresholds" .br The input images are combined with pixels above and below specified threshold values (before scaling) excluded. The images may be scaled and the average weighted. The sigma image also has the rejected pixels excluded. .IP "Sigclip - apply a sigma clipping algorithm to each pixel" .br The input images are combined by applying a sigma clipping algorithm at each pixel. The images should be scaled. This only rejects highly deviant points and so includes more of the data than the median or minimum and maximum algorithms. It requires many images (>10-15) to work effectively. Otherwise the bad pixels bias the sigma significantly. The mean used to determine the sigmas is based on the "minmaxrej" algorithm to eliminate the effects of bad pixels on the mean. Only one iteration is performed and at most one pixel is rejected at each point in the output image. After the deviant pixels are rejected the final mean is computed from all the data. The sigma image excludes the rejected pixels. .IP "Avsigclip - apply a sigma clipping algorithm to each pixel" .br The input images are combined with a variant of the sigma clipping algorithm which works well with only a few images. The images should be scaled. For each line the mean is first estimated using the "minmaxrej" algorithm. The sigmas at each point in the line are scaled by the square root of the mean, that is a Poisson scaling of the noise is assumed. These sigmas are averaged to get a line estimate of the sigma. Then the sigma at each point in the line is estimated by multiplying the line sigma by the square root of the mean at that point. As with the sigma clipping algorithm only one iteration is performed and at most one pixel is rejected at each point. After the deviant pixels are rejected the file mean is computed from all the data. The sigma image excludes the rejected pixels. .RE .PP The "avsigclip" algorithm is the best algorithm for rejecting cosmic rays, especially with a small number of images, but it is also the most time consuming. With many images (>10-15) it might be advisable to use one of the other algorithms ("maxreject", "median", "minmaxrej") because of their greater speed. .PP This task also has several design features to make it efficient and versatile. There are separate data paths for integer data and real data; as with processing, if all input images and the output image are of the same datatype then the I/O is done with no internal conversions. With mixed datatypes the operations are done as real. Even in the integer path the operations requiring real arithmetic to preserve the accuracy of the calculation are performed in that mode. There is effectively no limit to the number of images which may be combined. Also, the task determines the amount of memory available and buffers the I/O as much as possible. This is a case where operating on images from disk rather than in memory is essential. .NH Status and Conclusion .PP The initial implementation of the IRAF \fBccdred\fR package was completed in June 1987. It has been in use at the National Optical Astronomy Observatories since April 1987. The package was not distributed with Version 2.5 of IRAF (released in August 1987) but is available as a separate installation upon request. It will be part of future releases of IRAF. .PP At NOAO the CCD reduction package is available at the telescopes as the data is obtained. This is accomplished by transferring the images from the data taking computer to a Sun workstation (Sun Microsystems, Inc.) initially via tape and later by a direct link. There are several reasons for adopting this architecture. First, the data acquisition system is well established and is dedicated to its real-time function. The second computer was phased in without disrupting the essential operation of the telescopes and if it fails data taking may continue with data being stored on tape. The role of the second computer is to provide faster and more powerful reduction and analysis capability not required in a data acquisition system. In the future it can be more easily updated to follow the state of the art in small computers. As CCD detectors get larger the higher processing speeds will be essential to keep up with the data flow. .PP By writing the reduction software in the high level, portable, IRAF system the users have the capability to process their data from the basic CCD reductions to a full analysis at the telescope. Furthermore, the same software is widely available on a variety of computers if later processing or reprocessing is desired; staff and visitors at NOAO may also reduce their data at the headquarters facilities. The use of a high level system was also essential in achieving the design goals; it would be difficult to duplicate this complex package without the rich programming environment provided by the IRAF system. .NH References .PP The following documentation is distributed by the National Optical Astronomy Observatories, Central Computer Services, P.O. Box 26732, Tucson, Arizona, 85726. A comprehensive description of the IRAF system is given in \fIThe IRAF Data Reduction and Analysis System\fR by Doug Tody (also appearing in \fIProceedings of the SPIE - Instrumentation in Astronomy VI\fR, Vol. 627, 1986). A general guide to using IRAF is \fIA User's Introduction to the IRAF Command Language\fR by Peter Shames and Doug Tody. Both these documents are also part of the IRAF documentation distributed with the system. .PP A somewhat more tutorial description of the \fBccdred\fR package is \fIA User's Guide to the IRAF CCDRED Package\fR by the author. Detailed task descriptions and supplementary documentation are given in the on-line help library and are part of the user's guide. .NH Appendix .PP The current set of tasks making up the IRAF CCD Reduction Package, \fBccdred\fR, are summarized below. .nf .ft L badpiximage - Create a bad pixel mask image from a bad pixel file ccdgroups - Group CCD images into image lists ccdhedit - CCD image header editor ccdlist - List CCD processing information ccdproc - Process CCD images combine - Combine CCD images darkcombine - Combine and process dark count images flatcombine - Combine and process flat field images mkfringecor - Make fringe correction images from sky images mkillumcor - Make flat field illumination correction images mkillumflat - Make illumination corrected flat fields mkskycor - Make sky illumination correction images mkskyflat - Make sky corrected flat field images setinstrument - Set instrument parameters zerocombine - Combine and process zero level images .fi .ft R mscred-5.05-2018.07.09/src/ccdred/doc/ccdtypes.hlp000066400000000000000000000107001332166314300210670ustar00rootroot00000000000000.help ccdtypes Aug96 noao.imred.ccdred .ih NAME ccdtypes -- Description of the CCD image types .ih CCDTYPES The following CCD image types may be specified as the value of the parameter \fIccdtype\fR: .nf "" - (the null string) all image types object - object images mask - bad pixel mask images zero - zero level images such as a bias or preflash dark - dark count images flat - flat field images illum - illumination images fringe - fringe correction images other - other image types defined in the translation file none - images without an image type parameter unknown - image types not defined in the translation file .fi .ih DESCRIPTION The \fBccdred\fR package recognizes certain standard CCD image types identified in the image header. The tasks may select images of a particular CCD image type from image lists with the parameter \fIccdtype\fR and also recognize and take special actions for calibration images. In order to make use of CCD image type information the header keyword identifying the image type must be specified in the instrument translation file. This entry has the form imagetyp keyword where keyword is the image header keyword. This allows the package to access the image type string. There must also be a translation between the image type strings and the CCD types as recognized by the package. This information consists of lines in the instrument translation file of the form header package where header is the exact string given in the image header and package is one of the types recognized by the package. The image header string can be virtually anything and if it contains blanks it must be quoted. The package image types are those given above except for the null string, "none", and "unknown". That is, these types may be specified as a CCD image type in selecting images but not as a translations of image type strings. There may be more than one image type that maps to the same package type. In particular other standard CCD image types, such as comparison spectra, multiple exposure, standard star, etc., should be mapped to object or other. There may also be more than one type of flat field, i.e. dome flat, sky flat, and lamp flat. For more on the instrument translation file see the help for \fBinstruments\fR. .ih EXAMPLES 1. The example entries in the instrument translation file are from the 1986 NOAO CCD image header format produced by the CAMERA format tape writer. .nf imagetyp data-typ 'OBJECT (0)' object 'DARK (1)' dark 'PROJECTOR FLAT (2)' flat 'SKY FLAT (3)' other 'COMPARISON LAMP (4)' other 'BIAS (5)' zero 'DOME FLAT (6)' flat .fi The image header keyword describing the image type is "data-typ". The values of the image type strings in the header contain blanks so they are quoted. Also the case of the strings is important. Note that there are two types of flat field images and two types of other images. 2. One way to check the image types is with the task \fBccdlist\fR. .nf cl> ccdlist *.imh Zero.imh[504,1][real][zero][][1][OT]:FOCUS L98-193 Flat1.imh[504,1][real][flat][][1][OTZ]:dflat 6v+blue 5s ccd002.imh[504,504][real][unknown][][1][OTZF]:FOCUS L98-193 ccd003.imh[544,512][short][object][][1]:L98-193 ccd004.imh[544,512][short][object][][1]:L98-193 ccd005.imh[544,512][short][object][][1]:L98-193 oldformat.imh[544,512][short][none][][1]:M31 V .fi The unknown type has a header image type of "MUL (8)". The old format image does not have any header type. 3. To select only images of a particular type: .nf cl> ccdlist *.imh ccdtype=object ccd003.imh[544,512][short][object][][1]:L98-193 ccd004.imh[544,512][short][object][][1]:L98-193 ccd005.imh[544,512][short][object][][1]:L98-193 cl> ccdlist *.imh ccdtype=unknown ccd002.imh[504,504][real][unknown][][1][OTZF]:FOCUS L98-193 cl> ccdlist *.imh ccdtype=none oldformat.imh[544,512][short][none][][1]:M31 V .fi 4. To process images with \fBccdproc\fR: .nf cl> ccdproc *.imh cl> ccdproc *.imh ccdtype=object .fi In the first case all the images will be processed (the default value of \fIccdtype\fR is ""). However, the task recognizes the calibration images, such as zero level and flat fields, and processes them appropriately. In the second case only object images are processed and all other images are ignored (except if needed as a calibration image). .ih REVISIONS .ls CCDTYPES V2.11 A new type "mask" has been added. .le .ih SEE ALSO instruments .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/combine.hlp000066400000000000000000001464261332166314300207040ustar00rootroot00000000000000.help combine Aug96 noao.imred.ccdred .ih NAME combine -- Combine CCD images using various algorithms .ih USAGE combine input output .ih PARAMETERS .ls input List of CCD images to combine. Images of a particular CCD image type may be selected with the parameter \fIccdtype\fR with the remaining images ignored. .le .ls output Output combined image or list of images. If the \fIproject\fR parameter is no (the typical case for CCD acquisition) then there will be one output image or, if the \fIamps\fR or \fIsubsets\fR parameter is selected, one output image per amplifier/subset. If the images consist of stacks then the \fIproject\fR option allows combining each input stack into separate output images as given by the image list. .le .ls plfile = "" (optional) Output pixel list file or list of files. If no name is given or the list ends prematurely then no file is produced. The pixel list file is a map of the number of pixels rejected or, equivalently, the total number of input images minus the number of pixels actually used. The file name is also added to the output image header under the keyword BPM. .le .ls sigma = "" (optional) Output sigma image or list of images. If no name is given or the list ends prematurely then no image is produced. The sigma is standard deviation, corrected for a finite population, of the input pixel values (excluding rejected pixels) about the output combined pixel values. .le .ls ccdtype = "" CCD image type to combine. If specified only input images of the specified type are combined. See \fBccdtypes\fR for the possible image types. .le .ls amps = yes Combine images by amplifier? If yes then the input images are grouped by the amplifier parameter and each group combined into a separate output image. The amplifier identifier is appended to the output image name(s). See \fBsubsets\fR for more on the amplifier parameter. .le .ls subsets = no Combine images by subset parameter? If yes then the input images are grouped by subset parameter and each group combined into a separate output image. The subset identifier is appended to the output image name(s). See \fBsubsets\fR for more on the subset parameter. .le .ls delete = no Delete input images after combining? Only those images combined are deleted. .le .ls combine = "average" (average|median) Type of combining operation performed on the final set of pixels (after offsetting, masking, thresholding, and rejection). The choices are "average" or "median". The median uses the average of the two central values when the number of pixels is even. .le .ls reject = "none" (none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip) Type of rejection operation performed on the pixels remaining after offsetting, masking and thresholding. The algorithms are discussed in the DESCRIPTION section. The rejection choices are: .nf none - No rejection minmax - Reject the nlow and nhigh pixels ccdclip - Reject pixels using CCD noise parameters crreject - Reject only positive pixels using CCD noise parameters sigclip - Reject pixels using a sigma clipping algorithm avsigclip - Reject pixels using an averaged sigma clipping algorithm pclip - Reject pixels using sigma based on percentiles .fi .le .ls project = no Project (combine) across the highest dimension of the input images? If no then all the input images are combined to a single output image. If yes then the highest dimension elements of each input image are combined to an output image and optional pixel list and sigma images. Each element of the highest dimension may have a separate offset but there can only be one mask image. .le .ls outtype = "real" (short|ushort|integer|long|real|double) Output image pixel datatype. The pixel datatypes are "double", "real", "long", "integer", unsigned short ("ushort") and "short" with highest precedence first. If none is specified then the highest precedence datatype of the input images is used. A mixture of short and unsigned short images has a highest precedence of integer. The datatypes may be abbreviated to a single character. .le .ls offsets = "none" (none|wcs|grid|) Integer offsets to add to each image axes. The options are: .ls "none" No offsets are applied. .le .ls "wcs" The world coordinate system (wcs) in the image is used to derive the offsets. The nearest integer offset that matches the world coordinate at the center of the first input image is used. .le .ls "grid" A uniform grid of offsets is specified by a string of the form .nf grid [n1] [s1] [n2] [s2] ... .fi where ni is the number of images in dimension i and si is the step in dimension i. For example "grid 5 100 5 100" specifies a 5x5 grid with origins offset by 100 pixels. .le .ls The offsets are given in the specified file. The file consists of one line per image with the offsets in each dimension forming the columns. .le .le .ls masktype = "none" (none|goodvalue|badvalue|goodbits|badbits) Type of pixel masking to use. If "none" then no pixel masking is done even if an image has an associated pixel mask. The other choices are to select the value in the pixel mask to be treated as good (goodvalue) or bad (badvalue) or the bits (specified as a value) to be treated as good (goodbits) or bad (badbits). The pixel mask file name comes from the image header keyword BPM. Note that when combining images by projection of the highest dimension only one pixel mask is applied to all the images. \fBAlso if the number of input images becomes too large (currently about 115 .imh or 57 .hhh images) then the images are temporarly stacked and combined by projection which also means the bad pixel mask from the first image will be used for all images.\fR .le .ls maskvalue = 0 Mask value used with the \fImasktype\fR parameter. If the mask type selects good or bad bits the value may be specified using IRAF notation for decimal, octal, or hexidecimal; i.e 12, 14b, 0cx to select bits 3 and 4. .le .ls blank = 0. Output value to be used when there are no pixels. .le .ls scale = "none" (none|mode|median|mean|exposure|@|!) Multiplicative image scaling to be applied. The choices are none, scale by the mode, median, or mean of the specified statistics section, scale by the exposure time in the image header, scale by the values in a specified file, or scale by a specified image header keyword. When specified in a file the scales must be one per line in the order of the input images. .le .ls zero = "none" (none|mode|median|mean|@|!) Additive zero level image shifts to be applied. The choices are none or shift by the mode, median, or mean of the specified statistics section, shift by values given in a file, or shift by values given by an image header keyword. When specified in a file the zero values must be one per line in the order of the input images. .le .ls weight = "none" (none|mode|median|mean|exposure|@|!) Weights to be applied during the final averaging. The choices are none, the mode, median, or mean of the specified statistics section, the exposure time, values given in a file, or values given by an image header keyword. When specified in a file the weights must be one per line in the order of the input images. .le .ls statsec = "" Section of images to use in computing image statistics for scaling and weighting. If no section is given then the entire region of the input is sampled (for efficiency the images are sampled if they are big enough). When the images are offset relative to each other one can precede the image section with one of the modifiers "input", "output", "overlap". The first interprets the section relative to the input image (which is equivalent to not specifying a modifier), the second interprets the section relative to the output image, and the last selects the common overlap and any following section is ignored. .le .ce Algorithm Parameters .ls lthreshold = INDEF, hthreshold = INDEF Low and high thresholds to be applied to the input pixels. This is done before any scaling, rejection, and combining. If INDEF the thresholds are not used. .le .ls nlow = 1, nhigh = 1 (minmax) The number of low and high pixels to be rejected by the "minmax" algorithm. These numbers are converted to fractions of the total number of input images so that if no rejections have taken place the specified number of pixels are rejected while if pixels have been rejected by masking, thresholding, or nonoverlap, then the fraction of the remaining pixels, truncated to an integer, is used. .le .ls nkeep = 1 The minimum number of pixels to retain or the maximum number to reject when using the clipping algorithms (ccdclip, crreject, sigclip, avsigclip, or pclip). When given as a positive value this is the minimum number to keep. When given as a negative value the absolute value is the maximum number to reject. If there are fewer pixels at some point due to offsetting, thresholding, or masking then if the number to keep (positive nkeep) is greater than the number of pixels no pixels will be rejected and if the number to reject is given (negative nkeep) then up to that number may be rejected. .le .ls mclip = yes (ccdclip, crreject, sigclip, avsigcliip) Use the median as the estimate for the true intensity rather than the average with high and low values excluded in the "ccdclip", "crreject", "sigclip", and "avsigclip" algorithms? The median is a better estimator in the presence of data which one wants to reject than the average. However, computing the median is slower than the average. .le .ls lsigma = 3., hsigma = 3. (ccdclip, crreject, sigclip, avsigclip, pclip) Low and high sigma clipping factors for the "ccdclip", "crreject", "sigclip", "avsigclip", and "pclip" algorithms. They multiply a "sigma" factor produced by the algorithm to select a point below and above the average or median value for rejecting pixels. The lower sigma is ignored for the "crreject" algorithm. .le .ls rdnoise = "0.", gain = "1.", snoise = "0." (ccdclip, crreject) CCD readout noise in electrons, gain in electrons/DN, and sensitivity noise as a fraction. These parameters are used with the "ccdclip" and "crreject" algorithms. The values may be either numeric or an image header keyword which contains the value. .le .ls sigscale = 0.1 (ccdclip, crreject, sigclip, avsigclip) This parameter determines when poisson corrections are made to the computation of a sigma for images with different scale factors. If all relative scales are within this value of unity and all relative zero level offsets are within this fraction of the mean then no correction is made. The idea is that if the images are all similarly though not identically scaled, the extra computations involved in making poisson corrections for variations in the sigmas can be skipped. A value of zero will apply the corrections except in the case of equal images and a large value can be used if the sigmas of pixels in the images are independent of scale and zero level. .le .ls pclip = -0.5 (pclip) Percentile clipping algorithm parameter. If greater than one in absolute value then it specifies a number of pixels above or below the median to use for computing the clipping sigma. If less than one in absolute value then it specifies the fraction of the pixels above or below the median to use. A positive value selects a point above the median and a negative value selects a point below the median. The default of -0.5 selects approximately the quartile point. See the DESCRIPTION section for further details. .le .ls grow = 0 Number of pixels to either side of a rejected pixel along image lines to also be rejected. This applies only to pixels rejected by one of the rejection algorithms and not the masked or threshold rejected pixels. .le PACKAGE PARAMETERS The package parameters are used to specify verbose and log output and the instrument and header definitions. .ih DESCRIPTION A set of CCD images are combined by weighted averaging or medianing. Pixels may be rejected from the combining by using pixel masks, threshold levels, and rejection algorithms. The images may be scaled multiplicatively or additively based on image statistics, image header keywords, or text files before rejection. The images may be combined with integer pixel coordinate offsets to produce an image bigger than any of the input images. This task is a variant of the \fBimages.imcombine\fR task specialized for CCD images. The input images to be combined are specified by a list. A subset or subsets of the input list may be selected using the parameters \fIccdtype\fR, \fIamps\fR and \fIsubsets\fR. The \fIccdtype\fR parameter selects only images of a specified standard CCD image type. The \fIamps\fR parameter breaks up the input list into sublists of common amplifier parameter (normally an amplifier but some other parameter could be used in the translation file). The \fIsubsets\fR parameter breaks up the input list into sublists of common subset parameter (filter, grating, etc.). For more information see \fBccdtypes\fR and \fBsubsets\fR. This selection process is useful with wildcard templates to combine, for example, the flat field images for each filter in one step (see \fBflatcombine\fR). When subsets of the input list are used the output image and optional pixel file and sigma image are given by root names with an amplifier and subset identifier appended by the task. If the \fBproject\fR parameter is yes then the highest dimension elements of each input image are combined to make an output image of one lower dimension. There is no limit to the number of elements combined in this case. This case is If the \fBproject\fR is no then the entire input list is combined to form a single output image per subset. In this case the images must all have the same dimensionality but they may have different sizes. There is a software limit of approximately 100 images in this case. The output image header is a copy of the first image in the combined set. In addition, the number of images combined is recorded under the keyword NCOMBINE, the exposure time is updated as the weighted average of the input exposure times, and any pixel list file created is recorded under the keyword BPM. The output pixel type is set by the parameter \fIouttype\fR. If left blank then the input datatype of highest precision is used. A mixture of short and unsigned short images has a highest precision of integer. In addition to one or more output combined images there may also be a pixel list image containing the number of pixels rejected at each point in the output image, an image containing the sigmas of the pixels combined about the final output combined pixels, and a log file. The pixel list image is in the compact pixel list format which can be used as an image in other programs. The sigma computation is the standard deviation corrected for a finite population (the n/(n-1) factor) including weights if a weighted average is used. Other input/output parameters are \fIdelete\fR and \fIclobber\fR. The \fIdelete\fR parameter may be set to "yes" to delete the input images used in producing an output image after it has been created. This is useful for minimizing disk space, particularly with large sets of calibration images needed to achieve high statistical accuracy in the final calibration image. The \fBclobber\fR parameter allows the output image names to be existing images which are overwritten (at the end of the operation). An outline of the steps taken by the program is given below and the following sections elaborate on the steps. .nf o Set the input image offsets and the final output image size. o Set the input image scales and weights o Write the log file output .fi For each output image line: .nf o Get input image lines that overlap the output image line o Reject masked pixels o Reject pixels outside the threshold limits o Reject pixels using the specified algorithm o Reject neighboring pixels along each line o Combine remaining pixels using the weighted average or median o Compute sigmas of remaining pixels about the combined values o Write the output image line, rejected pixel list, and sigmas .fi OFFSETS The images to be combined need not be of the same size or overlap. They do have to have the same dimensionality which will also be the dimensionality of the output image. Any dimensional images supported by IRAF may be used. Note that if the \fIproject\fR flag is yes then the input images are the elements of the highest dimension; for example the planes of a three dimensional image. The overlap of the images is determined by a set of integer pixel offsets with an offset for each dimension of each input image. For example offsets of 0, 10, and 20 in the first dimension of three images will result in combining the three images with only the first image in the first 10 colums, the first two images in the next 10 columns and all three images starting in the 31st column. At the 31st output column the 31st column of the first image will be combined with the 21st column of the second image and the 1st column of the third image. The output image size is set by the maximum extent in each dimension of any input image after applying the offsets. In the above example if all the images have 100 columns then the output image will have 130 columns corresponding to the 30 column offset in the third image. The input image offsets are set using the \fIoffset\fR parameter. There are four ways to specify the offsets. If the word "none" or the empty string "" are used then all offsets will be zero and all pixels with the same coordinates will be combined. The output image size will be equal to the biggest dimensions of the input images. If "wcs" offsets are specified then the world coordinate systems (wcs) in the image headers are used to derived the offsets. The world coordinate at the center of the first input image is evaluated. Then integer pixel offsets are determined for each image to bring the same world coordinate to the same point. Note the following caveats. The world coordinate systems must be of the same type, orientation, and scale and only the nearest integer shift is used. If the input images have offsets in a regular grid or one wants to make an output image in which the input images are "mosaiced" together in a grid then the special offset string beginning with the word "grid" is used. The format is .nf grid [n1] [s1] [n2] [s2] ... .fi where ni is the number of images in dimension i and si is the step in dimension i. For example "grid 5 100 5 100" specifies a 5x5 grid with origins offset by 100 pixels. Note that one must insure that the input images are specified in the correct order. This may best be accomplished using a "@" list. One useful application of the grid is to make a nonoverlapping mosaic of a number of images for display purposes. Suppose there are 16 images which are 100x100. The offset string "grid 4 101 4 101" will produce a mosaic with a one pixel border having the value set by \fIblank\fR parameter between the images. The offsets may be defined in a file by specifying the file name in the \fIoffset\fR parameter. (Note that the special file name STDIN may be used to type in the values terminated by the end-of-file character). The file consists of a line for each input image. The lines must be in the same order as the input images and so an "@" list may be useful. The lines consist of whitespace separated offsets one for each dimension of the images. In the first example cited above the offset file might contain: .nf 0 0 10 0 20 0 .fi where we assume the second dimension has zero offsets. The offsets need not have zero for one of the images. The offsets may include negative values or refer to some arbitrary common point. When the offsets are read by the program it will find the mininum value in each dimension and subtract it from all the other offsets in that dimension. The above example could also be specified as: .nf 225 15 235 15 245 15 .fi There may be cases where one doesn't want the mininum offsets reset to zero. If all the offsets are positive and the comment "# Absolute" appears in the offset file then the images will be combined with blank values between the first output pixel and the first overlapping input pixel. Continuing with the above example, the file .nf # Absolute 10 10 20 10 30 10 .fi will have the first pixel of the first image in the 11th pixel of the output image. Note that there is no way to "pad" the other side of the output image. SCALES AND WEIGHTS In order to combine images with rejection of pixels based on deviations from some average or median they must be scaled to a common level. There are two types of scaling available, a multiplicative intensity scale and an additive zero point shift. The intensity scaling is defined by the \fIscale\fR parameter and the zero point shift by the \fIzero\fR parameter. These parameters may take the values "none" for no scaling, "mode", "median", or "mean" to scale by statistics of the image pixels, "exposure" (for intensity scaling only) to scale by the exposure time keyword in the image header, any other image header keyword specified by the keyword name prefixed by the character '!', and the name of a file containing the scale factors for the input image prefixed by the character '@'. Examples of the possible parameter values are shown below where "myval" is the name of an image header keyword and "scales.dat" is a text file containing a list of scale factors. .nf scale = none No scaling zero = mean Intensity offset by the mean scale = exposure Scale by the exposure time zero = !myval Intensity offset by an image keyword scale = @scales.dat Scales specified in a file .fi The image statistics factors are computed by sampling a uniform grid of points with the smallest grid step that yields less than 10000 pixels; sampling is used to reduce the time need to compute the statistics. If one wants to restrict the sampling to a region of the image the \fIstatsec\fR parameter is used. This parameter has the following syntax: .nf [input|output|overlap] [image section] .fi The initial modifier defaults to "input" if absent. The modifiers are useful if the input images have offsets. In that case "input" specifies that the image section refers to each input image, "output" specifies that the image section refers to the output image coordinates, and "overlap" specifies the mutually overlapping region of the input images. In the latter case an image section is ignored. The statistics are as indicated by their names. In particular, the mode is a true mode using a bin size which is a fraction of the range of the pixels and is not based on a relationship between the mode, median, and mean. Also masked pixels are excluded from the computations as well as during the rejection and combining operations. The "exposure" option in the intensity scaling uses the exposure time from the image header. If one wants to use a nonexposure time image header keyword the ! syntax is available. If both an intensity scaling and zero point shift are selected the multiplicative scaling is done first. Use of both makes sense if the intensity scaling is the exposure time to correct for different exposure times and then the zero point shift allows for sky brightness changes. The image statistics and scale factors are recorded in the log file unless they are all equal, which is equivalent to no scaling. The intensity scale factors are normalized to a unit mean and the zero point shifts are adjust to a zero mean. When the factors are specified in an @file or by a keyword they are not normalized. Scaling affects not only the mean values between images but also the relative pixel uncertainties. For example scaling an image by a factor of 0.5 will reduce the effective noise sigma of the image at each pixel by the square root of 0.5. Changes in the zero point also changes the noise sigma if the image noise characteristics are Poissonian. In the various rejection algorithms based on identifying a noise sigma and clipping large deviations relative to the scaled median or mean, one may need to account for the scaling induced changes in the image noise characteristics. In those algorithms it is possible to eliminate the "sigma correction" while still using scaling. The reasons this might be desirable are 1) if the scalings are similar the corrections in computing the mean or median are important but the sigma corrections may not be important and 2) the image statistics may not be Poissonian, either inherently or because the images have been processed in some way that changes the statistics. In the first case because computing square roots and making corrections to every pixel during the iterative rejection operation may be a significant computational speed limit the parameter \fIsigscale\fR selects how dissimilar the scalings must be to require the sigma corrections. This parameter is a fractional deviation which, since the scale factors are normalized to unity, is the actual minimum deviation in the scale factors. For the zero point shifts the shifts are normalized by the mean shift before adjusting the shifts to a zero mean. To always use sigma scaling corrections the parameter is set to zero and to eliminate the correction in all cases it is set to a very large number. If the final combining operation is "average" then the images may be weighted during the averaging. The weights are specified in the same way as the scale factors. In addition the NCOMBINE keyword, if present, will be used in the weights. The weights, scaled to a unit sum, are printed in the log output. The weights are only used for the final weighted average and sigma image output. They are not used to form averages in the various rejection algorithms. For weights in the case of no scaling or only multiplicative scaling the weights are used as given or determined so that images with lower signal levels will have lower weights. However, for cases in which zero level scaling is used the weights are computed from the initial weights (the exposure time, image statistics, or input values) using the formula: .nf weight_final = weight_initial / (scale * zero) .fi where the zero values are those before adjustment to zero mean over all images. The reasoning is that if the zero level is high the sky brightness is high and so the S/N is lower and the weight should be lower. PIXEL MASKS A pixel mask is a type of IRAF file having the extension ".pl" which identifies an integer value with each pixel of the images to which it is applied. The integer values may denote regions, a weight, a good or bad flag, or some other type of integer or integer bit flag. In the common case where many values are the same this file is compacted to be small and efficient to use. It is also most compact and efficient if the majority of the pixels have a zero mask value so frequently zero is the value for good pixels. Note that these files, while not stored as a strict pixel array, may be treated as images in programs. This means they may be created by programs such as \fBmkpattern\fR, edited by \fBimedit\fR, examined by \fBimexamine\fR, operated upon by \fBimarith\fR, graphed by \fBimplot\fR, and displayed by \fBdisplay\fR. At the time of introducing this task, generic tools for creating pixel masks have yet to be written. There are two ways to create a mask in V2.10. First if a regular integer image can be created then it can be converted to pixel list format with \fBimcopy\fR: .nf cl> imcopy template plfile.pl .fi by specifically using the .pl extension on output. Other programs that can create integer images (such \fBmkpattern\fR or \fBccdred.badpiximage\fR) can create the pixel list file directly by simply using the ".pl" extension in the output image name. To use pixel masks with \fBcombine\fR one must associate a pixel mask file with an image by entering the pixel list file name in the image header under the keyword BPM (bad pixel mask). This can be done with \fBhedit\fR. Note that the same pixel mask may be associated with more than one image as might be the case if the mask represents defects in the detector used to obtain the images. If a pixel mask is associated with an image the mask is used when the \fImasktype\fR parameter is set to a value other than "none". Note that when it is set to "none" mask information is not used even if it exists for the image. The values of \fImasktype\fR which apply masks are "goodvalue", "badvalue", "goodbits", and "badbits". They are used in conjunction with the \fImaskvalue\fR parameter. When the mask type is "goodvalue" the pixels with mask values matching the specified value are included in combining and all others are rejected. Similarly, for a mask type of "badvalue" the pixels with mask values matching the specified value are rejected and all others are accepted. The bit types are useful for selecting a combination of attributes in a mask consisting of bit flags. The mask value is still an integer but is interpreted by bitwise comparison with the values in the mask file. If a mask operation is specified and an image has no mask image associated with it then the mask values are taken as all zeros. In those cases be careful that zero is an accepted value otherwise the entire image will be rejected. In the case of combining the higher dimensions of an image into a lower dimensional image, the "project" option, the same pixel mask is applied to all of the data being combined; i.e. the same 2D pixel mask is applied to every plane of a 3D image. This is because a higher dimensional image is treated as a collection of lower dimensional images having the same header and hence the same bad pixel mask. It would be tempting to use a bad pixel mask with the same dimension as the image being projected but this is not currently how the task works. When the number of input images exceeds the maximum number of open files allowed by IRAF (currently about 115 .imh or 57 .hhh images) the input images are stacked and combined with the project option. \fBThis means that the bad pixel mask from the first input image will be applied to all the images.\fR THRESHOLD REJECTION In addition to rejecting masked pixels, pixels in the unscaled input images which are below or above the thresholds given by the parameters \fIlthreshold\fR and \fIhthreshold\fR are rejected. Values of INDEF mean that no threshold value is applied. Threshold rejection may be used to exclude very bad pixel values or as an alternative way of masking images. In the latter case one can use a task like \fBimedit\fR or \fBimreplace\fR to set parts of the images to be excluded to some very low or high magic value. REJECTION ALGORITHMS The \fIreject\fR parameter selects a type of rejection operation to be applied to pixels not masked or thresholded. If no rejection operation is desired the value "none" is specified. MINMAX .in 4 A specified fraction of the highest and lowest pixels are rejected. The fraction is specified as the number of high and low pixels, the \fInhigh\fR and \fInlow\fR parameters, when data from all the input images are used. If pixels have been rejected by offseting, masking, or thresholding then a matching fraction of the remaining pixels, truncated to an integer, are used. Thus, .nf nl = n * nlow/nimages + 0.001 nh = n * nhigh/nimages + 0.001 .fi where n is the number of pixels surviving offseting, masking, and thresholding, nimages is the number of input images, nlow and nhigh are task parameters and nl and nh are the final number of low and high pixels rejected by the algorithm. The factor of 0.001 is to adjust for rounding of the ratio. As an example with 10 input images and specifying one low and two high pixels to be rejected the fractions to be rejected are nlow=0.1 and nhigh=0.2 and the number rejected as a function of n is: .nf n 0 1 2 3 4 5 6 7 8 9 10 nl 0 0 0 0 0 0 0 0 0 0 1 nh 0 0 0 0 0 1 1 1 1 1 2 .fi .in -4 CCDCLIP .in 4 If the images are obtained using a CCD with known read out noise, gain, and sensitivity noise parameters and they have been processed to preserve the relation between data values and photons or electrons then the noise characteristics of the images are well defined. In this model the sigma in data values at a pixel with true value , as approximated by the median or average with the lowest and highest value excluded, is given by: .nf sigma = ((rn / g) ** 2 + / g + (s * ) ** 2) ** 1/2 .fi where rn is the read out noise in electrons, g is the gain in electrons per data value, s is a sensitivity noise given as a fraction, and ** is the exponentiation operator. Often the sensitivity noise, due to uncertainties in the pixel sensitivities (for example from the flat field), is not known in which case a value of zero can be used. See the task \fBstsdas.wfpc.noisemodel\fR for a way to determine these vaues (though that task expresses the read out noise in data numbers and the sensitivity noise parameter as a percentage). The read out noise is specified by the \fIrdnoise\fR parameter. The value may be a numeric value to be applied to all the input images or a image header keyword containing the value for each image. Similarly, the parameter \fIgain\fR specifies the gain as either a value or image header keyword and the parameter \fIsnoise\fR specifies the sensitivity noise parameter as either a value or image header keyword. The algorithm operates on each output pixel independently. It starts by taking the median or unweighted average (excluding the minimum and maximum) of the unrejected pixels provided there are at least two input pixels. The expected sigma is computed from the CCD noise parameters and pixels more that \fIlsigma\fR times this sigma below or \fIhsigma\fR times this sigma above the median or average are rejected. The process is then iterated until no further pixels are rejected. If the average is used as the estimator of the true value then after the first round of rejections the highest and lowest values are no longer excluded. Note that it is possible to reject all pixels if the average is used and is sufficiently skewed by bad pixels such as cosmic rays. If there are different CCD noise parameters for the input images (as might occur using the image header keyword specification) then the sigmas are computed for each pixel from each image using the same estimated true value. If the images are scaled and shifted and the \fIsigscale\fR threshold is exceeded then a sigma is computed for each pixel based on the image scale parameters; i.e. the median or average is scaled to that of the original image before computing the sigma and residuals. After rejection the number of retained pixels is checked against the \fInkeep\fR parameter. If there are fewer pixels retained than specified by this parameter the pixels with the smallest residuals in absolute value are added back. If there is more than one pixel with the same absolute residual (for example the two pixels about an average or median of two will have the same residuals) they are all added back even if this means more than \fInkeep\fR pixels are retained. Note that the \fInkeep\fR parameter only applies to the pixels used by the clipping rejection algorithm and does not apply to threshold or bad pixel mask rejection. This is the best clipping algorithm to use if the CCD noise parameters are adequately known. The parameters affecting this algorithm are \fIreject\fR to select this algorithm, \fImclip\fR to select the median or average for the center of the clipping, \fInkeep\fR to limit the number of pixels rejected, the CCD noise parameters \fIrdnoise, gain\fR and \fIsnoise\fR, \fIlsigma\fR and \fIhsigma\fR to select the clipping thresholds, and \fIsigscale\fR to set the threshold for making corrections to the sigma calculation for different image scale factors. .in -4 CRREJECT .in 4 This algorithm is identical to "ccdclip" except that only pixels above the average are rejected based on the \fIhsigma\fR parameter. This is appropriate for rejecting cosmic ray events and works even with two images. .in -4 SIGCLIP .in 4 The sigma clipping algorithm computes at each output pixel the median or average excluding the high and low values and the sigma about this estimate. There must be at least three input pixels, though for this method to work well there should be at least 10 pixels. Values deviating by more than the specified sigma threshold factors are rejected. These steps are repeated, except that after the first time the average includes all values, until no further pixels are rejected or there are fewer than three pixels. After rejection the number of retained pixels is checked against the \fInkeep\fR parameter. If there are fewer pixels retained than specified by this parameter the pixels with the smallest residuals in absolute value are added back. If there is more than one pixel with the same absolute residual (for example the two pixels about an average or median of two will have the same residuals) they are all added back even if this means more than \fInkeep\fR pixels are retained. Note that the \fInkeep\fR parameter only applies to the pixels used by the clipping rejection algorithm and does not apply to threshold or bad pixel mask rejection. The parameters affecting this algorithm are \fIreject\fR to select this algorithm, \fImclip\fR to select the median or average for the center of the clipping, \fInkeep\fR to limit the number of pixels rejected, \fIlsigma\fR and \fIhsigma\fR to select the clipping thresholds, and \fIsigscale\fR to set the threshold for making corrections to the sigma calculation for different image scale factors. .in -4 AVSIGCLIP .in 4 The averaged sigma clipping algorithm assumes that the sigma about the median or mean (average excluding the low and high values) is proportional to the square root of the median or mean at each point. This is described by the equation: .nf sigma(column,line) = sqrt (gain(line) * signal(column,line)) .fi where the \fIestimated\fR signal is the mean or median (hopefully excluding any bad pixels) and the gain is the \fIestimated\fR proportionality constant having units of photons/data number. This noise model is valid for images whose values are proportional to the number of photons recorded. In effect this algorithm estimates a detector gain for each line with no read out noise component when information about the detector noise parameters are not known or available. The gain proportionality factor is computed independently for each output line by averaging the square of the residuals (at points having three or more input values) scaled by the median or mean. In theory the proportionality should be the same for all rows but because of the estimating process will vary somewhat. Once the proportionality factor is determined, deviant pixels exceeding the specified thresholds are rejected at each point by estimating the sigma from the median or mean. If any values are rejected the median or mean (this time not excluding the extreme values) is recomputed and further values rejected. This is repeated until there are no further pixels rejected or the number of remaining input values falls below three. Note that the proportionality factor is not recomputed after rejections. If the images are scaled differently and the sigma scaling correction threshold is exceeded then a correction is made in the sigma calculations for these differences, again under the assumption that the noise in an image scales as the square root of the mean intensity. After rejection the number of retained pixels is checked against the \fInkeep\fR parameter. If there are fewer pixels retained than specified by this parameter the pixels with the smallest residuals in absolute value are added back. If there is more than one pixel with the same absolute residual (for example the two pixels about an average or median of two will have the same residuals) they are all added back even if this means more than \fInkeep\fR pixels are retained. Note that the \fInkeep\fR parameter only applies to the pixels used by the clipping rejection algorithm and does not apply to threshold or bad pixel mask rejection. This algorithm works well for even a few input images. It works better if the median is used though this is slower than using the average. Note that if the images have a known read out noise and gain (the proportionality factor above) then the "ccdclip" algorithm is superior. The two algorithms are related in that the average sigma proportionality factor is an estimate of the gain. The parameters affecting this algorithm are \fIreject\fR to select this algorithm, \fImclip\fR to select the median or average for the center of the clipping, \fInkeep\fR to limit the number of pixels rejected, \fIlsigma\fR and \fIhsigma\fR to select the clipping thresholds, and \fIsigscale\fR to set the threshold for making corrections to the sigma calculation for different image scale factors. .in -4 PCLIP .in 4 The percentile clipping algorithm is similar to sigma clipping using the median as the center of the distribution except that, instead of computing the sigma of the pixels from the CCD noise parameters or from the data values, the width of the distribution is characterized by the difference between the median value and a specified "percentile" pixel value. This width is then multipled by the scale factors \fIlsigma\fR and \fIhsigma\fR to define the clipping thresholds above and below the median. The clipping is not iterated. The pixel values at each output point are ordered in magnitude and the median is determined. In the case of an even number of pixels the average of the two middle values is used as the median value and the lower or upper of the two is the median pixel when counting from the median pixel to selecting the percentile pixel. The parameter \fIpclip\fR selects the percentile pixel as the number (if the absolute value is greater than unity) or fraction of the pixels from the median in the ordered set. The direction of the percentile pixel from the median is set by the sign of the \fIpclip\fR parameter with a negative value signifying pixels with values less than the median. Fractional values are internally converted to the appropriate number of pixels for the number of input images. A minimum of one pixel and a maximum corresponding to the extreme pixels from the median are enforced. The value used is reported in the log output. Note that the same percentile pixel is used even if pixels have been rejected by offseting, masking, or thresholding; for example, if the 3nd pixel below the median is specified then the 3rd pixel will be used whether there are 10 pixels or 5 pixels remaining after the preliminary steps. Some examples help clarify the definition of the percentile pixel. In the examples assume 10 pixels. The median is then the average of the 5th and 6th pixels. A \fIpclip\fR value of 2 selects the 2nd pixel above the median (6th) pixel which is the 8th pixel. A \fIpclip\fR value of -0.5 selects the point halfway between the median and the lowest pixel. In this case there are 4 pixels below the median, half of that is 2 pixels which makes the percentile pixel the 3rd pixel. The percentile clipping algorithm is most useful for clipping small excursions, such as the wings of bright objects when combining disregistered observations for a sky flat field, that are missed when using the pixel values to compute a sigma. It is not as powerful, however, as using the CCD noise parameters (provided they are accurately known) to clip about the median. The parameters affecting this algorithm are \fIreject\fR to select this algorithm, \fIpclip\fR to select the percentile pixel, \fInkeep\fR to limit the number of pixels rejected, and \fIlsigma\fR and \fIhsigma\fR to select the clipping thresholds. .in -4 GROW REJECTION Neighbors of pixels rejected by the rejection algorithms along image lines may also be rejected. The number of neighbors to be rejected on either side is specified by the \fIgrow\fR parameter. The rejection only applies to neighbors along each image line. This is because the task operates independently on each image line and does not have the ability to go back to previous lines or maintain a list of rejected pixels to later lines. This rejection step is also checked against the \fInkeep\fR parameter and only as many pixels as would not violate this parameter are rejected. Unlike it's application in the rejection algorithms at this stage there is no checking on the magnitude of the residuals and the pixels retained which would otherwise be rejected are randomly selected. COMBINING After all the steps of offsetting the input images, masking pixels, threshold rejection, scaling, and applying a rejection algorithms the remaining pixels are combined and output. The pixels may be combined by computing the median or by computing a weighted average. SIGMA OUTPUT In addition to the combined image and optional sigma image may be produced. The sigma computed is the standard deviation, corrected for a finite population by a factor of n/(n-1), of the unrejected input pixel values about the output combined pixel values. .ih EXAMPLES 1. To average and median images without any other features: .nf cl> combine obj* avg combine=average reject=none cl> combine obj* med combine=median reject=none .fi 2. To reject cosmic rays: .nf cl> combine obs1,obs2 Obs reject=crreject rdnoise=5.1, gain=4.3 .fi 3. To make a grid for display purposes with 21 64x64 images: .nf cl> combine @list grid offset="grid 5 65 5 65" .fi 4. To apply a mask image with good pixels marked with a zero value and bad pixels marked with a value of one: .nf cl> hedit ims* bpm badpix.pl add+ ver- cl> combine ims* final combine=median masktype=goodval .fi 5. To scale image by the exposure time and then adjust for varying sky brightness and make a weighted average: .nf cl> combine obj* avsig combine=average reject=avsig \ >>> scale=exp zero=mode weight=exp expname=exptime .fi .ih TIME REQUIREMENTS The following times were obtain with a Sun 4/470. The tests combine 1000x200 images consisting of Poisson noise and cosmic rays generated with the \fBartdata\fR package. The times, especially the total time, are approximate and depend on user loads. .nf IMAGES: Number of images (1000x200) and datatype (R=real, S=short) COMBINE: Combine option REJECT: Rejection option with grow = 0 minmax: nlow = 1, nhigh = 1 ccdclip: lsigma = 3., hsigma = 3, sigscale = 0. sigclip: lsigma = 3., hsigma = 3, sigscale = 0. avsigclip: lsigma = 3., hsigma = 3, sigscale = 0. pclip: lsigma = 3., hsigma = 3, pclip = -0.5 /a: mclip = no (clip about the average) /m: mclip = yes (clip about the median) O M T S: Features used (Y=yes, N=no) O: offset = "grid 5 10 2 10" M: masktype = goodval, maskval = 0 Pixel mask has 2 bad lines and 20 bad columns T: lthreshold = INDEF, hthreshold = 1100. S: scale = mode, zero = none, weight = mode TIME: cpu time in seconds, total time in minutes and seconds IMAGES COMBINE REJECT O M T S TIME 10R average none N N N N 1.3 0:08 10R average minmax N N N N 4.3 0:10 10R average pclip N N N N 17.9 0:32 10R average ccdclip/a N N N N 11.6 0:21 10R average crreject/a N N N N 11.4 0:21 10R average sigclip/a N N N N 13.6 0:29 10R average avsigclip/a N N N N 15.9 0:35 10R average ccdclip/m N N N N 16.9 0:32 10R average crreject/m N N N N 17.0 0:28 10R average sigclip/m N N N N 19.6 0:42 10R average avsigclip/m N N N N 20.6 0:43 10R median none N N N N 6.8 0:17 10R median minmax N N N N 7.8 0:15 10R median pclip N N N N 16.9 1:00 10R median ccdclip/a N N N N 18.0 0:34 10R median crreject/a N N N N 17.7 0:30 10R median sigclip/a N N N N 21.1 1:13 10R median avsigclip/a N N N N 23.1 0:41 10R median ccdclip/m N N N N 16.1 0:27 10R median crreject/m N N N N 16.0 0:27 10R median sigclip/m N N N N 18.1 0:29 10R median avsigclip/m N N N N 19.6 0:32 10R average none N N N Y 6.1 0:36 10R median none N N N Y 10.4 0:49 10R median pclip N N N Y 20.4 1:10 10R median ccdclip/m N N N Y 19.5 0:36 10R median avsigclip/m N N N Y 23.0 1:06 10R average none N Y N N 3.5 0:12 10R median none N Y N N 8.9 0:21 10R median pclip N Y N N 19.9 0:45 10R median ccdclip/m N Y N N 18.0 0:44 10R median avsigclip/m N Y N N 20.9 0:28 10R average none Y N N N 4.3 0:13 10R median none Y N N N 9.6 0:21 10R median pclip Y N N N 21.8 0:54 10R median ccdclip/m Y N N N 19.3 0:44 10R median avsigclip/m Y N N N 22.8 0:51 10R average none Y Y Y Y 10.8 0:22 10R median none Y Y Y Y 16.1 0:28 10R median pclip Y Y Y Y 27.4 0:42 10R median ccdclip/m Y Y Y Y 25.5 0:39 10R median avsigclip/m Y Y Y Y 28.9 0:44 10S average none N N N N 2.2 0:06 10S average minmax N N N N 4.6 0:12 10S average pclip N N N N 18.1 0:33 .fi .ih REVISIONS .ls COMBINE V2.11 The limit of the number of images that may be combined has been removed. If the number of images exceeds the maximum number of open images permitted then the images are stacked in a single temporary image and then combined with the project option. Note that this will double the amount of diskspace temporarily. There is also a limitation in this case that the bad pixel mask from the first image in the list will be applied to all the images. Images may now be grouped by an "amplifier" parameter. A new parameter \fIamps\fR was added to control this grouping. Integer offsets may be determined from the image world coordinate system. .le .ls COMBINE V2.10.3 The output pixel datatype parameter, \fIouttype\fR was previously ignored and the package \fIpixeltype\fR was used. The task output pixel type parameter is now used. The factors specified by an @file or keyword are not normalized. .le .ls COMBINE V2.10.2 The weighting was changed from using the square root of the exposure time or image statistics to using the values directly. This corresponds to variance weighting. Other options for specifying the scaling and weighting factors were added; namely from a file or from a different image header keyword. The \fInkeep\fR parameter was added to allow controlling the maximum number of pixels to be rejected by the clipping algorithms. The \fIsnoise\fR parameter was added to include a sensitivity or scale noise component to the noise model. Errors will now delete the output images. .le .ls COMBINE V2.10 This task was greatly revised to provide many new features. These features are: .nf o Bad pixel masks o Combining offset and different size images o Blank value for missing data o Combining across the highest dimension (the project option) o Separating threshold rejection, the rejection algorithms, and the final combining statistic o New CCDCLIP, CRREJECT, and PCLIP algorithms o Rejection now may reject more than one pixel per output pixel o Choice of a central median or average for clipping o Choice of final combining operation o Simultaneous multiplicative and zero point scaling .fi .le .ih LIMITATIONS Though the previous limit on the number of images that can be combined was removed in V2.11 the method has the limitation that only a single bad pixel mask will be used for all images. .ih SEE ALSO image.imcombine, instruments, ccdtypes, icfit, ccdred, guide, darkcombine, flatcombine, zerocombine, onedspec.scombine wfpc.noisemodel .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/contents.ms000066400000000000000000000014721332166314300207500ustar00rootroot00000000000000.sp 1i .ps +2 .ft B .ce Contents .sp 3 .ps -2 .ft R .sp 1.\h'|0.4i'\fBIntroduction\fP\l'|5.6i.'\0\01 .sp 2.\h'|0.4i'\fBGetting Started\fP\l'|5.6i.'\0\02 .sp 3.\h'|0.4i'\fBProcessing Your Data\fP\l'|5.6i.'\0\05 .br \h'|0.4i'3.1.\h'|0.9i'Combining Calibration Images\l'|5.6i.'\0\06 .br \h'|0.4i'3.2.\h'|0.9i'Calibrations and Corrections\l'|5.6i.'\0\07 .sp 4.\h'|0.4i'\fBSpecial Processing Operations\fP\l'|5.6i.'\0\08 .br \h'|0.4i'4.1.\h'|0.9i'Spectroscopic Flat Fields\l'|5.6i.'\0\08 .br \h'|0.4i'4.2.\h'|0.9i'Illumination Corrections\l'|5.6i.'\0\09 .br \h'|0.4i'4.3.\h'|0.9i'Sky Flat Fields\l'|5.6i.'\010 .br \h'|0.4i'4.4.\h'|0.9i'Illumination Corrected Flat Fields\l'|5.6i.'\010 .br \h'|0.4i'4.5.\h'|0.9i'Fringe Corrections\l'|5.6i.'\010 .sp 5.\h'|0.4i'\fBSummary\fP\l'|5.6i.'\011 .sp \h'|0.4i'\fBReferences\fP\l'|5.6i.'\011 mscred-5.05-2018.07.09/src/ccdred/doc/cosmicrays.hlp000066400000000000000000000371211332166314300214330ustar00rootroot00000000000000.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) 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 mscred-5.05-2018.07.09/src/ccdred/doc/darkcombine.hlp000066400000000000000000000113131332166314300215300ustar00rootroot00000000000000.help darkcombine Aug91 noao.imred.ccdred .ih NAME darkcombine -- Combine and process dark count images .ih USAGE darkcombine input .ih PARAMETERS .ls input List of dark count images to combine. The \fIccdtype\fR parameter may be used to select the zero level images from a list containing all types of data. .le .ls output = "Dark" Output dark count root image name. .le .ls combine = "average" (average|median) Type of combining operation performed on the final set of pixels (after rejection). The choices are "average" or "median". The median uses the average of the two central values when the number of pixels is even. .le .ls reject = "minmax" (none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip) Type of rejection operation. See \fBcombine\fR for details. .le .ls ccdtype = "dark" CCD image type to combine. If no image type is given then all input images are combined. .le .ls process = yes Process the input images before combining? .le .ls delete = no Delete input images after combining? Only those images combined are deleted. .le .ls scale = "exposure" (none|mode|median|mean|exposure) Multiplicative image scaling to be applied. The choices are none, scale by the mode, median, or mean of the specified statistics section, or scale by the exposure time given in the image header. .le .ls statsec = "" Section of images to use in computing image statistics for scaling. If no section is given then the entire region of the image is sampled (for efficiency the images are sampled if they are big enough). .le .ce Algorithm Parameters .ls nlow = 0, nhigh = 1 (minmax) The number of low and high pixels to be rejected by the "minmax" algorithm. .le .ls nkeep = 1 The minimum number of pixels to retain or the maximum number to reject when using the clipping algorithms (ccdclip, crreject, sigclip, avsigclip, or pclip). When given as a positive value this is the minimum number to keep. When given as a negative value the absolute value is the maximum number to reject. This is actually converted to a number to keep by adding it to the number of images. .le .ls mclip = yes (ccdclip, crreject, sigclip, avsigcliip) Use the median as the estimate for the true intensity rather than the average with high and low values excluded in the "ccdclip", "crreject", "sigclip", and "avsigclip" algorithms? The median is a better estimator in the presence of data which one wants to reject than the average. However, computing the median is slower than the average. .le .ls lsigma = 3., hsigma = 3. (ccdclip, crreject, sigclip, avsigclip, pclip) Low and high sigma clipping factors for the "ccdclip", "crreject", "sigclip", "avsigclip", and "pclip" algorithms. They multiply a "sigma" factor produced by the algorithm to select a point below and above the average or median value for rejecting pixels. The lower sigma is ignored for the "crreject" algorithm. .le .ls rdnoise = "0.", gain = "1.", snoise = "0." (ccdclip, crreject) CCD readout noise in electrons, gain in electrons/DN, and sensitivity noise as a fraction. These parameters are used with the "ccdclip" and "crreject" algorithms. The values may be either numeric or an image header keyword which contains the value. .le .ls pclip = -0.5 (pclip) Percentile clipping algorithm parameter. If greater than one in absolute value then it specifies a number of pixels above or below the median to use for computing the clipping sigma. If less than one in absolute value then it specifies the fraction of the pixels above or below the median to use. A positive value selects a point above the median and a negative value selects a point below the median. The default of -0.5 selects approximately the quartile point. See \fBcombine\fR for further details. .le .ls blank = 0. Output value to be used when there are no pixels. .le .ih DESCRIPTION The dark count images in the input image list are combined. The input images may be processed first if desired. The original images may be deleted automatically if desired. The output pixel datatype will be real. This task is a script which applies \fBccdproc\fR and \fBcombine\fR. The parameters and combining algorithms are described in detail in the help for \fBcombine\fR. This script has default parameters specifically set for dark count images and simplifies the combining parameters. There are other combining options not included in this task. For these additional features, such as thresholding, offseting, masking, and projecting, use \fBcombine\fR. .ih EXAMPLES 1. The image data contains four dark count images. To automatically select them and combine them as a background job using the default combining algorithm: cl> darkcombine ccd*.imh& .ih REVISIONS .ls DARKCOMBINE V2.11 The images will be combined by amplifier. .le .ih SEE ALSO ccdproc, combine .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/flatcombine.hlp000066400000000000000000000126321332166314300215420ustar00rootroot00000000000000.help flatcombine Aug91 noao.imred.ccdred .ih NAME flatcombine -- Combine and process flat field images .ih USAGE flatcombine input .ih PARAMETERS .ls input List of flat field images to combine. The \fIccdtype\fR parameter may be used to select the flat field images from a list containing all types of data. .le .ls output = "Flat" Output flat field root image name. The subset ID is appended. .le .ls combine = "average" (average|median) Type of combining operation performed on the final set of pixels (after rejection). The choices are "average" or "median". The median uses the average of the two central values when the number of pixels is even. .le .ls reject = "avsigclip" (none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip) Type of rejection operation. See \fBcombine\fR for details. .le .ls ccdtype = "flat" CCD image type to combine. If no image type is given then all input images are combined. .le .ls process = yes Process the input images before combining? .le .ls subsets = yes Combine images by subset parameter? If yes then the input images are grouped by subset parameter and each group combined into a separate output image. The subset identifier is appended to the output and sigma image names. See \fBsubsets\fR for more on the subset parameter. This is generally used with flat field images. .le .ls delete = no Delete input images after combining? Only those images combined are deleted. .le .ls scale = "mode" (none|mode|median|mean|exposure) Multiplicative image scaling to be applied. The choices are none, scale by the mode, median, or mean of the specified statistics section, or scale by the exposure time given in the image header. .le .ls statsec = "" Section of images to use in computing image statistics for scaling. If no section is given then the entire region of the image is sampled (for efficiency the images are sampled if they are big enough). .le .ce Algorithm Parameters .ls nlow = 1, nhigh = 1 (minmax) The number of low and high pixels to be rejected by the "minmax" algorithm. .le .ls nkeep = 1 The minimum number of pixels to retain or the maximum number to reject when using the clipping algorithms (ccdclip, crreject, sigclip, avsigclip, or pclip). When given as a positive value this is the minimum number to keep. When given as a negative value the absolute value is the maximum number to reject. This is actually converted to a number to keep by adding it to the number of images. .le .ls mclip = yes (ccdclip, crreject, sigclip, avsigcliip) Use the median as the estimate for the true intensity rather than the average with high and low values excluded in the "ccdclip", "crreject", "sigclip", and "avsigclip" algorithms? The median is a better estimator in the presence of data which one wants to reject than the average. However, computing the median is slower than the average. .le .ls lsigma = 3., hsigma = 3. (ccdclip, crreject, sigclip, avsigclip, pclip) Low and high sigma clipping factors for the "ccdclip", "crreject", "sigclip", "avsigclip", and "pclip" algorithms. They multiply a "sigma" factor produced by the algorithm to select a point below and above the average or median value for rejecting pixels. The lower sigma is ignored for the "crreject" algorithm. .le .ls rdnoise = "0.", gain = "1.", snoise = "0." (ccdclip, crreject) CCD readout noise in electrons, gain in electrons/DN, and sensitivity noise as a fraction. These parameters are used with the "ccdclip" and "crreject" algorithms. The values may be either numeric or an image header keyword which contains the value. .le .ls pclip = -0.5 (pclip) Percentile clipping algorithm parameter. If greater than one in absolute value then it specifies a number of pixels above or below the median to use for computing the clipping sigma. If less than one in absolute value then it specifies the fraction of the pixels above or below the median to use. A positive value selects a point above the median and a negative value selects a point below the median. The default of -0.5 selects approximately the quartile point. See \fBcombine\fR for further details. .le .ls blank = 1. Output value to be used when there are no pixels. .le .ih DESCRIPTION The flat field images in the input image list are combined. If there is more than one subset (such as a filter or grating) then the input flat field images are grouped by subset and an combined separately. The input images may be processed first if desired. However if all zero level bias effects are linear then this is not necessary and some processing time may be saved. The original images may be deleted automatically if desired. The output pixel datatype will be real. This task is a script which applies \fBccdproc\fR and \fBcombine\fR. The parameters and combining algorithms are described in detail in the help for \fBcombine\fR. This script has default parameters specifically set for flat field images and simplifies the combining parameters. There are other combining options not included in this task. For these additional features, such as thresholding, offseting, masking, and projecting, use \fBcombine\fR. .ih EXAMPLES 1. The image data contains four flat field images for three filters. To automatically select them and combine them as a background job using the default combining algorithm: cl> flatcombine ccd*.imh& The final images are "FlatV", "FlatB", and "FlatR". .ih REVISIONS .ls FLATCOMBINE V2.11 The images will be combined by amplifier. .le .ih SEE ALSO ccdproc, combine, subsets .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/flatfields.hlp000066400000000000000000000233431332166314300213750ustar00rootroot00000000000000.help flatfields Jun87 noao.imred.ccdred .ih NAME flatfields -- Discussion of CCD flat field calibrations .ih DESCRIPTION This topic describes the different types of CCD flat fields and the tasks available in the \fBccdred\fR and spectroscopy packages for creating them. Flat field calibration is the most important operation performed on CCD data. This operation calibrates the relative response of the detector at each pixel. In some cases this is as simple as taking a special type of observation called a flat field. However, in many cases this calibration observation must be corrected for illumination, scanning, wavelength, and aperture effects. The discussion is in three sections; direct imaging, scan mode, and spectroscopy. Though there are many similarities between these modes of operation there are important differences in how corrections are applied to the basic flat field observations. The application of the flat field calibrations to the observations using \fBccdproc\fR is the same in all cases, however. .sh 1. Direct Imaging The starting point for determining the flat field calibration is an observation of something which should have uniform response at all points on the detector. In addition the color of the light falling at each pixel should be the same as that in an observation so the same filter must be used when determining the flat field (the issue of the matching the color of the objects observed at the appropriate pixels is ignored here). The best calibration observation is of a blank sky. If an accurate blank sky observation can be obtained then this is all that is needed for a flat field calibration. This type of flat field might be called a \fIsky flat\fR, though this term is more often used for a type of flat field described below. There are two difficulties with this type of calibration; finding a really blank sky and getting a sufficiently accurate measurement without using all the observing time. It is usually not possible to get a blank sky observation accurate enough to calibrate the individual pixels without introducing undesirable noise. What is generally done is to use a lamp to either uniformly illuminate a part of the dome or directly illuminate the field of view. The first type of observation is called a \fIdome flat\fR and the second is called a \fIprojection flat\fR. We shall call both of these types of observations \fBlamp flat fields\fR. If the illumination is truely uniform then these types of observations are sufficient for flat field calibration. To get a very accurate flat field many observations are made and then combined (see \fBflatcombine\fR). Unfortunately, it is sometimes the case that the lamp flat fields do not illuminate the telescope/detector in the same way as the actual observations. Calibrating with these flat fields will introduce a residual large scale illumination pattern, though it will correctly calibrate the relative pixel responses locally. There are two ways to correct for this effect. The first is to correct the flat field observation. The second is to apply the uncorrected flat field to the observations and then apply an \fIillumination\fR correction as a separate operation. The first is more efficient since it consists of a single correction applied to each observation but in some cases the approximate correction is desired immediately, the observation needed to make the correction has not been taken yet, or the residual illumination error is not discovered until later. For the two methods there are two types of correction. One is to use a blank sky observation to correct for the residual illumination pattern. This is different than using the sky observation directly as a flat field calibration in that only the large scale pattern is needed. Determining the large scale illumination does not require high signal-to-noise at each pixel and faint objects in the image can be either eliminated or ignored. The second method is to remove the large scale shape from the lamp flat field. This is not as good as using a blank sky observation but, if there is no such observation and the illumination pattern is essentially only in the lamp flat field, this may be sufficient. From the above two paragraphs one sees there are four options. There is a task in the \fBccdred\fR package for each of these options. To correct a lamp flat field observation by a blank sky observation, called a \fIsky flat\fR, the task is \fBmkskyflat\fR. To correct the flat field for its own large scale gradients, called an \fIillumination flat\fR, the task is \fBmkillumflat\fR. To create a secondary correction to be applied to data processed with the lamp flat field image the tasks are \fBmkskycor\fR and \fBmkillumcor\fR which are, respectively, based on a blank sky observation and the lamp flat field illumination pattern. With this introduction turn to the individual documentation for these four tasks for further details. .sh 2. Scan Mode There are two types of scan modes supported by the \fBccdred\fR package; \fIshortscan\fR and \fIlongscan\fR (see \fBccdproc\fR for further details). They both affect the manner in which flat field calibrations are handled. The shortscan mode produces images which are the same as direct images except that the light recorded at each pixel was collected by a number of different pixels. This improves the flat field calibration. If the flat field images, of the same types described in the direct imaging section, are observed in the same way as all other observations, i.e. in scan mode, then there is no difference from direct imaging (except in the quality of the flat fields). There is a statistical advantage to observing the lamp or sky flat field without scanning and then numerically averaging to simulate the result of the scanning. This improves the accuracy of the flat fields and might possibly allow direct blank sky observations to be used for flat fields. The numerical scanning is done in \fBccdproc\fR by setting the appropriate scanning parameters. In longscan mode the CCD detector is read out in such a way that each output image pixel is the sum of the light falling on all pixels along the direction of the scan. This reduces the flat field calibration to one dimension, one response value for each point across the scan. The one dimensional calibration is obtained from a longscan observation by averaging all the readout lines. This is done automatically in \fBccdproc\fR by setting the appropriate parameters. In this case very good flat fields can be obtained from one or more blank sky observations or an unscanned lamp observation. Other corrections are not generally used. .sh 3. Spectroscopy Spectroscopic flat fields differ from direct imaging in that the spectrum of the sky or lamp and transmission variations with wavelength are part of the observation. Application of such images will introduce the inverse of the spectrum and transmission into the observation. It also distorts the observed counts making signal-to-noise estimates invalid. This, and the low signal in the dispersed light, makes it difficult to use blank sky observations directly as flat fields. As with direct imaging, sky observation may be used to correct for illumination errors if necessary. At sufficiently high dispersion the continuous lamp spectrum may be flat enough that the spectral signature of the lamp is not a problem. Alternatively, flux calibrating the spectra will also remove the flat field spectral signature. The spectroscopic flat fields also have to be corrected for regions outside of the slit or apertures to avoid bad response effects when applying the flat field calibration to the observations. The basic scheme for removing the spectral signature is to average all the lines or columns across the dispersion and within the aperture to form an estimate of the spectrum. In addition to the averaging, a smooth curve is fit to the lamp spectrum to remove noise. This smooth shape is then divided back into each line or column to eliminate the shape of the spectrum without changing the shape of the spectrum in the spatial direction or the small scale response variations. Regions outside of the apertures are replaced by unity. This method requires that the dispersion be aligned fairly close to either the CCD lines or columns. This scheme is used in both longslit and multiaperture spectra. The latter includes echelle, slitlets, aperture masks, and fiber feeds. For narrow apertures which do not have wider slits for the lamp exposures there may be problems with flexure and defining a good composite spectrum. The algorithm for longslit spectra is simpler and is available in the task \fBresponse\fR in the \fBlongslit\fR package. For multiaperture data there are problems of defining where the spectra lie and avoiding regions off of the aperture where there is no signal. The task which does this is \fBapnormalize\fR in the \fBapextract\fR package. Note that the lamp observations must first be processed explicitly for bias and dark count corrections. Longslit spectra may also suffer the same types of illumination problems found in direct imaging. However, in this case the illumination pattern is determined from sky observations (or the flat field itself) by finding the large scale pattern across the dispersion and at a number of wavelengths while avoiding the effects of night sky spectrum. The task which makes this type of correction in the \fBlongslit\fR package is \fBillumination\fR. This produces an illumination correction. To make sky flats or the other types of corrections image arithmetic is used. Note also that the sky observations must be explicitly processed through the flat field stage before computing the illumination. .ih SEE ALSO .nf ccdproc, guide, mkillumcor, mkillumflat, mkskycor, mkskyflat apextract.apnormalize, longslit.response, longslit.illumination .fi .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/guide.hlp000066400000000000000000001066041332166314300203570ustar00rootroot00000000000000.help guide Feb88 noao.imred.ccdred .ce User's Guide to the CCDRED Package .sh 1. Introduction This guide provides a brief description of the IRAF CCD reduction package \fBccdred\fR and examples of reducing simple CCD data. It is a generic guide in that it is not tied to any particular type of data. There may be more specific guides (or "cookbooks") for your data. Detailed descriptions of the tasks and features of the package are provided in the help documentation for the package. The purpose of the CCDRED package is to provide tools for the easy and efficient reduction of CCD images. The standard reduction operations are replacement of bad columns and lines by interpolation from neighboring columns and lines, subtraction of a bias level determined from overscan or prescan columns or lines, subtraction of a zero level using a zero length exposure calibration image, subtraction of a dark count calibration image appropriately scaled to the dark time exposure, division by a scaled flat field calibration image, division by an illumination image (derived from a blank sky image), subtraction of a scaled fringe image (also derived from a blank sky image), and trimming the image of unwanted lines or columns such as the overscan strip. Any set of operations may be done simultaneously over a list of images in a highly efficient manner. The reduction operations are recorded in the image header and may also be logged on the terminal and in a log file. The package also provides tools for combining multiple exposures of object and calibration images to improve the statistical accuracy of the observations and to remove transient bad pixels. The combining operation scales images of different exposure times, adjusts for variable sky background, statistically weights the images by their signal-to-noise, and provides a number of useful algorithms for detecting and rejecting transient bad pixels. Other tasks are provided for listing reduction information about the images, deriving secondary calibration images (such as sky corrected flat fields or illumination correction images), and easily setting the package parameters for different instruments. There are several important features provided by the package to make the reduction of CCD images convenient; particularly to minimize record keeping. One of these is the ability to recognize the different types of CCD images. This ability allows the user to select a certain class of images to be processed or listed and allows the processing tasks to identify calibration images and process them differently from object images. The standard CCD image types are \fIobject\fR, \fIzero\fR level, \fIdark\fR count, and \fIflat\fR field. For more on the image types see \fBccdtypes\fR. The tasks can also identify different amplifiers and different filters (or other subset parameter) which require different calibration images. This means you don't have to separate the images by filter and process each set separately. This feature is discussed further in \fBsubsets\fR. The tasks keep track of the reduction steps completed on each image and ignore images which have been processed. This feature, along with recognizing the image types, amplifiers, and subsets, makes it possible to specify all the images to a task with a wildcard template, such as "*.imh", rather than indicating each image by name. You will find this extremely important with large sets of observations. A fundamental aspect of the package is that the processing modifies the images. In other words, the reduction operations are performed directly on the image. This "feature" further simplifies record keeping, frees the user from having to form unique output image names, and minimizes the amount of disk space required. There are two safety features in this process. First, the modifications do not take effect until the operation is completed on the image. This allows you to abort the task without messing up the image data and protects data if the computer crashes. The second feature is that there is a package parameter which may be set to make a backup of the input data with a particular prefix such as "orig" or "imdir$". This backup feature may be used when there is sufficient disk space, when learning to use the package, or just to be cautious. In a similar effort to efficiently manage disk space, when combining images into a master object or calibration image there is an option to delete the input images upon completion of the combining operation. Generally this is desirable when there are many calibration exposures, such as zero level or flat field images, which are not used after they are combined into a final calibration image. The following sections guide you through the basic use of the \fBccdred\fR package. Only the important parameters which you might want to change are described. It is assumed that the support personnel have created the necessary instrument files (see \fBinstruments\fR) which will set the default parameters for the data you will be reducing. If this is not the case you may need to delve more deeply into the details of the tasks. Information about all the parameters and how the various tasks operate are given in the help documentation for the tasks and in additional special help topics. Some useful help documentation is indicated in the discussion and also in the \fBReferences\fR section. .sh 2. Getting Started The first step is to load \fBccdred\fR. This is done by loading the \fBnoao\fR package, followed by the image reduction package \fBimred\fR, and finally the \fBccdred\fR package. Loading a package consists of typing its name. Note that some of these packages may be loaded automatically when you logon to IRAF. When you load the \fBccdred\fR package the menu of tasks or commands is listed. This appears as follows: .nf cl> ccdred badpiximage ccdtest mkfringecor setinstrument ccdgroups combine mkillumcor zerocombine ccdhedit cosmicrays mkillumflat ccdlist darkcombine mkskycor ccdproc flatcombine mkskyflat .fi A summary of the tasks and additional help topics is obtained by typing: cl> help This list and how to get additional help on specific topics is described in the \fBReferences\fR section at the end of this guide. The first command to use is \fBsetinstrument\fR, which sets the package appropriately for the CCD images to be reduced. The support personnel should tell you the instrument identification, but if not a list of known instruments may be listed by using '?' for the instrument name. .nf cl> setinstrument Instrument ID (type ? for a list) \fI\fR .fi This task sets the default parameters and then allows you to modify the package parameters and the processing parameters using the parameter editor \fBeparam\fR. If you are not familiar with \fBeparam\fR see the help or CL introduction documentation. For most terminals you move up and down through the parameters with the terminal arrow keys, you change the parameters by simply typing the desired value, and you exit with control Z or control D. Note that you can change parameters for any task at any time with \fBeparam\fR and you do not have to run \fBsetinstrument\fR again, even if you logout, until you need to reduce data from a different instrument. The \fBccdred\fR package parameters control general I/O functions of the tasks in the package. The parameters you might wish to change are the output pixel type and the verbose option. Except when the input images are short integers, the noise is significantly greater than one digital unit, and disk space is critical, it is probably better to allow the processing to convert the images to real pixel datatype. The verbose parameter simply prints the information written to the log file on the terminal. This can be useful when little else is being done and you are just beginning. However, when doing background processing and other IRAF reduction tasks it is enough to simply look at the end of the logfile with the task \fBtail\fR to see the current state of the processing. The \fBccdproc\fR parameters control the CCD processing. There are many parameters but they all may be conveniently set at this point. Many of the parameters have default values set appropriately for the instrument you specified. The images to be processed can be specified later. What needs to be set are the processing operations that you want done and the parameters required for each operation. The processing operations are selected by entering yes or no for each one. The following items briefly describe each of the possible processing operations and the additional parameters required. .ls \fIoverscan\fR - Apply overscan strip correction? The overscan or prescan region is specified by the parameter \fIbiassec\fR. This is given as an IRAF image section. Only the part of the section corresponding to the readout axis is used and the other part is ignored. The length of the overscan region is set by the \fItrimsec\fR parameter. The overscan region is averaged along the readout axis, specified by the parameter \fIreadaxis\fR, to create a one dimensional bias vector. This bias is fit by a function to remove cosmic rays and noise. There are a number of parameters at the end of the parameter list which control the fitting. The default overscan bias section and fitting parameters for your instrument should be set by \fBsetinstrument\fR. An image header keyword may be used to define the overscan bias section by using the syntax !. If an overscan section is not set you can use \fBimplot\fR to determine the columns or rows for the bias region and define an overscan image section. If you are unsure about image sections consult with someone or read the introductory IRAF documentation. .le .ls \fItrim\fR - Trim the image? The image is trimmed to the image section given by the parameter \fItrimsec\fR. A default trim section for your instrument should be set by \fBsetinstrument\fR, however, you may override this default if desired. An image header keyword may be used to define the overscan bias section by using the syntax !. As with the overscan image section it is straightforward to specify, but if you are unsure consult someone. .le .ls \fIfixpix\fR - Fix bad CCD lines and columns? The bad pixels (cosmetic defects) in the detector are given in a bad pixel mask specified by the parameter \fIfixfile\fR. This information is used to replace the pixels by interpolating from the neighboring pixels. A standard file for your instrument may be set by \fBsetinstrument\fR or if the word "BPM" is given then the file is obtain from the image header under the keyword "BPM". An image header keyword may be specified with the syntax ! where is an image header keyword. The bad pixel masks are matched to the input by amplifier. For more on the bad pixel mask see \fBinstruments\fR. .le .ls \fIzerocor\fR - Apply zero level correction? The zero level image to be subtracted is specified by the parameter \fIzero\fR. An image header keyword may be specified with the syntax ! where is an image header keyword. If none is given then the calibration image will be sought in the list of images to be processed. The zero calibration images are matched to the input by amplifier. .le .ls \fIdarkcor\fR - Apply dark count correction? The dark count image to be subtracted is specified by the parameter \fIdark\fR. An image header keyword may be specified with the syntax ! where is an image header keyword. If none is given then the calibration image will be sought in the list of images to be processed. The dark count calibration images are matched to the input by amplifier. .le .ls \fIflatcor\fR - Apply flat field correction? The flat field images to be used are specified by the parameter \fIflat\fR. An image header keyword may be specified with the syntax ! where is an image header keyword. There must be one flat field image for each amplifier and subset (see \fBsubsets\fR) to be processed. If a flat field image is not given then the calibration image will be sought in the list of images to be processed. .le .ls \fIreadcor\fR - Convert zero level image to readout correction? If a one dimensional zero level readout correction vector is to be subtracted instead of a two dimensional zero level image then, when this parameter is set, the zero level images will be averaged to one dimension. The readout axis must be specified by the parameter \fIreadaxis\fR. The default for your instrument is set by \fBsetinstrument\fR. .le .ls \fIscancor\fR - Convert flat field image to scan correction? If the instrument is operated in a scan mode then a correction to the flat field may be required. There are two types of scan modes, "shortscan" and "longscan". In longscan mode flat field images will be averaged to one dimension and the readout axis must be specified. Shortscan mode is a little more complicated. The scan correction is used if the flat field images are not observed in scan mode. The number of scan lines must be specified by the parameter \fInscan\fR. If they are observed in scan mode, like the object observations, then the scan correction operations should \fInot\fR be specified. For details of scan mode operations see \fBccdproc\fR. The scan parameters should be set by \fBsetinstrument\fR. If in doubt consult someone familiar with the instrument and mode of operation. .le This description of the parameters is longer than the actual operation of setting the parameters. The only parameters likely to change during processing are the calibration image parameters. When processing many images using the same calibration files a modest performance improvement can be achieved by keeping (caching) the calibration images in memory to avoid disk accesses. This option is available by specifying the amount of memory available for image caching with the parameter \fImax_cache\fR. If the value is zero then the images are accessed from disk as needed while if there is sufficient memory the calibration images may be kept in memory during the task execution. .sh 3. Processing Your Data The processing path depends on the type of data, the type of instrument, types of calibration images, and the observing sequence. In this section we describe two types of operations common in reducing most data; combining calibration images and performing the standard calibration and correction operations. Some additional special operations are described in the following section. However, the first thing you might want to try before any processing is to get a listing of the CCD images showing the CCD image types, amplifiers, subsets, and processing flags. The task for this is \fBccdlist\fR. It has three types of of output; a short one line per image format, a longer format which shows the state of the processing, and a format which prints the image names only (used to create files containing lists of images of a particular CCD image type). To get a quick listing type: .nf cl> ccdlist *.imh ccd001.imh[544,512][short][unknown][][V]:FOCUS L98-193 ccd007.imh[544,512][short][object][][V]:N2968 V 600s ccd015.imh[544,512][short][object][][B]:N3098 B 500s ccd024.imh[544,512][short][object][][R]:N4036 R 600s ccd045.imh[544,512][short][flat][][V]:dflat 5s ccd066.imh[544,512][short][flat][][B]:dflat 5s ccd103.imh[544,512][short][flat][][R]:dflat 5s ccd104.imh[544,512][short][zero][][]:bias ccd105.imh[544,512][short][dark][][]:dark 3600s .fi The example shows only a sample of the images. The short format listing tells you the name of the image, its size and pixel type, the CCD image type as seen by the package, the amplifier identifier, the subset identifier (in this case the filter), and the title. If the data had been processed then there would also be processing flags. If the CCD image types do not seem right then there may be a problem with the instrument specification. Many of the tasks in the \fBccdred\fR package have the parameter \fIccdtype\fR which selects a particular type of image. To list only the object images from the previous example: .nf cl> ccdlist *.imh ccdtype=object ccd007.imh[544,512][short][object][][V]:N2968 V 600s ccd015.imh[544,512][short][object][][B]:N3098 B 500s ccd024.imh[544,512][short][object][][R]:N4036 R 600s .fi If no CCD image type is specified (by using the null string "") then all image types are selected. This may be necessary if your instrument data does not contain image type identifications. .sh 3.1 Combining Calibration Images If you do not need to combine calibration images because you only have one image of each type, you can skip this section. Calibration images, particularly zero level and flat field images, are combined in order to minimize the effects of noise and reject bad pixels in the calibrations. The basic tool for combining images is the task \fBcombine\fR. There are simple variants of this task whose default parameters are set appropriately for each type of calibration image. These are the ones you will use for calibration images leaving \fBcombine\fR for combining object images. Zero level images are combined with \fBzerocombine\fR, dark count images with \fBdarkcombine\fR, and flat field images with \fBflatcombine\fR. For example, to combine flat field images the command is: .nf cl> flatcombine *.imh Jun 1 14:26 combine: maxreject Images N Exp Mode Scale Offset Weight ccd045.imh 1 5.0 INDEF 1.000 0. 0.048 ccd046.imh 1 5.0 INDEF 1.000 0. 0.048 <... list of files ...> ccd065.imh 1 5.0 INDEF 1.000 0. 0.048 ----------- ------ ------ FlatV.imh 21 5.0 .fi This output is printed when verbose mode is set. The same information is recorded in the log file. In this case the flat fields are combined by rejecting the maximum value at each point in the image (the "maxreject" algorithm). The images are scaled by the exposure times, which are all the same in this example. The mode is not evaluated for exposure scaling and the relative weights are the same because the exposure times are the same. The example only shows part of the output; \fBflatcombine\fR automatically groups the flat field images by filter to produce the calibration images "FlatV", "FlatB", and "FlatR". .sh 3.2 Calibrations and Corrections Processing the CCD data is easy and largely automated. First, set the task parameters with the following command: cl> eparam ccdproc You may have already set the parameters when you ran \fBsetinstrument\fR, though the calibration image parameters \fIzero\fR, \fIdark\fR, and \fIflat\fR may still need to be set or changed. Once this is done simply give the command .nf cl> ccdproc *.imh ccd003: Jun 1 15:13 Overscan section is [520:540,*] with mean=485.0 ccd003: Jun 1 15:14 Trim data section is [3:510,3:510] ccd003: Jun 1 15:14 Overscan section is [520:540,*] with mean=485.0 FlatV: Jun 1 15:14 Trim data section is [3:510,3:510] FlatV: Jun 1 15:15 Overscan section is [520:540,*] with mean=486.4 ccd003: Jun 1 15:15 Flat field image is FlatV.imh with scale=138.2 ccd004: Jun 1 15:16 Trim data section is [3:510,3:510] ccd004: Jun 1 15:16 Overscan section is [520:540,*] with mean=485.2 ccd004: Jun 1 15:16 Flat field image is FlatV.imh with scale=138.2 <... more ...> ccd013: Jun 1 15:22 Trim data section is [3:510,3:510] ccd013: Jun 1 15:23 Overscan section is [520:540,*] with mean=482.4 FlatB: Jun 1 15:23 Trim data section is [3:510,3:510] FlatB: Jun 1 15:23 Overscan section is [520:540,*] with mean=486.4 ccd013: Jun 1 15:24 Flat field image is FlatB.imh with scale=132.3 <... more ...> .fi The output shown is with verbose mode set. It is the same as recorded in the log file. It illustrates the principle of automatic calibration image processing. The first object image, "ccd003", was being processed when the flat field image was required. Since the image was taken with the V filter the appropriate flat field was determined to be "FlatV". Since it had not been processed, the processing of "ccd003" was interrupted to process "FlatV". The processed calibration image may have been cached if there was enough memory. Once "FlatV" was processed (note that the flat field was not flattened because the task knows this image is a flat field) the processing of "ccd003" was completed. The next image, "ccd004", is also a V filter image so the already processed, and possibly cached, flat field "FlatV" is used again. The first B band image is "ccd013" and, as before, the B filter flat field calibration image is processed automatically. The same automatic calibration processing and image caching occurs when using zero level and dark count calibration images. Commonly the processing is done with the verbose mode turned off and the task run as a background job. This is done with the commands .nf cl> ccdred.verbose=no cl> ccdproc *.imh & .fi The already processed images in the input list are recognized as having been processed and are not affected. To check the status of the processing we can look at the end of the log file with: cl> tail logfile After processing we can repeat the \fBccdlist\fR command to find: .nf cl> ccdlist *.imh ccdtype=object ccd007.imh[508,508][real][object][V][OTF]:N2968 V 600s ccd015.imh[508,508][real][object][B][OTF]:N3098 B 500s ccd024.imh[544,512][short][object][R][OTF]:N4036 R 600s .fi The processing flags indicate the images have been overscan corrected, trimmed, and flat fielded. As you can see, processing images is very easy. There is one source of minor confusion for beginning users and that is dealing with calibration images. First, there is no reason that calibration images may not be processed explicitly with \fBccdproc\fR, just remember to set the \fIccdtype\fR to the calibration image type or to "". When processing object images the calibration images to be used may be specified either with the task parameter for the particular calibration image or by including the calibration image in the list of input images. Calibration images specified by parameter value take precedence and the task does not check its CCD image type. Calibration images given in the input list must have a valid CCD image type. In case too many calibration images are specified, say because the calibration images combined to make the master calibration images were not deleted and so are part of the image list "*.imh", only the first one will be used. All the calibration image types may be combined by amplifier. Another point to know is that flat field, illumination, and fringe images are subset (filter) dependent and so a calibration image for each filter must be specified. .sh 4. Special Processing Operations The special processing operations are mostly concerned with the flat field response correction. There are also special processing operations available in \fBccdproc\fR for one dimensional readout corrections in the zero level and flat field calibrations. These were described briefly above and in more detail in \fBccdproc\fR and are not discussed further in this guide. The processing operations described in this section are for preparing flat fields for two dimensional spectroscopic data, for correcting flat fields for illuminations effects, for making a separate illumination correction, and for applying corrections for fringe effects. For additional discussion about flat fields and illumination corrections see the help topic \fBflatfields\fR. .sh 4.1 Spectroscopic Flat Fields For spectroscopic data the flat fields may have to be processed to remove the general shape of the lamp spectrum and to replace regions outside of the aperture where there is no flat field information with values that will not cause bad response effects when the flat field is applied to the data. If the shape of the lamp spectrum is not important and if the longslit spectra have the regions outside of the slit either off the detector or trimmed then you may use the flat field without special processing. First you must process the flat field images explicitly with cl> ccdproc *.imh ccdtype=flat where "*.imh" may be replaced with any list containing the flat fields. If zero level and dark count corrections are required these calibration images must be available at this time. Load the \fBtwodspec\fR package and then either the \fBlongslit\fR package, for longslit data, or the \fBapextract\fR package, for multiaperture data such as echelles, multifiber, or aperture mask spectra. The task for removing the longslit quartz spectrum is \fBresponse\fR. There is also a task for removing illumination effects, including the slit profile, from longslit spectra called \fBillumination\fR. For more about processing longslit spectra see the help for these tasks and the paper \fIReduction of Longslit Spectra with IRAF\fR. The cookbook \fIReduction of Longslit Spectroscopic Data Using IRAF (KPNO ICCD and Cryogenic Camera Data)\fR also provides a very good discussion even if your data is from a different instrument. For multiaperture data the task for removing the relative shapes of the spectra is called \fBapnormalize\fR. Again, consult the help documentation for this task for further details. Since you will probably also be using the package for extracting the spectra you may be interested in the document \fIThe IRAF APEXTRACT Package\fR. .sh 4.2 Illumination Corrections The flat field calibration images may not have the same illumination pattern as the observations of the sky due to the way the lamp illuminates the optical system. In this case when the flat field correction is applied to the data there will be gradients in the sky background. To remove these gradients a blank sky calibration image is heavily smoothed to produce an illumination image. The illumination image is then divided into the images during processing to correct for the illumination difference between the flat field and the objects. Like the flat fields, the illumination corrections images may be subset dependent so there should be an illumination image for each subset. The task which makes illumination correction images is \fBmkskycor\fR. Some examples are .nf cl> mkskycor sky004 Illum004 cl> mkskycor sky*.imh "" .fi In the first example the sky image "sky004" is used to make the illumination correction image "Illum004". In the second example the sky images are converted to illumination correction images by specifying no output image names. Like \fBccdproc\fR if the input images have not been processed they are first processed automatically. To apply the illumination correction .nf cl> ccdproc *.imh ccdtype=object illumcor+ illum=Illum004 cl> ccdproc *.imh ccdtype=object illumcor+ illum=sky*.imh .fi The illumination images could also be set using \fBeparam\fR or given on the command line. .sh 4.3 Sky Flat Fields You will notice that when you process images with an illumination correction you are dividing each image by a flat field calibration and an illumination correction. If the illumination corrections are not done as a later step but at the same time as the rest of the processing one will get the same calibration by multiplying the flat field by the illumination correction and using this product alone as the flat field. Such an image is called a \fIsky flat\fR since it is a flat field which has been corrected to yield a flat sky when applied to the observations. This approach has the advantage of one less calibration image and two less computations (scaling and dividing the illumination correction). As an added short cut, rather than compute the illumination image with \fBmkskycor\fR and then multiplying, the task \fBmkskyflat\fR does all this in one step. Thus, \fBmkskyflat\fR takes an input blank sky image, processes it if needed, determines the appropriate flat field (sky flats are also subset dependent) from the \fBccdproc\fR parameters or the input image list, and produces an output sky flat. Further if no output image is specified the task converts the input blank sky calibration image into a sky flat. Two examples in which a new image is created and in which the input images are converted to sky flats are .nf cl> mkskyflat sky004 Skyflat cl> mkskyflat sky*.imh "" .fi .sh 4.4 Illumination Corrected Flat Fields A third method to account for illumination problems in the flat fields is to remove the large scale pattern from the flat field itself. This is useful if there are no reasonable blank sky calibration images and the astronomical exposures are evenly illuminated but the flat fields are not. This is done by smoothing the flat field images instead of blank sky images. As with using the sky images there are two methods, creating an illumination correction to be applied as a separate step or fixing the original flat field. The smoothing algorithm is the same as that used in the other tasks. The tasks to make these types of corrections are \fBmkillumcor\fR and \fBmkillumflat\fR. The usage is pretty much the same as the other illumination correction tasks except that it is more reasonable to replace the original flat fields by the corrected flat fields when fixing the flat field. Examples of an illumination correction and removing the illumination pattern from the flat field are .nf cl> mkillumcor flat025 Illum025 cl> mkillumflat flat*.imh "" .fi As with the other tasks, the input images are processed if necessary. .sh 4.5 Fringe Corrections Some CCD detectors suffer from fringing effects due to the night sky emission lines which are not removed by the other calibration and correction operations. To correct for the fringing you need a really blank sky image. There is not yet a task to remove objects from sky images because this is often done with an interactive image display tool (which will soon be added). The blank sky image is heavily smoothed to determine the mean sky background and then this is subtracted from the original image. The image should then be essentially zero except for the fringe pattern. This fringe correction image is scaled to the same exposure time as the image to be corrected and then subtracted to remove the fringing. Note that since the night sky lines are variable there may need to be an additional scaling applied. Determining this scaling requires either an interactive display tool or a very clever task. Such tasks will also be added in the future. The task to make a fringe correction image is \fBmkfringecor\fR. the sky background is determined in exactly the same way as the illumination pattern, in fact the same sky image may be used for both the sky illumination and for the fringe correction. The task works consistently with the "mk" tasks in that the input images are processed first if needed and then the output correction image is produced with the specified name or replaces the input image if no output image is specified. As examples, .nf cl> mkfringecor sky004 Fringe cl> mkfringecor sky*.imh "" .fi .sh 5. Demonstration A simple demonstration task is available. To run this demonstration load the \fBccdtest\fR package; this is a subpackage of the main \fBccdred\fR package. Then simply type cl> demo The demonstration will then create some artificial CCD data and reduce them giving descriptive comments as it goes along. This demonstration uses the "playback" facility of the command language and is actually substituting it's own commands for terminal input. Initially you must type carriage return or space after each comment ending with "...". If you wish to have the demonstration run completely automatically at it's own speed then type 'g' a the "..." prompt. Thereafter, it will simple pause long enough to give you a chance to read the comments. When the demo is finished you will need to remove the files created. However, feel free to examine the reduced images, the log file, etc. \fINote that the demonstration changes the setup parameters so be sure to run \fBsetinstrument\fI again and check the setup parameters.\fR .sh 6. Summary The \fBccdred\fR package is very easy to use. First load the package; it is in the \fBimred\fR package which is in the \fBnoao\fR package. If this is your first time reducing data from a particular instrument or if you have changed instruments then run \fBsetinstrument\fR. Set the processing parameters for the operations you want performed. If you need to combine calibration images to form a master calibration image use one of the combine tasks. Spectroscopic flat fields may need to be processed first in order to remove the lamp spectrum. Finally, just type cl> ccdproc *.imh& .sh 7. References A general guide to using IRAF is \fIA User's Introduction to the IRAF Command Language\fR. This document may be found in the IRAF documentation sets and is available from the National Optical Astronomy Observatories, Central Computer Services (NOAO-CCS). A more detailed description of the \fBccdred\fR package including a discussion of the design and some of the algorithms see \fIThe IRAF CCD Reduction Package -- CCDRED\fR" by F. Valdes. This paper is available from NOAO-CCS and appears in the proceedings of the Santa Cruz Summer Workshop in Astronomy and Astrophysics, \fIInstrumentation for Ground-Based Optical Astronomy: Present and Future\fR, edited by Lloyd B. Robinson and published by Springer-Verlag. The task descriptions and supplementary documentation are available in printed form in the IRAF documentation sets, a special set containing documentation for just the \fBccdred\fR package, and on-line through the help task by typing cl> help \fItopic\fR where \fItopic\fR is one of the following. .nf badpiximage - Create a bad pixel mask image from a bad pixel file ccdgroups - Group CCD images into image lists ccdhedit - CCD image header editor ccdlist - List CCD processing information ccdproc - Process CCD images ccdtest - CCD test and demonstration package combine - Combine CCD images cosmicrays - Detect and replace cosmic rays darkcombine - Combine and process dark count images flatcombine - Combine and process flat field images mkfringecor - Make fringe correction images from sky images mkillumcor - Make flat field illumination correction images mkillumflat - Make illumination corrected flat fields mkskycor - Make sky illumination correction images mkskyflat - Make sky corrected flat field images setinstrument - Set instrument parameters zerocombine - Combine and process zero level images ADDITIONAL HELP TOPICS ccdred - CCD image reduction package ccdtypes - Description of the CCD image types flatfields - Discussion of CCD flat field calibrations guide - Introductory guide to using the CCDRED package instruments - Instrument specific data files subsets - Description of CCD subsets .fi Printed copies of the on-line help documentation may be made with the command cl> help topic | lprint In addition to the package documentation for \fBccdred\fR, \fBlongslit\fR, and \fBapextract\fR there may be specific guides for certain instruments. These specific guides, called "cookbooks", give specific examples and parameter values for the CCD data. .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/guide.ms000066400000000000000000001114161332166314300202100ustar00rootroot00000000000000.RP .TL User's Guide to the CCDRED Package .AU Francisco Valdes .AI IRAF Group - Central Computer Services .K2 P.O. Box 26732, Tucson, Arizona 85726 June 1987 Revised February 1988 .AB The IRAF CCD reduction package, \fBccdred\fR, provides tools for the easy and efficient reduction of CCD images. The standard reduction operations are replacement of bad pixels, subtraction of an overscan or prescan bias, subtraction of a zero level image, subtraction of a dark count image, division by a flat field calibration image, division by an illumination correction, subtraction of a fringe image, and trimming unwanted lines or columns. Another common operation provided by the package is scaling and combining images with a number of algorithms for rejecting cosmic rays. Data in the image header is used to make the reductions largely automated and self-documenting though the package may still be used in the absence of this data. Also a translation mechanism is used to relate image header parameters to those used by the package to allow data from a variety of observatories and instruments to be processed. This guide provides a brief description of the IRAF CCD reduction package and examples of reducing simple CCD data. .AE .NH Introduction .LP This guide provides a brief description of the IRAF CCD reduction package \fBccdred\fR and examples of reducing simple CCD data. It is a generic guide in that it is not tied to any particular type of data. There may be more specific guides (or "cookbooks") for your data. Detailed descriptions of the tasks and features of the package are provided in the help documentation for the package. The purpose of the CCDRED package is to provide tools for the easy and efficient reduction of CCD images. The standard reduction operations are replacement of bad columns and lines by interpolation from neighboring columns and lines, subtraction of a bias level determined from overscan or prescan columns or lines, subtraction of a zero level using a zero length exposure calibration image, subtraction of a dark count calibration image appropriately scaled to the dark time exposure, division by a scaled flat field calibration image, division by an illumination image (derived from a blank sky image), subtraction of a scaled fringe image (also derived from a blank sky image), and trimming the image of unwanted lines or columns such as the overscan strip. Any set of operations may be done simultaneously over a list of images in a highly efficient manner. The reduction operations are recorded in the image header and may also be logged on the terminal and in a log file. The package also provides tools for combining multiple exposures of object and calibration images to improve the statistical accuracy of the observations and to remove transient bad pixels. The combining operation scales images of different exposure times, adjusts for variable sky background, statistically weights the images by their signal-to-noise, and provides a number of useful algorithms for detecting and rejecting transient bad pixels. Other tasks are provided for listing reduction information about the images, deriving secondary calibration images (such as sky corrected flat fields or illumination correction images), and easily setting the package parameters for different instruments. There are several important features provided by the package to make the reduction of CCD images convenient; particularly to minimize record keeping. One of these is the ability to recognize the different types of CCD images. This ability allows the user to select a certain class of images to be processed or listed and allows the processing tasks to identify calibration images and process them differently from object images. The standard CCD image types are \fIobject\fR, \fIzero\fR level, \fIdark\fR count, and \fIflat\fR field. For more on the image types see \fBccdtypes\fR. The tasks can also identify the different filters (or other subset parameter) which require different flat field images. This means you don't have to separate the images by filter and process each set separately. This feature is discussed further in \fBsubsets\fR. The tasks keep track of the reduction steps completed on each image and ignore images which have been processed. This feature, along with recognizing the image types and subsets, makes it possible to specify all the images to a task with a wildcard template, such as "*.imh", rather than indicating each image by name. You will find this extremely important with large sets of observations. A fundamental aspect of the package is that the processing modifies the images. In other words, the reduction operations are performed directly on the image. This "feature" further simplifies record keeping, frees the user from having to form unique output image names, and minimizes the amount of disk space required. There are two safety features in this process. First, the modifications do not take effect until the operation is completed on the image. This allows you to abort the task without messing up the image data and protects data if the computer crashes. The second feature is that there is a package parameter which may be set to make a backup of the input data with a particular prefix such as "orig" or "imdir$". This backup feature may be used when there is sufficient disk space, when learning to use the package, or just to be cautious. In a similar effort to efficiently manage disk space, when combining images into a master object or calibration image there is an option to delete the input images upon completion of the combining operation. Generally this is desirable when there are many calibration exposures, such as zero level or flat field images, which are not used after they are combined into a final calibration image. The following sections guide you through the basic use of the \fBccdred\fR package. Only the important parameters which you might want to change are described. It is assumed that the support personnel have created the necessary instrument files (see \fBinstruments\fR) which will set the default parameters for the data you will be reducing. If this is not the case you may need to delve more deeply into the details of the tasks. Information about all the parameters and how the various tasks operate are given in the help documentation for the tasks and in additional special help topics. Some useful help documentation is indicated in the discussion and also in the \fBReferences\fR section. .NH Getting Started .LP The first step is to load \fBccdred\fR. This is done by loading the \fBnoao\fR package, followed by the image reduction package \fBimred\fR, and finally the \fBccdred\fR package. Loading a package consists of typing its name. Note that some of these packages may be loaded automatically when you logon to IRAF. When you load the \fBccdred\fR package the menu of tasks or commands is listed. This appears as follows: .nf .KS .ft L cl> ccdred badpiximage ccdtest mkfringecor setinstrument ccdgroups combine mkillumcor zerocombine ccdhedit cosmicrays mkillumflat ccdlist darkcombine mkskycor ccdproc flatcombine mkskyflat .ft R .KE .fi A summary of the tasks and additional help topics is obtained by typing: .ft L cl> help .ft R This list and how to get additional help on specific topics is described in the \fBReferences\fR section at the end of this guide. The first command to use is \fBsetinstrument\fR, which sets the package appropriately for the CCD images to be reduced. The support personnel should tell you the instrument identification, but if not a list of known instruments may be listed by using '?' for the instrument name. .nf .ft L cl> setinstrument Instrument ID (type ? for a list) \fI .ft R .fi This task sets the default parameters and then allows you to modify the package parameters and the processing parameters using the parameter editor \fBeparam\fR. If you are not familiar with \fBeparam\fR see the help or CL introduction documentation. For most terminals you move up and down through the parameters with the terminal arrow keys, you change the parameters by simply typing the desired value, and you exit with control Z or control D. Note that you can change parameters for any task at any time with \fBeparam\fR and you do not have to run \fBsetinstrument\fR again, even if you logout, until you need to reduce data from a different instrument. The \fBccdred\fR package parameters control general I/O functions of the tasks in the package. The parameters you might wish to change are the output pixel type and the verbose option. Except when the input images are short integers, the noise is significantly greater than one digital unit, and disk space is critical, it is probably better to allow the processing to convert the images to real pixel datatype. The verbose parameter simply prints the information written to the log file on the terminal. This can be useful when little else is being done and you are just beginning. However, when doing background processing and other IRAF reduction tasks it is enough to simply look at the end of the logfile with the task \fBtail\fR to see the current state of the processing. The \fBccdproc\fR parameters control the CCD processing. There are many parameters but they all may be conveniently set at this point. Many of the parameters have default values set appropriately for the instrument you specified. The images to be processed can be specified later. What needs to be set are the processing operations that you want done and the parameters required for each operation. The processing operations are selected by entering yes or no for each one. The following items briefly describe each of the possible processing operations and the additional parameters required. .LP \fIoverscan\fR - Apply overscan strip correction? .IP The overscan or prescan region is specified by the parameter \fIbiassec\fR. This is given as an IRAF image section. Only the part of the section corresponding to the readout axis is used and the other part is ignored. The length of the overscan region is set by the \fItrimsec\fR parameter. The overscan region is averaged along the readout axis, specified by the parameter \fIreadaxis\fR, to create a one dimensional bias vector. This bias is fit by a function to remove cosmic rays and noise. There are a number of parameters at the end of the parameter list which control the fitting. The default overscan bias section and fitting parameters for your instrument should be set by \fBsetinstrument\fR. An image header keyword may be used to define the overscan bias section by using the syntax !. If an overscan section is not set you can use \fBimplot\fR to determine the columns or rows for the bias region and define an overscan image section. If you are unsure about image sections consult with someone or read the introductory IRAF documentation. .LP \fItrim\fR - Trim the image? .IP The image is trimmed to the image section given by the parameter \fItrimsec\fR. A default trim section for your instrument should be set by \fBsetinstrument\fR, however, you may override this default if desired. An image header keyword may be used to define the overscan bias section by using the syntax !. As with the overscan image section it is straightforward to specify, but if you are unsure consult someone. .LP \fIfixpix\fR - Fix bad CCD lines and columns? .IP The bad pixels (cosmetic defects) in the detector are given in a bad pixel mask specified by the parameter \fIfixfile\fR. This information is used to replace the pixels by interpolating from the neighboring pixels. A standard file for your instrument may be set by \fBsetinstrument\fR or if the word "BPM" is given then the file is obtain from the image header under the keyword "BPM". An image header keyword may be specified with the syntax ! where is an image header keyword. The bad pixel masks are matched to the input by amplifier. For more on the bad pixel mask see \fBinstruments\fR. .LP \fIzerocor\fR - Apply zero level correction? .IP The zero level image to be subtracted is specified by the parameter \fIzero\fR. An image header keyword may be specified with the syntax ! where is an image header keyword. If none is given then the calibration image will be sought in the list of images to be processed. The zero calibration images are matched to the input by amplifier. .LP \fIdarkcor\fR - Apply dark count correction? .IP The dark count image to be subtracted is specified by the parameter \fIdark\fR. An image header keyword may be specified with the syntax ! where is an image header keyword. If none is given then the calibration image will be sought in the list of images to be processed. The dark count calibration images are matched to the input by amplifier. .LP \fIflatcor\fR - Apply flat field correction? .IP The flat field images to be used are specified by the parameter \fIflat\fR. An image header keyword may be specified with the syntax ! where is an image header keyword. There must be one flat field image for each amplifier and subset (see \fBsubsets\fR) to be processed. If a flat field image is not given then the calibration image will be sought in the list of images to be processed. .LP \fIreadcor\fR - Convert zero level image to readout correction? .IP If a one dimensional zero level readout correction vector is to be subtracted instead of a two dimensional zero level image then, when this parameter is set, the zero level images will be averaged to one dimension. The readout axis must be specified by the parameter \fIreadaxis\fR. The default for your instrument is set by \fBsetinstrument\fR. .LP \fIscancor\fR - Convert flat field image to scan correction? .IP If the instrument is operated in a scan mode then a correction to the flat field may be required. There are two types of scan modes, "shortscan" and "longscan". In longscan mode flat field images will be averaged to one dimension and the readout axis must be specified. Shortscan mode is a little more complicated. The scan correction is used if the flat field images are not observed in scan mode. The number of scan lines must be specified by the parameter \fInscan\fR. If they are observed in scan mode, like the object observations, then the scan correction operations should \fInot\fR be specified. For details of scan mode operations see \fBccdproc\fR. The scan parameters should be set by \fBsetinstrument\fR. If in doubt consult someone familiar with the instrument and mode of operation. .LP This description of the parameters is longer than the actual operation of setting the parameters. The only parameters likely to change during processing are the calibration image parameters. When processing many images using the same calibration files a modest performance improvement can be achieved by keeping (caching) the calibration images in memory to avoid disk accesses. This option is available by specifying the amount of memory available for image caching with the parameter \fImax_cache\fR. If the value is zero then the images are accessed from disk as needed while if there is sufficient memory the calibration images may be kept in memory during the task execution. .NH Processing Your Data .LP The processing path depends on the type of data, the type of instrument, types of calibration images, and the observing sequence. In this section we describe two types of operations common in reducing most data; combining calibration images and performing the standard calibration and correction operations. Some additional special operations are described in the following section. However, the first thing you might want to try before any processing is to get a listing of the CCD images showing the CCD image types, amplifiers, subsets, and processing flags. The task for this is \fBccdlist\fR. It has three types of of output; a short one line per image format, a longer format which shows the state of the processing, and a format which prints the image names only (used to create files containing lists of images of a particular CCD image type). To get a quick listing type: .nf .ft L cl> ccdlist *.imh ccd001.imh[544,512][short][unknown][][V]:FOCUS L98-193 ccd007.imh[544,512][short][object][][V]:N2968 V 600s ccd015.imh[544,512][short][object][][B]:N3098 B 500s ccd024.imh[544,512][short][object][][R]:N4036 R 600s ccd045.imh[544,512][short][flat][][V]:dflat 5s ccd066.imh[544,512][short][flat][][B]:dflat 5s ccd103.imh[544,512][short][flat][][R]:dflat 5s ccd104.imh[544,512][short][zero][][]:bias ccd105.imh[544,512][short][dark][][]:dark 3600s .ft R .fi The example shows only a sample of the images. The short format listing tells you the name of the image, its size and pixel type, the CCD image type as seen by the package, the amplifier identifier, the subset identifier (in this case the filter), and the title. If the data had been processed then there would also be processing flags. If the CCD image types do not seem right then there may be a problem with the instrument specification. Many of the tasks in the \fBccdred\fR package have the parameter \fIccdtype\fR which selects a particular type of image. To list only the object images from the previous example: .nf .ft L cl> ccdlist *.imh ccdtype=object ccd007.imh[544,512][short][object][][V]:N2968 V 600s ccd015.imh[544,512][short][object][][B]:N3098 B 500s ccd024.imh[544,512][short][object][][R]:N4036 R 600s .ft R .fi If no CCD image type is specified (by using the null string "") then all image types are selected. This may be necessary if your instrument data does not contain image type identifications. .NH 2 Combining Calibration Images .LP If you do not need to combine calibration images because you only have one image of each type, you can skip this section. Calibration images, particularly zero level and flat field images, are combined in order to minimize the effects of noise and reject bad pixels in the calibrations. The basic tool for combining images is the task \fBcombine\fR. There are simple variants of this task whose default parameters are set appropriately for each type of calibration image. These are the ones you will use for calibration images leaving \fBcombine\fR for combining object images. Zero level images are combined with \fBzerocombine\fR, dark count images with \fBdarkcombine\fR, and flat field images with \fBflatcombine\fR. For example, to combine flat field images the command is: .nf .ft L cl> flatcombine *.imh Jun 1 14:26 combine: maxreject Images N Exp Mode Scale Offset Weight ccd045.imh 1 5.0 INDEF 1.000 0. 0.048 ccd046.imh 1 5.0 INDEF 1.000 0. 0.048 \fI<... list of files ...>\fL ccd065.imh 1 5.0 INDEF 1.000 0. 0.048 ----------- ------ ------ FlatV.imh 21 5.0 .ft R .fi This output is printed when verbose mode is set. The same information is recorded in the log file. In this case the flat fields are combined by rejecting the maximum value at each point in the image (the "maxreject" algorithm). The images are scaled by the exposure times, which are all the same in this example. The mode is not evaluated for exposure scaling and the relative weights are the same because the exposure times are the same. The example only shows part of the output; \fBflatcombine\fR automatically groups the flat field images by filter to produce the calibration images "FlatV", "FlatB", and "FlatR". .NH 2 Calibrations and Corrections .LP Processing the CCD data is easy and largely automated. First, set the task parameters with the following command: .ft L cl> eparam ccdproc .ft R You may have already set the parameters when you ran \fBsetinstrument\fR, though the calibration image parameters \fIzero\fR, \fIdark\fR, and \fIflat\fR may still need to be set or changed. Once this is done simply give the command .nf .ft L cl> ccdproc *.imh ccd003: Jun 1 15:13 Overscan section is [520:540,*] with mean=485.0 ccd003: Jun 1 15:14 Trim data section is [3:510,3:510] ccd003: Jun 1 15:14 Overscan section is [520:540,*] with mean=485.0 FlatV: Jun 1 15:14 Trim data section is [3:510,3:510] FlatV: Jun 1 15:15 Overscan section is [520:540,*] with mean=486.4 ccd003: Jun 1 15:15 Flat field image is FlatV.imh with scale=138.2 ccd004: Jun 1 15:16 Trim data section is [3:510,3:510] ccd004: Jun 1 15:16 Overscan section is [520:540,*] with mean=485.2 ccd004: Jun 1 15:16 Flat field image is FlatV.imh with scale=138.2 \fI<... more ...>\fL ccd013: Jun 1 15:22 Trim data section is [3:510,3:510] ccd013: Jun 1 15:23 Overscan section is [520:540,*] with mean=482.4 FlatB: Jun 1 15:23 Trim data section is [3:510,3:510] FlatB: Jun 1 15:23 Overscan section is [520:540,*] with mean=486.4 ccd013: Jun 1 15:24 Flat field image is FlatB.imh with scale=132.3 \fI<... more ...>\fL .ft R .fi The output shown is with verbose mode set. It is the same as recorded in the log file. It illustrates the principle of automatic calibration image processing. The first object image, "ccd003", was being processed when the flat field image was required. Since the image was taken with the V filter the appropriate flat field was determined to be "FlatV". Since it had not been processed, the processing of "ccd003" was interrupted to process "FlatV". The processed calibration image may have been cached if there was enough memory. Once "FlatV" was processed (note that the flat field was not flattened because the task knows this image is a flat field) the processing of "ccd003" was completed. The next image, "ccd004", is also a V filter image so the already processed, and possibly cached, flat field "FlatV" is used again. The first B band image is "ccd013" and, as before, the B filter flat field calibration image is processed automatically. The same automatic calibration processing and image caching occurs when using zero level and dark count calibration images. Commonly the processing is done with the verbose mode turned off and the task run as a background job. This is done with the commands .nf .ft L cl> ccdred.verbose=no cl> ccdproc *.imh & .ft R .fi The already processed images in the input list are recognized as having been processed and are not affected. To check the status of the processing we can look at the end of the log file with: .ft L cl> tail logfile .ft R After processing we can repeat the \fBccdlist\fR command to find: .nf .ft L cl> ccdlist *.imh ccdtype=object ccd007.imh[508,508][real][object][V][OTF]:N2968 V 600s ccd015.imh[508,508][real][object][B][OTF]:N3098 B 500s ccd024.imh[544,512][short][object][R][OTF]:N4036 R 600s .ft R .fi The processing flags indicate the images have been overscan corrected, trimmed, and flat fielded. As you can see, processing images is very easy. There is one source of minor confusion for beginning users and that is dealing with calibration images. First, there is no reason that calibration images may not be processed explicitly with \fBccdproc\fR, just remember to set the \fIccdtype\fR to the calibration image type or to "". When processing object images the calibration images to be used may be specified either with the task parameter for the particular calibration image or by including the calibration image in the list of input images. Calibration images specified by parameter value take precedence and the task does not check its CCD image type. Calibration images given in the input list must have a valid CCD image type. In case too many calibration images are specified, say because the calibration images combined to make the master calibration images were not deleted and so are part of the image list "*.imh", only the first one will be used. All the calibration image types may be combined by amplifier. Another point to know is that flat field, illumination, and fringe images are subset (filter) dependent and so a calibration image for each filter must be specified. .NH Special Processing Operations .LP The special processing operations are mostly concerned with the flat field response correction. There are also special processing operations available in \fBccdproc\fR for one dimensional readout corrections in the zero level and flat field calibrations. These were described briefly above and in more detail in \fBccdproc\fR and are not discussed further in this guide. The processing operations described in this section are for preparing flat fields for two dimensional spectroscopic data, for correcting flat fields for illuminations effects, for making a separate illumination correction, and for applying corrections for fringe effects. For additional discussion about flat fields and illumination corrections see the help topic \fBflatfields\fR. .NH 2 Spectroscopic Flat Fields .LP For spectroscopic data the flat fields may have to be processed to remove the general shape of the lamp spectrum and to replace regions outside of the aperture where there is no flat field information with values that will not cause bad response effects when the flat field is applied to the data. If the shape of the lamp spectrum is not important and if the longslit spectra have the regions outside of the slit either off the detector or trimmed then you may use the flat field without special processing. First you must process the flat field images explicitly with .ft L cl> ccdproc *.imh ccdtype=flat .ft R where "*.imh" may be replaced with any list containing the flat fields. If zero level and dark count corrections are required these calibration images must be available at this time. Load the \fBtwodspec\fR package and then either the \fBlongslit\fR package, for longslit data, or the \fBapextract\fR package, for multiaperture data such as echelles, multifiber, or aperture mask spectra. The task for removing the longslit quartz spectrum is \fBresponse\fR. There is also a task for removing illumination effects, including the slit profile, from longslit spectra called \fBillumination\fR. For more about processing longslit spectra see the help for these tasks and the paper \fIReduction of Longslit Spectra with IRAF\fR. The cookbook \fIReduction of Longslit Spectroscopic Data Using IRAF (KPNO ICCD and Cryogenic Camera Data)\fR also provides a very good discussion even if your data is from a different instrument. For multiaperture data the task for removing the relative shapes of the spectra is called \fBapnormalize\fR. Again, consult the help documentation for this task for further details. Since you will probably also be using the package for extracting the spectra you may be interested in the document \fIThe IRAF APEXTRACT Package\fR. .NH 2 Illumination Corrections .LP The flat field calibration images may not have the same illumination pattern as the observations of the sky due to the way the lamp illuminates the optical system. In this case when the flat field correction is applied to the data there will be gradients in the sky background. To remove these gradients a blank sky calibration image is heavily smoothed to produce an illumination image. The illumination image is then divided into the images during processing to correct for the illumination difference between the flat field and the objects. Like the flat fields, the illumination corrections images may be subset dependent so there should be an illumination image for each subset. The task which makes illumination correction images is \fBmkskycor\fR. Some examples are .nf .ft L cl> mkskycor sky004 Illum004 cl> mkskycor sky*.imh "" .ft R .fi In the first example the sky image "sky004" is used to make the illumination correction image "Illum004". In the second example the sky images are converted to illumination correction images by specifying no output image names. Like \fBccdproc\fR if the input images have not been processed they are first processed automatically. To apply the illumination correction .nf .ft L cl> ccdproc *.imh ccdtype=object illumcor+ illum=Illum004 cl> ccdproc *.imh ccdtype=object illumcor+ illum=sky*.imh .ft R .fi The illumination images could also be set using \fBeparam\fR or given on the command line. .NH 2 Sky Flat Fields .LP You will notice that when you process images with an illumination correction you are dividing each image by a flat field calibration and an illumination correction. If the illumination corrections are not done as a later step but at the same time as the rest of the processing one will get the same calibration by multiplying the flat field by the illumination correction and using this product alone as the flat field. Such an image is called a \fIsky flat\fR since it is a flat field which has been corrected to yield a flat sky when applied to the observations. This approach has the advantage of one less calibration image and two less computations (scaling and dividing the illumination correction). As an added short cut, rather than compute the illumination image with \fBmkskycor\fR and then multiplying, the task \fBmkskyflat\fR does all this in one step. Thus, \fBmkskyflat\fR takes an input blank sky image, processes it if needed, determines the appropriate flat field (sky flats are also subset dependent) from the \fBccdproc\fR parameters or the input image list, and produces an output sky flat. Further if no output image is specified the task converts the input blank sky calibration image into a sky flat. Two examples in which a new image is created and in which the input images are converted to sky flats are .nf .ft L cl> mkskyflat sky004 Skyflat cl> mkskyflat sky*.imh "" .ft R .fi .NH 2 Illumination Corrected Flat Fields .LP A third method to account for illumination problems in the flat fields is to remove the large scale pattern from the flat field itself. This is useful if there are no reasonable blank sky calibration images and the astronomical exposures are evenly illuminated but the flat fields are not. This is done by smoothing the flat field images instead of blank sky images. As with using the sky images there are two methods, creating an illumination correction to be applied as a separate step or fixing the original flat field. The smoothing algorithm is the same as that used in the other tasks. The tasks to make these types of corrections are \fBmkillumcor\fR and \fBmkillumflat\fR. The usage is pretty much the same as the other illumination correction tasks except that it is more reasonable to replace the original flat fields by the corrected flat fields when fixing the flat field. Examples of an illumination correction and removing the illumination pattern from the flat field are .nf .ft L cl> mkillumcor flat025 Illum025 cl> mkillumflat flat*.imh "" .ft R .fi As with the other tasks, the input images are processed if necessary. .NH 2 Fringe Corrections .LP Some CCD detectors suffer from fringing effects due to the night sky emission lines which are not removed by the other calibration and correction operations. To correct for the fringing you need a really blank sky image. There is not yet a task to remove objects from sky images because this is often done with an interactive image display tool (which will soon be added). The blank sky image is heavily smoothed to determine the mean sky background and then this is subtracted from the original image. The image should then be essentially zero except for the fringe pattern. This fringe correction image is scaled to the same exposure time as the image to be corrected and then subtracted to remove the fringing. Note that since the night sky lines are variable there may need to be an additional scaling applied. Determining this scaling requires either an interactive display tool or a very clever task. Such tasks will also be added in the future. The task to make a fringe correction image is \fBmkfringecor\fR. the sky background is determined in exactly the same way as the illumination pattern, in fact the same sky image may be used for both the sky illumination and for the fringe correction. The task works consistently with the "mk" tasks in that the input images are processed first if needed and then the output correction image is produced with the specified name or replaces the input image if no output image is specified. As examples, .nf .ft L cl> mkfringecor sky004 Fringe cl> mkfringecor sky*.imh "" .ft R .fi .NH Demonstration .LP A simple demonstration task is available. To run this demonstration load the \fBccdtest\fR package; this is a subpackage of the main \fBccdred\fR package. Then simply type .ft L cl> demo .ft R The demonstration will then create some artificial CCD data and reduce them giving descriptive comments as it goes along. This demonstration uses the "playback" facility of the command language and is actually substituting it's own commands for terminal input. Initially you must type carriage return or space after each comment ending with "...". If you wish to have the demonstration run completely automatically at it's own speed then type 'g' a the "..." prompt. Thereafter, it will simple pause long enough to give you a chance to read the comments. When the demo is finished you will need to remove the files created. However, feel free to examine the reduced images, the log file, etc. \fINote that the demonstration changes the setup parameters so be sure to run \fBsetinstrument\fI again and check the setup parameters.\fR .NH Summary .LP The \fBccdred\fR package is very easy to use. First load the package; it is in the \fBimred\fR package which is in the \fBnoao\fR package. If this is your first time reducing data from a particular instrument or if you have changed instruments then run \fBsetinstrument\fR. Set the processing parameters for the operations you want performed. If you need to combine calibration images to form a master calibration image use one of the combine tasks. Spectroscopic flat fields may need to be processed first in order to remove the lamp spectrum. Finally, just type .ft L cl> ccdproc *.imh& .ft R .SH References .LP A general guide to using IRAF is \fIA User's Introduction to the IRAF Command Language\fR. This document may be found in the IRAF documentation sets and is available from the National Optical Astronomy Observatories, Central Computer Services (NOAO-CCS). A more detailed description of the \fBccdred\fR package including a discussion of the design and some of the algorithms see \fIThe IRAF CCD Reduction Package -- CCDRED\fR" by F. Valdes. This paper is available from NOAO-CCS and appears in the proceedings of the Santa Cruz Summer Workshop in Astronomy and Astrophysics, \fIInstrumentation for Ground-Based Optical Astronomy: Present and Future\fR, edited by Lloyd B. Robinson and published by Springer-Verlag. The task descriptions and supplementary documentation are available in printed form in the IRAF documentation sets, a special set containing documentation for just the \fBccdred\fR package, and on-line through the help task by typing .ft L cl> help \fItopic\fR .ft R where \fItopic\fR is one of the following. .nf .ft L badpiximage - Create a bad pixel mask image from a bad pixel file ccdgroups - Group CCD images into image lists ccdhedit - CCD image header editor ccdlist - List CCD processing information ccdproc - Process CCD images ccdtest - CCD test and demonstration package combine - Combine CCD images cosmicrays - Detect and replace cosmic rays darkcombine - Combine and process dark count images flatcombine - Combine and process flat field images mkfringecor - Make fringe correction images from sky images mkillumcor - Make flat field illumination correction images mkillumflat - Make illumination corrected flat fields mkskycor - Make sky illumination correction images mkskyflat - Make sky corrected flat field images setinstrument - Set instrument parameters zerocombine - Combine and process zero level images ADDITIONAL HELP TOPICS ccdred - CCD image reduction package ccdtypes - Description of the CCD image types flatfields - Discussion of CCD flat field calibrations guide - Introductory guide to using the CCDRED package instruments - Instrument specific data files subsets - Description of CCD subsets .ft R .fi Printed copies of the on-line help documentation may be made with the command .ft L cl> help \fItopic\fL | lprint .ft R In addition to the package documentation for \fBccdred\fR, \fBlongslit\fR, and \fBapextract\fR there may be specific guides for certain instruments. These specific guides, called "cookbooks", give specific examples and parameter values for the CCD data. mscred-5.05-2018.07.09/src/ccdred/doc/instruments.hlp000066400000000000000000000241041332166314300216470ustar00rootroot00000000000000.help instruments Aug96 noao.imred.ccdred .ih NAME instruments -- Instrument specific data files .ih DESCRIPTION The \fBccdred\fR package has been designed to accomodate many different instruments, detectors, and observatories. This is done by having instrument specific data files. Note that by instrument we mean a combination of detector, instrument, application, and observatory, so there might be several "instruments" associated with a particular CCD detector. Creating and maintaining the instrument files is generally the responsiblity of the support staff, though the user may create or copy and modify his/her own instrument/application specific files. The task \fBsetinstrument\fR makes this information available to the user and package easily. There are three instrument data files, all of which are optional. The package may be used without the instrument files but much of the convenience of the package, particularly with respect to using the CCD image types, will be lost. The three files are an instrument image header translation file, an initialization task which mainly sets default task parameters, and a bad pixel file identifying the cosmic bad pixels in the detector. These files are generally stored in a system data directory which is a subdirectory of the logical directory "ccddb$". Each file has a root name which identifies the instrument. .sh 1. Instrument Translation File The instrument translation file translates the parameter names used by the \fBccdred\fR pacakge into instrument specific parameters and also supplies instrument specific default values. The package parameter \fIccdred.instrument\fR specifies this file to the package. The task \fBsetinstrument\fR sets this parameter, though it can be set explicitly like any other parameter. For the standard instrument translation file the root name is the instrument identification and the extension is "dat" ("*.dat" files are protected from being removed in a "stripped" system, i.e. when all nonessential files are removed). Private instrument files may be given any name desired. The instrument translation proceeds as follows. When a package task needs a parameter for an image, for example "imagetyp", it looks in the instrument translation file. If the file is not found or none is specified then the image header keyword that is requested has the same name. If an instrument translation file is defined then the requested parameter is translated to an image header keyword, provided a translation entry is given. If no translation is given the package name is used. For example the package parameter "imagetyp" might be translated to "data-typ" (the old NOAO CCD keyword). If the parameter is not found then the default value specified in the translation file, if present, is returned. For recording parameter information in the header, such as processing flags, the translation is also used. The default value has no meaning in this case. For example, if the flag specifying that the image has been corrected by a flat field is to be set then the package parameter name "flatcor" might be translated to "ff-flag". If no translation is given then the new image header parameter is entered as "flatcor". The format of the translation file are lines consisting of the package parameter name, followed by the image header keyword, followed by the default value. The first two fields are parameter names. The fields are separated by whitespace (blanks and tabs). String default values containing blanks must be quoted. An example is given below. .nf # Sample translation file. exptime itime darktime itime imagetyp data-typ amp ampid subset f1pos biassec biassec [411:431,2:573] datasec datasec [14:385,2:573] fixpix bp-flag 0 overscan bt-flag 0 zerocor bi-flag 0 darkcor dk-flag 0 flatcor ff-flag 0 fringcor fr-flag 0 .fi The first comment line is ignored as are blank lines. The first two lines translate the exposure and dark times. The next three lines translate the CCD image type, the amplifier, and the subset parameter without default values (see \fBccdtypes\fR and \fBsubsets\fR for more information). The next two lines give the overscan bias strip section and the data section with default values for the instrument. Note that these parameters may be overridden in the task \fBccdproc\fR. The next set of translations requires further discussion. For processing flags the package assumes that the absence of a keyword means that the processing has not been done. If processing is always to be done with the \fBCCDRED\fR package and no processing keywords are recorded in the raw data then these parameters should be absent (unless you don't like the names used by the package). However, for compatibility with the original NOAO CCD images, which may be processed outside of IRAF and which use 0 as the no processing value, the processing flags are translated and the false values are indicated by the default values. If there is more than one translation for the same CCDRED parameter, for example more than one exptime, then the last one is used. In addition to the parameter name translations the translation file contains translations between the value of the image type parameter and the image types used by the package. These lines consist of the image header type string as the first field (with quotes if there are blanks) and the image type as recognized by the package. The following example will make this clearer. .nf 'OBJECT (0)' object 'DARK (1)' dark 'PROJECTOR FLAT (2)' flat 'SKY FLAT (3)' other 'COMPARISON LAMP (4)' other 'BIAS (5)' zero 'DOME FLAT (6)' flat .fi The values of the image type strings in the header contain blanks so they are quoted. Also the case of the strings is important. Note that there are two types of flat field images and three types of object images. The CCD image types recognized by the package are: .nf mask - bad pixel mask zero - zero level image such as a bias or preflash dark - dark count image flat - flat field image illum - illumination image such as a sky image fringe - fringe correction image object - object image .fi There may be more than one image type that maps to the same package type. In particular other standard CCD image types, such as comparison spectra, multiple exposure, standard star, etc., should be mapped to object or other. There may also be more than one type of flat field, i.e. dome flat, sky flat, and lamp flat. For more on the CCD image types see \fBccdtypes\fR. The complete set of package parameters are given below. The package parameter names are generally the same as the standard image header keywords being adopted by NOAO. .nf General Image Header and Default Parameters ccdmean darktime exptime fixfile imagetyp ncombine biassec subset title datasec nscanrow amp CCDRED Processing Flags ccdproc darkcor fixpix flatcor fringcor illumcor overscan trim zerocor CCDRED CCD Image Types dark flat fringe illum none object unknown zero mask .fi The translation mechanism described here may become more sophisticated in the future and a general IRAF system facility may be implemented eventually. For the present the translation mechanism is quite simple. .sh 2. Instrument Setup Script The task \fBsetinstrument\fR translates an instrument ID into a CL script in the instrument directory. This script is then executed. Generally this script simply sets the task parameters for an instrument/application. However, it could do anything else the support staff desires. Below are the first few lines of a typical instrument setup script. .nf ccdred.instrument = "ccddb$kpno/example.dat" ccdred.pixeltype = "real" ccdproc.overscan = yes ccdproc.trim = yes ccdproc.fixpix = yes ccdproc.zerocor = no ccdproc.darkcor = no ccdproc.flatcor = yes ccdproc.biassec = "[411:431,2:573]" ccdproc.datasec = "[14:385,2:573]" .fi The instrument parameter should always be set unless there is no translation file for the instrument. The \fBccdproc\fR parameters illustrate setting the appropriate processing flags for the instrument. The overscan bias and trim data sections show an alternate method of setting these instrument specific parameters. They may be set in the setup script in which case they are given explicitly in the user parameter list for \fBccdproc\fR. If the value is "image" then the parameters may be determined either through the default value in the instrument translation file, as illustrated in the previous section, or from the image header itself. The instrument setup script for setting default task parameters may be easily created by the support person as follows. Set the package parameters using \fBeparam\fR or with CL statements. Setting the parameters might involve testing. When satisified with the way the package is set then the parameters may be dumped to a setup script using the task \fBdparam\fR. The final step is editing this script to delete unimportant and query parameters. For example, .nf cl> dparam ccdred >> file.cl cl> dparam ccdproc >> file.cl cl> dparam combine >> file.cl ... cl> ed file.cl .fi .sh 3. Instrument Bad Pixel Masks The bad pixel masks describe the bad pixels, columns, and lines in the detector which are to be replaced by interpolation when processing the images. The mask is detector specific. Several types of masks are allowed. A pixel list (.pl) format file consists of zero for good pixels and positive non-zero for bad pixels. A regular image file may also be used. It will be treated as an integer image (i.e. real values will be truncated) and zero values denote good pixels and positive non-zero values denote bad pixels. The final format is a text file specifying individual pixels or rectangular regions. Each line of the file has either two values, a column and line for a single pixel, or four values, a starting and ending column and a starting and ending line. A region may have the starting and ending values be the same to specify a pixel, line, or column. .ih SEE ALSO ccdtypes, subsets, setinstrument .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/mkfringecor.hlp000066400000000000000000000071161332166314300215660ustar00rootroot00000000000000.help mkfringecor Feb88 noao.imred.ccdred .ih NAME mkfringecor -- Make fringe correction images from sky images .ih USAGE mkfringecor input output .ih PARAMETERS .ls input List of input images for making fringe correction images. .le .ls output List of output fringe correction images. If none is specified or if the name is the same as the input image then the output image replaces the input image. .le .ls ccdtype = "" CCD image type to select from the input images. If none is specified then all types are used. .le .ls xboxmin = 5, xboxmax = 0.25, yboxmin = 5, yboxmax = 0.25 Minimum and maximum smoothing box size along the x and y axes. The minimum box size is used at the edges and grows to the maximum size in the middle of the image. This allows the smoothed image to better represent gradients at the edge of the image. If a size is less then 1 then it is interpreted as a fraction of the image size. If a size is greater than or equal to 1 then it is the box size in pixels. A size greater than the size of image selects a box equal to the size of the image. .le .ls clip = yes Clean the input images of objects? If yes then a clipping algorithm is used to detect and exclude objects from the smoothing. .le .ls lowsigma = 2.5, highsigma = 2.5 Sigma clipping thresholds above and below the smoothed background. .le .ls ccdproc (parameter set) CCD processing parameters. .le .ih DESCRIPTION The input blank sky images are automatically processed up through the illumination correction before computing the fringe correction images. The fringe corrections are subset dependent. The slowly varying background is determined and subtracted leaving only the fringe pattern caused by the sky emission lines. These fringe images are then scaled and subtracted from the observations by \fBccdproc\fR. The background is determined by heavily smoothing the image using a moving "boxcar" average. The effects of the objects and fringes in the image is minimized by using a sigma clipping algorithm to detect and exclude them from the average. Note, however, that objects left in the fringe image will affect the fringe corrected observations. Any objects in the sky image should be removed using \fBskyreplace\fR (not yet available). The smoothing algorithm is a moving average over a two dimensional box. The algorithm is unconvential in that the box size is not fixed. The box size is increased from the specified minimum at the edges to the maximum in the middle of the image. This permits a better estimate of the background at the edges, while retaining the very large scale smoothing in the center of the image. Note that the sophisticated tools of the \fBimages\fR package may be used for smoothing but this requires more of the user and, for the more sophisticated smoothing algorithms such as surface fitting, more processing time. To minimize the effects of the fringes and any objects in the blank sky calibration images a sigma clipping algorithm is used to detect and exclude features from the background. This is done by computing the rms of the image lines relative to the smoothed background and excluding points exceeding the specified threshold factors times the rms. This is done before each image line is added to the moving average, except for the first few lines where an iterative process is used. .ih EXAMPLES 1. The two examples below make an fringe correction image from a blank sky image, "sky017". In the first example a separate fringe image is created and in the second the fringe image replaces the sky image. .nf cl> mkskycor sky017 Fringe cl> mkskycor sky017 frg017 .fi .ih SEE ALSO ccdproc .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/mkillumcor.hlp000066400000000000000000000076721332166314300214450ustar00rootroot00000000000000.help mkillumcor Oct88 noao.imred.ccdred .ih NAME mkillumcor -- Make flat field illumination correction images .ih USAGE mkillumcor input output .ih PARAMETERS .ls input List of input images for making flat field illumination correction images. .le .ls output List of output flat field illumination correction images. If none is specified or if the name is the same as the input image then the output image replaces the input image. .le .ls ccdtype = "flat" CCD image type to select from the input images. If none is specified then all types are used. .le .ls xboxmin = 5, xboxmax = 0.25, yboxmin = 5, yboxmax = 0.25 Minimum and maximum smoothing box size along the x and y axes. The minimum box size is used at the edges and grows to the maximum size in the middle of the image. This allows the smoothed image to better represent gradients at the edge of the image. If a size is less then 1 then it is interpreted as a fraction of the image size. If a size is greater than or equal to 1 then it is the box size in pixels. A size greater than the size of image selects a box equal to the size of the image. .le .ls clip = yes Clean the input images of objects? If yes then a clipping algorithm is used to detect and exclude deviant points from the smoothing. .le .ls lowsigma = 2.5, highsigma = 2.5 Sigma clipping thresholds above and below the smoothed illumination. .le .ls divbyzero = 1. The illumination correction is the inverse of the smoothed flat field. This may produce division by zero. A warning is given if division by zero takes place and the result (the illumination correction value) is replaced by the value of this parameter. .le .ls ccdproc (parameter set) CCD processing parameters. .le .ih DESCRIPTION First, the input flat field images are automatically processed if needed. Then, the large scale illumination pattern of the images is determined by heavily smoothing them using a moving "boxcar" average. The illumination correction, the inverse of the illumination pattern, is applied by \fBccdproc\fR to CCD images to remove the illumination pattern introduced by the flat field. The combination of the flat field calibration and the illumination correction based on the flat field is equivalent to removing the illumination from the flat field (see \fBmkillumflat\fR). This two step calibration is generally used when the observations have been previously flat field calibrated. This task is closely related to \fBmkskycor\fR which determines the illumination correction from a blank sky image; this is preferable to using the illumination from the flat field as it corrects for the residual illumination error. For a general discussion of the options for flat fields and illumination corrections see \fBflatfields\fR. The smoothing algorithm is a moving average over a two dimensional box. The algorithm is unconvential in that the box size is not fixed. The box size is increased from the specified minimum at the edges to the maximum in the middle of the image. This permits a better estimate of the background at the edges, while retaining the very large scale smoothing in the center of the image. Note that the sophisticated tools of the \fBimages\fR package may be used for smoothing but this requires more of the user and, for the more sophisticated smoothing algorithms such as surface fitting, more processing time. To minimize the effects of bad pixels a sigma clipping algorithm is used to detect and reject these pixels from the illumination. This is done by computing the rms of the image lines relative to the smoothed illumination and excluding points exceeding the specified threshold factors times the rms. This is done before each image line is added to the moving average, except for the first few lines where an iterative process is used. .ih EXAMPLES 1. The example below makes an illumination correction image from the flat field image, "flat017". cl> mkillumcor flat017 Illum .ih SEE ALSO ccdproc, flatfields, mkillumflat, mkskycor, mkskyflat .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/mkillumflat.hlp000066400000000000000000000103371332166314300216000ustar00rootroot00000000000000.help mkillumflat Oct88 noao.imred.ccdred .ih NAME mkillumflat -- Make illumination corrected flat fields .ih USAGE mkillumflat input output .ih PARAMETERS .ls input List of input flat field images to be illumination corrected. .le .ls output List of output illumination corrected flat field images. If none is specified or if the name is the same as the input image then the output image replaces the input image. .le .ls ccdtype = "flat" CCD image type to select from the input images. .le .ls xboxmin = 5, xboxmax = 0.25, yboxmin = 5, yboxmax = 0.25 Minimum and maximum smoothing box size along the x and y axes. The minimum box size is used at the edges and grows to the maximum size in the middle of the image. This allows the smoothed image to better represent gradients at the edge of the image. If a size is less then 1 then it is interpreted as a fraction of the image size. If a size is greater than or equal to 1 then it is the box size in pixels. A size greater than the size of image selects a box equal to the size of the image. .le .ls clip = yes Clean the input images of objects? If yes then a clipping algorithm is used to detect and exclude objects from the smoothing. .le .ls lowsigma = 2.5, highsigma = 2.5 Sigma clipping thresholds above and below the smoothed illumination. .le .ls divbyzero = 1. The illumination flat field is the ratio of the the flat field to a smoothed flat field. This may produce division by zero. A warning is given if division by zero takes place and the result (the illumination corrected flat field value) is replaced by the value of this parameter. .le .ls ccdproc (parameter set) CCD processing parameters. .le .ih DESCRIPTION First, the input flat field images are processed as needed. Then the large scale illumination pattern of the images is removed. The illumination pattern is determined by heavily smoothing the image using a moving "boxcar" average. The output image is the ratio of the input image to the illumination pattern. The illumination pattern is normalized by its mean to preserve the mean level of the input image. When this task is applied to flat field images only the small scale response effects are retained. This is appropriate if the flat field images have illumination effects which differ from the astronomical images and blank sky images are not available for creating sky corrected flat fields. When a high quality blank sky image is available the related task \fBmkskyflat\fR should be used. Note that the illumination correction, whether from the flat field or a sky image, may be applied as a separate step by using the task \fBmkillumcor\fR or \fBmkskycor\fR and applying the illumination correction as a separate operation in \fBccdproc\fR. However, creating an illumination corrected flat field image before processing is more efficient since one less operation per image processed is needed. For more discussion about flat fields and illumination corrections see \fBflatfields\fR. The smoothing algorithm is a moving average over a two dimensional box. The algorithm is unconvential in that the box size is not fixed. The box size is increased from the specified minimum at the edges to the maximum in the middle of the image. This permits a better estimate of the background at the edges, while retaining the very large scale smoothing in the center of the image. Note that the sophisticated tools of the \fBimages\fR package may be used for smoothing but this requires more of the user and, for the more sophisticated smoothing algorithms such as surface fitting, more processing time. To minimize the effects of bad pixels a sigma clipping algorithm is used to detect and reject these pixels from the illumination. This is done by computing the rms of the image lines relative to the smoothed illumination and excluding points exceeding the specified threshold factors times the rms. This is done before each image line is added to the moving average, except for the first few lines where an iterative process is used. .ih EXAMPLES 1. Two examples in which a new image is created and in which the input flat fields are corrected in place are: .nf cl> mkllumflat flat004 FlatV cl> mkillumflat flat* "" .fi .ih SEE ALSO ccdproc, flatfields, mkfringecor, mkillumcor, mkskycor, mkskyflat .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/mkskycor.hlp000066400000000000000000000106431332166314300211210ustar00rootroot00000000000000.help mkskycor Feb88 noao.imred.ccdred .ih NAME mkskycor -- Make sky illumination correction images .ih USAGE mkskycor input output .ih PARAMETERS .ls input List of input images for making sky illumination correction images. .le .ls output List of output flat field illumination correction images. If none is specified or if the name is the same as the input image then the output image replaces the input image. .le .ls ccdtype = "" CCD image type to select from the input images. If none is specified then all types are used. .le .ls xboxmin = 5, xboxmax = 0.25, yboxmin = 5, yboxmax = 0.25 Minimum and maximum smoothing box size along the x and y axes. The minimum box size is used at the edges and grows to the maximum size in the middle of the image. This allows the smoothed image to better represent gradients at the edge of the image. If a size is less then 1 then it is interpreted as a fraction of the image size. If a size is greater than or equal to 1 then it is the box size in pixels. A size greater than the size of image selects a box equal to the size of the image. .le .ls clip = yes Clean the input images of objects? If yes then a clipping algorithm is used to detect and exclude objects from the smoothing. .le .ls lowsigma = 2.5, highsigma = 2.5 Sigma clipping thresholds above and below the smoothed illumination. .le .ls ccdproc (parameter set) CCD processing parameters. .le .ih DESCRIPTION The large scale illumination pattern of the input images, generally blank sky calibration images, is determined by heavily smoothing the image using a moving "boxcar" average. The effects of objects in the image may be minimized by using a sigma clipping algorithm to detect and exclude the objects from the average. This illumination image is applied by \fBccdproc\fR to CCD images to remove the illumination pattern. The input images are automatically processed up through flat field calibration before computing the illumination. The illumination correction is that needed to make the processed images flat over large scales. The input images are generally blank sky calibration images which have the same illumination and instrumental effects as the object observations. Object images may be used but removal of the objects may not be very good; particularly large, bright objects. For further discussion of flat fields and illumination corrections see \fBflatfields\fR. You will notice that when you process images with an illumination correction you are dividing each image by a flat field calibration and an illumination correction. If the illumination corrections are not done as a later step but at the same time as the rest of the processing one will get the same calibration by multiplying the flat field by the illumination correction and using this product alone as the flat field. This approach has the advantage of one less calibration image and two less computations (scaling and dividing the illumination correction). Such an image, called a \fIsky flat\fR, may be created by \fBmkskyflat\fR as an alternative to this task. The smoothing algorithm is a moving average over a two dimensional box. The algorithm is unconvential in that the box size is not fixed. The box size is increased from the specified minimum at the edges to the maximum in the middle of the image. This permits a better estimate of the background at the edges, while retaining the very large scale smoothing in the center of the image. Note that the sophisticated tools of the \fBimages\fR package may be used for smoothing but this requires more of the user and, for the more sophisticated smoothing algorithms such as surface fitting, more processing time. Blank sky images may not be completely blank so a sigma clipping algorithm may be used to detect and exclude objects from the illumination pattern. This is done by computing the rms of the image lines relative to the smoothed background and excluding points exceeding the specified threshold factors times the rms. This is done before each image line is added to the moving average, except for the first few lines where an iterative process is used. .ih EXAMPLES 1. The two examples below make an illumination image from a blank sky image, "sky017". In the first example a separate illumination image is created and in the second the illumination image replaces the sky image. .nf cl> mkskycor sky017 Illum cl> mkskycor sky017 sky017 .fi .ih SEE ALSO ccdproc, flatfields, mkillumcor, mkillumflat, mkskyflat .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/mkskyflat.hlp000066400000000000000000000116661332166314300212720ustar00rootroot00000000000000.help mkskyflat Feb88 noao.imred.ccdred .ih NAME mkskyflat -- Make sky corrected flat field images .ih USAGE mkskyflat input output .ih PARAMETERS .ls input List of blank sky images to be used to create sky corrected flat field calibration images. .le .ls output List of output sky corrected flat field calibration images (called sky flats). If none is specified or if the name is the same as the input image then the output image replaces the input image. .le .le .ls ccdtype = "" CCD image type to select from the input images. .le .ls xboxmin = 5, xboxmax = 0.25, yboxmin = 5, yboxmax = 0.25 Minimum and maximum smoothing box size along the x and y axes. The minimum box size is used at the edges and grows to the maximum size in the middle of the image. This allows the smoothed image to better represent gradients at the edge of the image. If a size is less then 1 then it is interpreted as a fraction of the image size. If a size is greater than or equal to 1 then it is the box size in pixels. A size greater than the size of image selects a box equal to the size of the image. .le .ls clip = yes Clean the input images of objects? If yes then a clipping algorithm is used to detect and exclude objects from the smoothing. .le .ls lowsigma = 2.5, highsigma = 2.5 Sigma clipping thresholds above and below the smoothed illumination. .le .ls ccdproc (pset) CCD processing parameter set. .le .ih DESCRIPTION A sky corrected flat field calibration image, called a sky flat, is a flat field that when applied to observations of the sky have no large scale gradients. Flat field images are generally obtained by exposures to lamps either illuminating the telescope field or a surface in the dome at which the telescope is pointed. Because the detector is not illuminated in the same way as an observation of the sky there may be large scale illumination patterns introduced into the observations with such a flat field. To correct this type of flat field a blank sky observation (which has been divided by the original flat field) is heavily smoothed to remove the noise leaving only the residual large scale illumination pattern. This illumination pattern is divided into the original flat field to remove this residual. The advantage of creating a sky flat field is that when processing the observations no additional operations are required. However, if the observations have already been processed with the original flat field then the residual illumination pattern of blank sky calibration images may be created as an illumination correction to be applied by \fBccdproc\fR. Such a correction is created by the task \fBmkskycor\fR. If a good blank sky image is not available then it may be desirable to remove the illumination pattern of the flat field image using \fBmkillumflat\fR or \fBmkillumcor\fR provided the sky observations are truly uniformly illuminated. For more on flat fields and illumination corrections see \fBflatfields\fR. The input, blank sky images are first processed, based on the \fBccdproc\fR parameters, if needed. These parameters also determine the flat field image to be used in making the sky flat. The residual illumination pattern is determined by heavily smoothing the image using a moving "boxcar" average. The effects of objects in the input image may be minimized by using a sigma clipping algorithm to detect and exclude the objects from the average. The output image is ratio of the flat field image, for the same subset as the input image, to the residual illumination pattern determined from the processed blank sky input image. The illumination pattern is normalized by its mean to preserve the mean level of the flat field image. The smoothing algorithm is a moving average over a two dimensional box. The algorithm is unconvential in that the box size is not fixed. The box size is increased from the specified minimum at the edges to the maximum in the middle of the image. This permits a better estimate of the background at the edges, while retaining the very large scale smoothing in the center of the image. Note that the sophisticated tools of the \fBimages\fR package may be used for smoothing but this requires more of the user and, for the more sophisticated smoothing algorithms such as surface fitting, more processing time. Blank sky images may not be completely blank so a sigma clipping algorithm may be used to detect and exclude objects from the illumination pattern. This is done by computing the rms of the image lines relative to the smoothed background and excluding points exceeding the specified threshold factors times the rms. This is done before each image line is added to the moving average, except for the first few lines where an iterative process is used. .ih EXAMPLES 1. Two examples in which a new image is created and in which the input sky images are converted to sky flats are: .nf cl> mkskyflat sky004 Skyflat cl> mkskyflat sky* "" .fi .ih SEE ALSO ccdproc, flatfields, mkfringecor, mkillumcor, mkillumflat, mkskycor .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/setinstrument.hlp000066400000000000000000000060301332166314300221760ustar00rootroot00000000000000.help setinstrument Oct87 noao.imred.ccdred .ih NAME setinstrument -- Set instrument parameters .ih USAGE setinstrument instrument .ih PARAMETERS .ls instrument Instrument identification for instrument parameters to be set. If '?' then a list of the instrument identifiers is printed. .le .ls site = "kpno" Site ID. .le .ls directory = "ccddb$" Instrument directory containing instrument files. The instrument files are found in the subdirectory given by the site ID. .le .ls review = yes Review the instrument parameters? If yes then \fBeparam\fR is run for the parameters of \fBccdred\fR and \fBccdproc\fR. .le .ls query Parameter query if initial instrument is not found. .le .ih DESCRIPTION The purpose of the task is to allow the user to easily set default parameters for a new instrument. The default parameters are generally defined by support personel in an instrument directory for a particular site. The instrument directory is the concatenation of the specified directory and the site. For example if the directory is "ccddb$" and the site is "kpno" then the instrument directory is "ccddb$kpno/". The user may have his own set of instrument files in a local directory. The current directory is used by setting the directory and site to the null string (""). The user specifies an instrument identifier. This instrument may be specific to a particular observatory, telescope, instrument, and detector. If the character '?' is specified or the instrument file is not found then a list of instruments in the instrument directory is produced by paging the file "instruments.men". The task then performs the following operations: .ls (1) If an instrument translation file with the name given by the instrument ID and the extension ".dat" is found then the instrument translation file parameter, \fIccdred.instrument\fR, is set to this file. If it does not exist then the user is queried again. Note that a null instrument, "", is allowed to set no translation file. .le .ls (2) If an instrument setup script with the name given by the instrument ID and the extension ".cl" is found then the commands in the file are executed (using the command \fIcl < script\fR. This script generally sets default parameters. .le .ls (3) If the review flag is set the task \fBeparam\fR is run to allow the user to examine and modify the parameters for the package \fBccdred\fR and task \fBccdproc\fR. .le .ih EXAMPLES 1. To get a list of the instruments; .nf cl> setinstrument ? [List of instruments] 2. To set the instrument and edit the processing parameters: cl> setinstrument ccdlink [Edit CCDRED parameters] [Edit CCDPROC parameters] 3. To use your own instrument translation file and/or setup script in your working directory. cl> setinst.site="" cl> setinst.dir="" cl> setinst myinstrument To make these files see help under \fBinstruments\fR. Copying and modifying system files is also straightforward. cl> copy ccddb$kpno/fits.dat . cl> edit fits.dat cl> setinst.site="" cl> setinst.dir="" cl> setinst fits .fi .ih SEE ALSO instruments, ccdred, ccdproc .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/subsets.hlp000066400000000000000000000075401332166314300207510ustar00rootroot00000000000000.help subsets Aug96 noao.imred.ccdred .ih NAME subsets -- Description of CCD subsets .ih DESCRIPTION The \fBccdred\fR package groups observations into subsets based on matching image header keyword values. There are currently two keywords used to group the CCD data. One groups all CCD types (see \fBccdtypes\fR) while the other applies only to object, flat field, illumination, and fringe images. The image header keywords used to identify the subsets are defined in the instrument translation file (see \fBinstruments\fR). The names used by the \fBccdred\fR package for these keywords are "amp" and "subset" which may be translated to any desired keyword. For example the translation file might contain the lines: .nf amp ampid subset filter .fi to group the observations by amplifier identification and by filter. The reason for grouping the observations is that the data may consists of multiple readouts from different amplifiers and CCDs as in a mosaic and there may be observations with different filters, apertures, grating settings, etc. The combining and processing of such data must apply to like data; i.e. only matching amplifier/CCD data should be combined and the flat field calibration should use the same amplifier/CCD and filter or grating setting. The \fBccdred\fR tasks allow specifying a large set of observations and provide the proper matching of the data. Each amp and subset value is assigned a short identifier. These are listed when using \fBccdlist\fR and are appended to a root name when combining images or using \fBccdgroup\fR. Because the keywords values in the image header may be any string there must be a mapping applied to generate unique identifiers. This mapping is defined in the files given by the package parameters \fIccdred.ampfile\fR and \fIccdred.ssfile\fR. The files consists of lines with two fields (except that comment lines may be included as a line by itself or following the second field): .nf 'keyword value' id .fi where the keyword value is the image header string and the id is the identifier. A field must be quoted if it contains blanks. The user may create these files to provide specific identifiers but generally they are created by the tasks. The tasks use the first word of the keyword value as the default identifier and a number is appended if the first word is not unique. The following steps define the identifiers: .ls (1) Search the mapping file, if present, for a matching keyword value and use the defined identifier if found. .le .ls (2) If there is no matching keyword value use the first word of the image header keyword value and, if it is not unique within the file, add successive integers until it is unique. .le .ls (3) If the identifier is not in the mapping file create the file and add an entry if necessary. .le .ih EXAMPLES 1. The subset file is "subsets" (the default). The subset parameter is translated to "f1pos" in the image header (the old NOAO CCD parameter) which is an integer filter position. After running a task, say "ccdlist *.imh" to cause all filters to be checked, the subset file contains: .nf '2' 2 '5' 5 '3' 3 .fi The order reflects the order in which the filters were encountered. Suppose the user wants to have more descriptive names then the subset file can be created or edited to the form: .nf # Sample translation file. '2' U '3' B '4' V .fi (This is only an example and does not mean these are standard filters.) 2. As another example suppose the image header parameter is "filter" and contains more descriptive strings. The subset file might become: .nf 'GG 385 Filter' GG 'GG 495 Filter' GG1 'RG 610 Filter' RG 'H-ALPHA' H_ALPHA .fi In this case use of the first word was not very good but it is unique. It is better if the filters are encoded with the thought that the first word will be used by \fBccdred\fR; it should be short and unique. .ih SEE ALSO instruments .endhelp mscred-5.05-2018.07.09/src/ccdred/doc/zerocombine.hlp000066400000000000000000000113051332166314300215670ustar00rootroot00000000000000.help zerocombine Aug91 noao.imred.ccdred .ih NAME zerocombine -- Combine and process zero level images .ih USAGE zerocombine input .ih PARAMETERS .ls input List of zero level images to combine. The \fIccdtype\fR parameter may be used to select the zero level images from a list containing all types of data. .le .ls output = "Zero" Output zero level root image name. .le .ls combine = "average" (average|median) Type of combining operation performed on the final set of pixels (after rejection). The choices are "average" or "median". The median uses the average of the two central values when the number of pixels is even. .le .ls reject = "minmax" (none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip) Type of rejection operation. See \fBcombine\fR for details. .le .ls ccdtype = "zero" CCD image type to combine. If no image type is given then all input images are combined. .le .ls process = no Process the input images before combining? .le .ls delete = no Delete input images after combining? Only those images combined are deleted. .le .ls scale = "none" (none|mode|median|mean|exposure) Multiplicative image scaling to be applied. The choices are none, scale by the mode, median, or mean of the specified statistics section, or scale by the exposure time given in the image header. .le .ls statsec = "" Section of images to use in computing image statistics for scaling. If no section is given then the entire region of the image is sampled (for efficiency the images are sampled if they are big enough). .le .ce Algorithm Parameters .ls nlow = 0, nhigh = 1 (minmax) The number of low and high pixels to be rejected by the "minmax" algorithm. .le .ls nkeep = 1 The minimum number of pixels to retain or the maximum number to reject when using the clipping algorithms (ccdclip, crreject, sigclip, avsigclip, or pclip). When given as a positive value this is the minimum number to keep. When given as a negative value the absolute value is the maximum number to reject. This is actually converted to a number to keep by adding it to the number of images. .le .ls mclip = yes (ccdclip, crreject, sigclip, avsigcliip) Use the median as the estimate for the true intensity rather than the average with high and low values excluded in the "ccdclip", "crreject", "sigclip", and "avsigclip" algorithms? The median is a better estimator in the presence of data which one wants to reject than the average. However, computing the median is slower than the average. .le .ls lsigma = 3., hsigma = 3. (ccdclip, crreject, sigclip, avsigclip, pclip) Low and high sigma clipping factors for the "ccdclip", "crreject", "sigclip", "avsigclip", and "pclip" algorithms. They multiply a "sigma" factor produced by the algorithm to select a point below and above the average or median value for rejecting pixels. The lower sigma is ignored for the "crreject" algorithm. .le .ls rdnoise = "0.", gain = "1.", snoise = "0." (ccdclip, crreject) CCD readout noise in electrons, gain in electrons/DN, and sensitivity noise as a fraction. These parameters are used with the "ccdclip" and "crreject" algorithms. The values may be either numeric or an image header keyword which contains the value. .le .ls pclip = -0.5 (pclip) Percentile clipping algorithm parameter. If greater than one in absolute value then it specifies a number of pixels above or below the median to use for computing the clipping sigma. If less than one in absolute value then it specifies the fraction of the pixels above or below the median to use. A positive value selects a point above the median and a negative value selects a point below the median. The default of -0.5 selects approximately the quartile point. See \fBcombine\fR for further details. .le .ls blank = 0. Output value to be used when there are no pixels. .le .ih DESCRIPTION The zero level images in the input image list are combined. The input images may be processed first if desired. The original images may be deleted automatically if desired. The output pixel datatype will be real. This task is a script which applies \fBccdproc\fR and \fBcombine\fR. The parameters and combining algorithms are described in detail in the help for \fBcombine\fR. This script has default parameters specifically set for zero level images and simplifies the combining parameters. There are other combining options not included in this task. For these additional features, such as thresholding, offseting, masking, and projecting, use \fBcombine\fR. .ih EXAMPLES 1. The image data contains four zero level images. To automatically select them and combine them as a background job using the default combining algorithm: cl> zerocombine ccd*.imh& .ih REVISIONS .ls ZEROCOMBINE V2.11 The images will be combined by amplifier. .le .ih SEE ALSO ccdproc, combine .endhelp mscred-5.05-2018.07.09/src/ccdred/flatcombine.cl000066400000000000000000000044201332166314300206040ustar00rootroot00000000000000# FLATCOMBINE -- Process and combine flat field CCD images. procedure flatcombine (input) string input {prompt="List of flat field images to combine"} file output="Flat" {prompt="Output flat field root name"} string combine="average" {prompt="Type of combine operation", enum="average|median"} string reject="avsigclip" {prompt="Type of rejection", enum="none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip"} string ccdtype="flat" {prompt="CCD image type to combine"} bool process=yes {prompt="Process images before combining?"} bool subsets=yes {prompt="Combine images by subset parameter?"} bool delete=no {prompt="Delete input images after combining?"} string scale="mode" {prompt="Image scaling", enum="none|mode|median|mean|exposure"} string statsec="" {prompt="Image section for computing statistics"} int nlow=1 {prompt="minmax: Number of low pixels to reject"} int nhigh=1 {prompt="minmax: Number of high pixels to reject"} int nkeep=1 {prompt="Minimum to keep (pos) or maximum to reject (neg)"} bool mclip=yes {prompt="Use median in sigma clipping algorithms?"} real lsigma=3. {prompt="Lower sigma clipping factor"} real hsigma=3. {prompt="Upper sigma clipping factor"} string rdnoise="0." {prompt="ccdclip: CCD readout noise (electrons)"} string gain="1." {prompt="ccdclip: CCD gain (electrons/DN)"} string snoise="0." {prompt="ccdclip: Sensitivity noise (fraction)"} real pclip=-0.5 {prompt="pclip: Percentile clipping parameter"} real blank=1. {prompt="Value if there are no pixels"} begin string ims, out ims = input out = output # Process images first if desired. if (process == YES) ccdproc (ims, output="", bpmasks="", ccdtype=ccdtype, noproc=no) # Combine the flat field images. combine (ims, output=out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigma="", imcmb="$I", combine=combine, reject=reject, ccdtype=ccdtype, amps=yes, subsets=subsets, delete=delete, project=no, outtype="real", outlimits="", offsets="none", masktype="none", blank=blank, scale=scale, zero="none", weight=no, statsec=statsec, lthreshold=INDEF, hthreshold=INDEF, nlow=nlow, nhigh=nhigh, nkeep=nkeep, mclip=mclip, lsigma=lsigma, hsigma=hsigma, rdnoise=rdnoise, gain=gain, snoise=snoise, sigscale=0.1, pclip=pclip, grow=0) end mscred-5.05-2018.07.09/src/ccdred/mkfringecor.par000066400000000000000000000010111332166314300210040ustar00rootroot00000000000000input,s,a,,,,Input CCD images output,s,h,"",,,Output fringe images (same as input if none given) ccdtype,s,h,"",,,CCD image type to select xboxmin,r,h,5,0.,,Minimum smoothing box size in x at edges xboxmax,r,h,0.25,0.,,Maximum smoothing box size in x yboxmin,r,h,5,0.,,Minimum moothing box size in y at edges yboxmax,r,h,0.25,0.,,Maximum moothing box size in y clip,b,h,yes,,,Clip input pixels? lowsigma,r,h,2.5,0.,,Low clipping sigma highsigma,r,h,2.5,0.,,High clipping sigma ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/ccdred/mkillumcor.par000066400000000000000000000010651332166314300206650ustar00rootroot00000000000000input,s,a,,,,Input CCD images output,s,a,,,,Output images (same as input if none given) ccdtype,s,h,"flat",,,CCD image type to select xboxmin,r,h,5,0.,,Minimum smoothing box size in x at edges xboxmax,r,h,0.25,0.,,Maximum smoothing box size in x yboxmin,r,h,5,0.,,Minimum smoothing box size in y at edges yboxmax,r,h,0.25,0.,,Maximum smoothing box size in y clip,b,h,yes,,,Clip input pixels? lowsigma,r,h,2.5,0.,,Low clipping sigma highsigma,r,h,2.5,0.,,High clipping sigma divbyzero,r,h,1.,,,Result for division by zero ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/ccdred/mkillumflat.par000066400000000000000000000010761332166314300210320ustar00rootroot00000000000000input,s,a,,,,Input CCD flat field images output,s,a,,,,Output images (same as input if none given) ccdtype,s,h,"flat",,,CCD image type to select xboxmin,r,h,5,0.,,Minimum smoothing box size in x at edges xboxmax,r,h,0.25,0.,,Maximum smoothing box size in x yboxmin,r,h,5,0.,,Minimum moothing box size in y at edges yboxmax,r,h,0.25,0.,,Maximum moothing box size in y clip,b,h,yes,,,Clip input pixels? lowsigma,r,h,2.5,0.,,Low clipping sigma highsigma,r,h,2.5,0.,,High clipping sigma divbyzero,r,h,1.,,,Result for division by zero ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/ccdred/mkpkg000066400000000000000000000012031332166314300170310ustar00rootroot00000000000000# Make CCDRED Package. $call lccdred $call relink $exit update: $call update@src $call relink $call install ; install: $move xx_ccdred.e mscbin$x_ccdred.e ; relink: $checkout x_ccdred.o mscbin$ $iffile (lib$libimc.a) $set LIBS = "-lccdred -limc -lxtools -lcurfit -lgsurfit -lncar -lgks" $else $set LIBS = "-lccdred -lcombine -lxtools -lcurfit -lgsurfit -lncar -lgks" $endif $omake x_ccdred.x $link x_ccdred.o $(LIBS) -o xx_ccdred.e $checkin x_ccdred.o mscbin$ ; lccdred: $checkout libccdred.a mscbin$ $update libccdred.a $checkin libccdred.a mscbin$ ; lcombine: $call lcombine@src ; libccdred.a: @src ; mscred-5.05-2018.07.09/src/ccdred/mkskycor.par000066400000000000000000000010001332166314300203360ustar00rootroot00000000000000input,s,a,,,,Input CCD images output,s,a,,,,Output images (same as input if none given) ccdtype,s,h,"",,,CCD image type to select xboxmin,r,h,5,0.,,Minimum smoothing box size in x at edges xboxmax,r,h,0.25,0.,,Maximum smoothing box size in x yboxmin,r,h,5,0.,,Minimum moothing box size in y at edges yboxmax,r,h,0.25,0.,,Maximum moothing box size in y clip,b,h,yes,,,Clip input pixels? lowsigma,r,h,2.5,0.,,Low clipping sigma highsigma,r,h,2.5,0.,,High clipping sigma ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/ccdred/mkskyflat.par000066400000000000000000000010001332166314300205010ustar00rootroot00000000000000input,s,a,,,,Input CCD images output,s,a,,,,Output images (same as input if none given) ccdtype,s,h,"",,,CCD image type to select xboxmin,r,h,5,0.,,Minimum smoothing box size in x at edges xboxmax,r,h,0.25,0.,,Maximum smoothing box size in x yboxmin,r,h,5,0.,,Minimum moothing box size in y at edges yboxmax,r,h,0.25,0.,,Maximum moothing box size in y clip,b,h,yes,,,Clip input pixels? lowsigma,r,h,2.5,0.,,Low clipping sigma highsigma,r,h,2.5,0.,,High clipping sigma ccdproc,pset,h,,,,CCD processing parameters mscred-5.05-2018.07.09/src/ccdred/setinstrument.cl000066400000000000000000000027241332166314300212520ustar00rootroot00000000000000# SETINSTRUMENT -- Set up instrument parameters for the CCD reduction tasks. # # This task sets default parameters based on an instrument ID. procedure setinstrument (instrument) char instrument {prompt="Instrument ID (type ? for a list)"} char site="kpno" {prompt="Site ID"} char directory="ccddb$" {prompt="Instrument directory"} bool review=yes {prompt="Review instrument parameters?"} char query {prompt="Instrument ID (type q to quit)", mode="q"} begin string inst, instdir, instmen, instfile # Define instrument directory, menu, and file instdir = directory if (site != "") instdir = instdir // site // "/" instmen = instdir // "instruments.men" inst = instrument instfile = instdir // inst // ".dat" # Loop until a valid instrument file is given. while (inst != "" && !access (instfile)) { if (access (instmen)) page (instmen) else if (inst == "?") print ("Instrument list ", instmen, " not found") else print ("Instrument file ", instfile, " not found") print ("") inst = query if (inst == "q") return instrument = inst instfile = instdir // inst // ".dat" } # Set instrument parameter. if (access (instfile)) ccdred.instrument = instfile else ccdred.instrument = "" # Run instrument setup script. instfile = instdir // inst // ".cl" if (access (instfile)) cl (< instfile) # Review parameters if desired. if (review) { eparam ("ccdred") eparam ("ccdproc") } end mscred-5.05-2018.07.09/src/ccdred/sflatcombine.cl000066400000000000000000000050731332166314300207740ustar00rootroot00000000000000# SFLATCOMBINE -- Process and combine images into a sky flat. procedure sflatcombine (input) string input {prompt="List of images to combine"} file output="Sflat" {prompt="Output sky flat field root name"} string combine="average" {prompt="Type of combine operation", enum="average|median"} string reject="avsigclip" {prompt="Type of rejection", enum="none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip"} string ccdtype="object" {prompt="CCD image type to combine"} bool subsets=yes {prompt="Combine images by subset parameter?"} string masktype = "none" {prompt="Mask type"} real maskvalue = 0. {prompt="Mask value"} string scale="mode" {prompt="Image scaling", enum="none|mode|median|mean|exposure"} string statsec="" {prompt="Image section for computing statistics"} int nkeep=1 {prompt="Minimum to keep (pos) or maximum to reject (neg)"} int nlow=1 {prompt="minmax: Number of low pixels to reject"} int nhigh=1 {prompt="minmax: Number of high pixels to reject"} bool mclip=yes {prompt="Use median in sigma clipping algorithms?"} real lsigma=6. {prompt="Lower sigma clipping factor"} real hsigma=3. {prompt="Upper sigma clipping factor"} string rdnoise="rdnoise" {prompt="ccdclip: CCD readout noise (electrons)"} string gain="gain" {prompt="ccdclip: CCD gain (electrons/DN)"} string snoise="0." {prompt="ccdclip: Sensitivity noise (fraction)"} real pclip=-0.5 {prompt="pclip: Percentile clipping parameter"} real blank=1. {prompt="Value if there are no pixels"} real grow=3. {prompt="Radius (pixels) for neighbor rejection", min=0.} begin string ims, out, temp ims = input out = output temp = mktemp ("tmp$iraf") # Check on images to combine. coutput (ims, out, temp, rejmask="", plfile="", sigma="", amps=yes, subsets=subsets) # Process images. ccdproc (ims, output="", bpmasks="", ccdtype=ccdtype, noproc=no, sflatcor=no) # Combine the images. combine (ims, output=out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigma="", imcmb="$I", combine=combine, reject=reject, ccdtype=ccdtype, amps=yes, subsets=subsets, delete=no, project=no, outtype="real", outlimits="", offsets="none", masktype=masktype, maskvalue=maskvalue, blank=blank, scale=scale, zero="none", weight=no, statsec=statsec, lthreshold=INDEF, hthreshold=INDEF, nlow=nlow, nhigh=nhigh, nkeep=nkeep, mclip=mclip, lsigma=lsigma, hsigma=hsigma, rdnoise=rdnoise, gain=gain, snoise=snoise, sigscale=0.1, pclip=pclip, grow=grow) # Set the image type. ccdhedit ("@"//temp, "imagetyp", "skyflat", type="string") delete (temp, verify-) end mscred-5.05-2018.07.09/src/ccdred/skyreplace.par000066400000000000000000000001351332166314300206460ustar00rootroot00000000000000image,f,a,,,,Image to be modified frame,i,h,1,,,Image display frame cursor,*gcur,h,,,,Cursor mscred-5.05-2018.07.09/src/ccdred/src/000077500000000000000000000000001332166314300165705ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/src/bleed.com000066400000000000000000000016121332166314300203430ustar00rootroot00000000000000int nc, nl #I Image size int c1, c2, l1, l2 #I Section (in output pixels) to be searched int ic1, il1 #I Offset between input and output images real sth #I Saturation threshold int sgrw #I Grow radius for saturated pixels int sval #I Saturated pixel mask value real bth #I Bleed pixel threshold int bgrw #I Grow radius for bleed pixels int bval #I Bleed trail mask value int tlen #I Minimum bleed trail length int nbehind #I Number of pixels behind line to buffer int nahead #I Number of pixels ahead of line to buffer int nbufs #I Number of output buffered lines pointer obufs #I Output data buffers pointer ombufs #I Output mask buffers pointer noibufs #I Fixpix data buffers pointer counts #I Array of bleed pixel counts. common /bleedcom/ nc, nl, c1, c2, l1, l2, ic1, il1, sth, sgrw, sval, bth, bgrw, bval, tlen, nbehind, nahead, nbufs, obufs, ombufs, noibufs, counts mscred-5.05-2018.07.09/src/ccdred/src/bleed.x000066400000000000000000000160411332166314300200360ustar00rootroot00000000000000include include # These routines must be used in a sequential pass through the image. # BLD_OPEN -- Initialize saturated pixel and bleed trail routines. # This includes memory allocation and initial line buffering. # The package parameters are passed in a common block. procedure bld_open (out, fdnoi, omask, bp, dointerp, sthresh, svalue, sgrow, bthresh, bvalue, bgrow, btrail, insec, outsec) pointer out #I Output image pointer fdnoi #I Output no interpolation image pointer omask #I Output mask pointer bp #I Input mask bool dointerp #I Are input pixels interpolated? real sthresh #I Saturation threshold int svalue #I Saturated pixel mask value int sgrow #I Number of pixels to grow saturated pixels real bthresh #I Threshold for candidate bleed pixels int bvalue #I Bleed trail mask value int bgrow #I Number of pixels to grow bleed pixels int btrail #I Minimum bleed trail length int insec[2,2] #I Input section int outsec[2,2] #I Output section int l pointer obuf pointer imgl2s() include "bleed.com" begin # Set parameters. if (out != NULL) { nc = IM_LEN(out,1) nl = IM_LEN(out,2) } else if (omask != NULL) { nc = IM_LEN(omask,1) nl = IM_LEN(omask,2) } else call error (1, "BLD_OPEN: No output specified") ic1 = insec[1,1] il1 = insec[1,2] c1 = outsec[1,1] c2 = outsec[2,1] l1 = outsec[1,2] l2 = outsec[2,2] if (IS_INDEFR(sthresh)) sth = MAX_REAL else sth = sthresh sval = svalue sgrw = sgrow bth = bthresh bval = bvalue bgrw = bgrow tlen = min (l2, btrail) nbehind = max (tlen + bgrw - 1, sgrw) nahead = max (bgrw, sgrw) nbufs = min (l2, 1 + nbehind + nahead) # Allocate memory and make it one indexed. if (out != NULL) call malloc (obufs, nc * nbufs, TY_REAL) else obufs = NULL if (fdnoi != NULL && dointerp) call malloc (noibufs, nc * nbufs, TY_REAL) else noibufs = NULL call malloc (ombufs, nc * nbufs, TY_SHORT) call malloc (counts, nc, TY_SHORT) obufs = obufs - 1 noibufs = noibufs - 1 ombufs = ombufs - 1 counts = counts - 1 # Set buffered grow lines. do l = l1, min (l2, nahead) { obuf = ombufs + nc * mod(l,nbufs) + 1 if (bp != NULL) call amovs (Mems[imgl2s(bp,l+il1-l1)+ic1-c1], Mems[obuf], nc) else call aclrs (Mems[obuf], nc) } # Initialize the bleed pixel counts. call aclrs (Mems[counts+1], nc) end # BLD_CLOSE -- Close the saturated pixel and bleed trail package. # This just consists of freeing buffer memory. procedure bld_close () include "bleed.com" begin # Free memory. obufs = obufs + 1 noibufs = noibufs + 1 ombufs = ombufs + 1 counts = counts + 1 call mfree (obufs, TY_REAL) call mfree (noibufs, TY_REAL) call mfree (ombufs, TY_SHORT) call mfree (counts, TY_SHORT) end # BLD_MASK -- Set mask of saturated and bleed trail pixels. # If an output descriptor is provided then write out the mask. procedure bld_mask (omask, l, data, bp) pointer omask #I Output mask int l #I Line real data[ARB] #I Data pointer bp #I Input mask int i, j, k, c pointer obuf, obufl, imgl2s(), impl2s() include "bleed.com" begin # Initialize next buffered output line. k = l + nahead if (k <= l2) { obuf = ombufs + nc * mod(k,nbufs) + 1 if (bp != NULL) call amovs (Mems[imgl2s(bp,k+il1-l1)+ic1-c1], Mems[obuf], nc) else call aclrs (Mems[obuf], nc) } # Find the saturation and bleed trails. Grow if required. obufl = ombufs + nc * mod(l,nbufs) do c = c1, c2 { # Saturated pixel? if (data[c] >= sth) { if (sgrw == 0) Mems[obufl+c] = sval else { do k = max(1,l-sgrw), min(l2,l+sgrw) { obuf = ombufs + nc * mod(k,nbufs) i = sgrw - abs (l - k) do j = max(1,c-i), min(nc,c+i) { if (Mems[obuf+j] == 0 || Mems[obuf+j] == bval) Mems[obuf+j] = sval } } } } # Bleed pixel? if (tlen < 1) next if (data[c] < bth) { Mems[counts+c] = 0 next } i = Mems[counts+c] + 1 Mems[counts+c] = i if (i < tlen) next if (i > tlen) { do k = l, min(l2,l+bgrw) { obuf = ombufs + nc * mod(k,nbufs) i = bgrw - abs (k - l) do j = max(1,c-i), min(nc,c+i) { if (Mems[obuf+j] == 0) Mems[obuf+j] = bval } } } else { do k = max(1,l-tlen-bgrw+1), min(l2,l+bgrw) { obuf = ombufs + nc * mod(k,nbufs) if (k < l - tlen + 1) i = bgrw - abs (l - tlen + 1 - k) else if (k > l) i = bgrw - abs (k - l) else i = bgrw do j = max(1,c-i), min(nc,c+i) { if (Mems[obuf+j] == 0) Mems[obuf+j] = bval } } } } # Write out completed line(s). if (omask != NULL) { j = l + nahead - nbufs + 1 if (l == l2) k = l2 else k = j do i = j, k { if (i < l1) next obuf = ombufs + nc * mod(i,nbufs) + 1 call amovs (Mems[obuf], Mems[impl2s(omask,i)], nc) } } end # BLD_INTERP -- Write output image with interpolated saturated and bleed pixels. # If desired also write an uninterpolated output image. # This is line interpolation only. # Only mask values for saturated or bleed trail pixels are interpolated. # However if an input mask was specified containing the same values # then those pixels will also be interpolated. procedure bld_interp (out, fdnoi, l, noidata, data) pointer out #I Output IMIO pointer pointer fdnoi #I Output no interpolation pointer int l #I Line pointer noidata #I Output data (without fixpix) real data[ARB] #I Output data (before interpolation) int i, j1, j2, k1, k2, c, mval real a, b pointer obuf, ombuf, noibuf, noibuf1, impl2r() include "bleed.com" begin if (out == NULL) return # Save the input data. if (noidata != NULL) { obuf = noibufs + nc * mod(l,nbufs) call amovr (Memr[noidata], Memr[obuf+1], nc) } obuf = obufs + nc * mod(l,nbufs) call amovr (data, Memr[obuf+1], nc) # Write out completed line. k1 = l + nahead - nbufs + 1 if (l == l2) k2 = l2 else k2 = k1 do i = k1, k2 { if (i < l1) next obuf = obufs + nc * mod(i,nbufs) noibuf1 = noibufs + nc * mod(i,nbufs) ombuf = ombufs + nc * mod(i,nbufs) if (fdnoi != NULL) { noibuf = impl2r (fdnoi, i) if (noibufs+1 != NULL) call amovr (Memr[noibuf1+1], Memr[noibuf], nc) else call amovr (Memr[obuf+1], Memr[noibuf], nc) } j1 = 0; j2 = 0 for (c=c1; c<=c2; c=c+1) { mval = Mems[ombuf+c] if (mval == 0) { j1 = c next } if (mval == sval || mval == bval) { if (j2 < c) { do j2 = c+1, nc { if (Mems[ombuf+j2] == 0) break } if (j1 < c1 && j2 > c2) break if (j1 < c1) { a = Memr[obuf+j2] b = 0 } else if (j2 > c2) { a = Memr[obuf+j1] b = 0 } else { a = Memr[obuf+j1] b = (Memr[obuf+j2] - a) / (j2 - j1) } } #Memr[obuf+c] = a + b * (c - j1) # The following is a design question. Should non-saturated # pixels be interpolated if they border a saturated # pixel? In this case we say yes. for (c=max(1,j1+1); c<=min(nc,j2-1); c=c+1) Memr[obuf+c] = a + b * (c - j1) } } call amovr (Memr[obuf+1], Memr[impl2r(out,i)], nc) } end mscred-5.05-2018.07.09/src/ccdred/src/calimage.com000066400000000000000000000002001332166314300210220ustar00rootroot00000000000000# Common for calibration images. pointer cal # Pointer calibration data int ncal # Number of images common /calib/ cal, ncal mscred-5.05-2018.07.09/src/ccdred/src/calimage.h000066400000000000000000000016761332166314300205150ustar00rootroot00000000000000# Data structure for calibration image database. define CAL_LEN (9*($1)) # Length of calib structure define CAL_KEY Memi[$1+($2)*9-1] # Pointer to key string define CAL_FLAG Memi[$1+($2)*9-2] # Flag for deferred mapping define CAL_AMPMERGE Memi[$1+($2)*9-3] # Merged image define CAL_IMAGE Memi[$1+($2)*9-4] # Pointer to image name string define CAL_CCDTYPE Memi[$1+($2)*9-5] # CCD type define CAL_AMP Memi[$1+($2)*9-6] # Pointer to amp identifier define CAL_CCD Memi[$1+($2)*9-7] # Pointer to ccd identifier define CAL_SUBSET Memi[$1+($2)*9-8] # Pointer to subset identifier define CAL_NSCAN Memi[$1+($2)*9-9] # Number of integrated scan lines define KEY Memc[CAL_KEY($1,$2)] define FLAG CAL_FLAG($1,$2) define AMPMERGE CAL_AMPMERGE($1,$2) define IMAGE Memc[CAL_IMAGE($1,$2)] define CCDTYPE CAL_CCDTYPE($1,$2) define AMP Memc[CAL_AMP($1,$2)] define CCD Memc[CAL_CCD($1,$2)] define SUBSET Memc[CAL_SUBSET($1,$2)] define NSCAN CAL_NSCAN($1,$2) mscred-5.05-2018.07.09/src/ccdred/src/calimage.x000066400000000000000000000367031332166314300205340ustar00rootroot00000000000000include include include include "ccdtypes.h" include "calimage.h" # 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, amplifier, 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, amplifier/ccd, 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 # Calibration 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, amp, ccd, subset, str bool strne(), ccd_cmp(), ccdflag() include "calimage.com" begin call smark (sp) call salloc (amp, SZ_FNAME, TY_CHAR) call salloc (ccd, SZ_FNAME, TY_CHAR) call salloc (subset, SZ_FNAME, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) # Match by amplifier if input has not been merged by amplifer. m = 0 n = 0 if (!ccdflag (im, "ampmerge")) { switch (ccdtype) { case MASK, ZERO, DARK: call ccdamp (im, Memc[amp], SZ_FNAME) do i = 1, ncal { if (CCDTYPE(cal,i) != ccdtype) next if (FLAG(cal,i) == YES) iferr (call cal_get (i, im)) next if (AMPMERGE(cal,i) == YES) next if (strne (AMP(cal,i), Memc[amp])) next n = n + 1 if (n == 1) { m = i } else { if (NSCAN(cal,i) == NSCAN(cal,m)) { # call eprintf ( # "Warning: Extra calibration image %s ignored\n") # call pargstr (IMAGE(cal,i)) # Reset image type to eliminate further warnings. CCDTYPE(cal,i) = UNKNOWN } else if (NSCAN(cal,m) != nscan && (NSCAN(cal,i)==nscan || NSCAN(cal,i)==1)) { m = i } } } case FLAT, SFLAT, ILLUM, FRINGE: call ccdamp (im, Memc[amp], SZ_FNAME) call ccdsubset (im, Memc[subset], SZ_FNAME) do i = 1, ncal { if (CCDTYPE(cal,i) != ccdtype) next if (FLAG(cal,i) == YES) iferr (call cal_get (i, im)) next if (AMPMERGE(cal,i) == YES) next if (strne (AMP(cal,i), Memc[amp])) next if (strne (SUBSET(cal,i), Memc[subset])) next n = n + 1 if (n == 1) { m = i } else { if (NSCAN(cal,i) == NSCAN(cal,m)) { # call eprintf ( # "Warning: Extra calibration image %s ignored\n") # call pargstr (IMAGE(cal,i)) # Reset image type to eliminate further warnings. CCDTYPE(cal,i) = UNKNOWN } else if (NSCAN(cal,m) != nscan && (NSCAN(cal,i)==nscan || NSCAN(cal,i)==1)) { m = i } } } } } # Match by CCD against calibrations which have been merged by amp. # Note that it is ok if the input has not been merged in which case # the part of the merged calibration will be matched with the amplifier. if (m == 0) { switch (ccdtype) { case MASK, ZERO, DARK: call ccdname (im, Memc[ccd], SZ_FNAME) do i = 1, ncal { if (CCDTYPE(cal,i) != ccdtype) next if (FLAG(cal,i) == YES) iferr (call cal_get (i, im)) next if (AMPMERGE(cal,i) == NO) next if (strne (CCD(cal,i), Memc[ccd])) next n = n + 1 if (n == 1) { m = i } else { if (NSCAN(cal,i) == NSCAN(cal,m)) { # call eprintf ( # "Warning: Extra calibration image %s ignored\n") # call pargstr (IMAGE(cal,i)) # Reset image type to eliminate further warnings. # CCDTYPE(cal,i) = UNKNOWN ; } else if (NSCAN(cal,m) != nscan && (NSCAN(cal,i)==nscan || NSCAN(cal,i)==1)) { m = i } } } case FLAT, SFLAT, ILLUM, FRINGE: call ccdname (im, Memc[ccd], SZ_FNAME) call ccdsubset (im, Memc[subset], SZ_FNAME) do i = 1, ncal { if (CCDTYPE(cal,i) != ccdtype) next if (FLAG(cal,i) == YES) iferr (call cal_get (i, im)) next if (strne (CCD(cal,i), Memc[ccd])) next if (strne (SUBSET(cal,i), Memc[subset])) next if (AMPMERGE(cal,i) == NO) { call eprintf ( "Warning: Multiple amps used for image but not for calibration\n") next } n = n + 1 if (n == 1) { m = i } else { if (NSCAN(cal,i) == NSCAN(cal,m)) { # call eprintf ( # "Warning: Extra calibration image %s ignored\n") # call pargstr (IMAGE(cal,i)) # Reset image type to eliminate further warnings. # CCDTYPE(cal,i) = UNKNOWN ; } else if (NSCAN(cal,m) != nscan && (NSCAN(cal,i)==nscan || NSCAN(cal,i)==1)) { m = i } } } } } # If no calibration image is found then it is an error. if (m == 0) { switch (ccdtype) { case MASK: call error (0, "No bad pixel mask found") 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 SFLAT: call sprintf (Memc[str], SZ_LINE, "No sky 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(cal,m), image, maxchars) if (nscan != NSCAN(cal,m)) { if (nscan != 1 && NSCAN(cal,m) == 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(cal,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 bool type int ccdtype, bplist, ccdtypecl, imtopenp(), nowhite() bool clgetb() errchk cal_list include "calimage.com" begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) ccdtype = ccdtypecl ("ccdtype", Memc[str], SZ_LINE) call clgstr ("bpmasks", Memc[str], SZ_LINE) bplist = nowhite (Memc[str], Memc[str], SZ_LINE) # Add calibration images to list. cal = NULL ncal = 0 type = (ccdtype != MASK) if (type && (clgetb ("fixpix") || bplist!=0)) { list1 = imtopenp ("fixfile") call cal_list (list1, MASK) call imtclose (list1) } type = (type && ccdtype != ZERO) if (type && clgetb ("zerocor")) { list1 = imtopenp ("zero") call cal_list (list1, ZERO) call imtclose (list1) } type = (type && ccdtype != DARK) if (type && clgetb ("darkcor")) { list1 = imtopenp ("dark") call cal_list (list1, DARK) call imtclose (list1) } type = (type && ccdtype != FLAT) if (type && clgetb ("flatcor")) { list1 = imtopenp ("flat") call cal_list (list1, FLAT) call imtclose (list1) } type = (type && ccdtype != SFLAT) if (type && clgetb ("sflatcor")) { list1 = imtopenp ("sflat") call cal_list (list1, SFLAT) call imtclose (list1) } if (type && ccdtype != ILLUM && clgetb ("illumcor")) { list1 = imtopenp ("illum") call cal_list (list1, ILLUM) call imtclose (list1) } if (type && 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 () int i include "calimage.com" begin if (cal != NULL) { do i = 1, ncal { call mfree (CAL_KEY(cal,i), TY_CHAR) call mfree (CAL_IMAGE(cal,i), TY_CHAR) call mfree (CAL_AMP(cal,i), TY_CHAR) call mfree (CAL_CCD(cal,i), TY_CHAR) call mfree (CAL_SUBSET(cal,i), TY_CHAR) } call mfree (cal, TY_STRUCT) } end # CAL_LIST -- Add calibration images to an internal list. # Map each image and get the CCD image type, amplifier, and subset. # If the ccdtype is given as a procedure argument this overrides the # image header type. For the calibration images add the type, amp, 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, ccdtypes(), ccdnscan(), imtgetim(), btoi() pointer sp, image, str, im, immap() bool streq(), ccdflag() include "calimage.com" begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { # If possible check the image. Ignore non-images in the input. if (listtype == UNKNOWN) { iferr (im = immap (Memc[image], READ_ONLY, 0)) next ccdtype = ccdtypes (im, Memc[str], SZ_LINE) } else if (Memc[image] == '!' || streq (Memc[image], "BPM")) { im = NULL ccdtype = listtype } else { iferr (im = immap (Memc[image], READ_ONLY, 0)) { #if (listtype != MASK) #call erract (EA_ERROR) im = NULL } ccdtype = listtype } # Ignore any images with no data. if (im != NULL) { if (IM_NDIM(im) == 0) { call imunmap (im) next } } switch (ccdtype) { case MASK, ZERO, DARK, FLAT, SFLAT, ILLUM, FRINGE: # Check for duplication. for (i=1; i<=ncal; i=i+1) if (streq (Memc[image], KEY(cal,i)) && CCDTYPE(cal,i) == ccdtype) break if (i <= ncal) break # Allocate memory for a new image. if (cal == NULL) call malloc (cal, CAL_LEN(10), TY_STRUCT) else if (mod (ncal,10) == 0) call realloc (cal, CAL_LEN(ncal+10), TY_STRUCT) call malloc (CAL_KEY(cal,i), SZ_FNAME, TY_CHAR) call malloc (CAL_IMAGE(cal,i), SZ_FNAME, TY_CHAR) call malloc (CAL_AMP(cal,i), SZ_FNAME, TY_CHAR) call malloc (CAL_CCD(cal,i), SZ_FNAME, TY_CHAR) call malloc (CAL_SUBSET(cal,i), SZ_FNAME, TY_CHAR) # Enter the key, image, ccdtype, amp, and subset. call strcpy (Memc[image], KEY(cal,i), SZ_FNAME) CCDTYPE(cal,i) = ccdtype if (im == NULL) FLAG(cal,i) = YES else { FLAG(cal,i) = NO call strcpy (Memc[image], IMAGE(cal,i), SZ_FNAME) call ccdamp (im, AMP(cal,i), SZ_FNAME) call ccdname (im, CCD(cal,i), SZ_FNAME) call ccdsubset (im, SUBSET(cal,i), SZ_FNAME) NSCAN(cal,i) = ccdnscan (im, ccdtype) AMPMERGE(cal,i) = btoi (ccdflag (im, "ampmerge")) } ncal = i } if (im != NULL) 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 # CAL_GET -- Get the calibration information. # This will return the information previously saved or open calibration # images specified in the reference image header or requiring the reference # image header (i.e. a bad pixel file). procedure cal_get (i, refim) int i #I Index pointer refim #I Reference image pointer im, xt_pmmap(), immap() bool check, streq(), ccdflag() int ccdnscan(), btoi() errchk xt_pmmap, immap, hdmgstr, ccdamp, ccdname, ccdsubset, ccdnscan include "calimage.com" begin switch (CCDTYPE(cal,i)) { case MASK: if (KEY(cal,i) != '!') { iferr (im = xt_pmmap (KEY(cal,i),refim,IMAGE(cal,i),SZ_FNAME)) { #call erract (EA_WARN) call erract (EA_ERROR) } if (streq (KEY(cal,i), "BPM")) check = false else check = true } else { call hdmgstr (refim, Memc[CAL_KEY(cal,i)+1], IMAGE(cal,i), SZ_FNAME) iferr (im=xt_pmmap (IMAGE(cal,i),refim,IMAGE(cal,i),SZ_FNAME)) { #call erract (EA_WARN) call erract (EA_ERROR) } check = false } if (im != NULL) call yt_pmunmap (im) if (IMAGE(cal,i) == EOS) { call strcpy ("EMPTY", IMAGE(cal,i), SZ_FNAME) check = false } if (check) { ifnoerr (im = immap (IMAGE(cal,i), READ_ONLY,0)) { call ccdamp (im, AMP(cal,i), SZ_FNAME) call ccdname (im, CCD(cal,i), SZ_FNAME) call ccdsubset (im, SUBSET(cal,i), SZ_FNAME) NSCAN(cal,i) = ccdnscan (im, CCDTYPE(cal,i)) AMPMERGE(cal,i) = btoi (ccdflag (im, "ampmerge")) call imunmap (im) } else { call ccdamp (refim, AMP(cal,i), SZ_FNAME) call ccdname (refim, CCD(cal,i), SZ_FNAME) call ccdsubset (refim, SUBSET(cal,i), SZ_FNAME) NSCAN(cal,i) = ccdnscan (refim, CCDTYPE(cal,i)) AMPMERGE(cal,i) = btoi (ccdflag (refim, "ampmerge")) } } else { call ccdamp (refim, AMP(cal,i), SZ_FNAME) call ccdname (refim, CCD(cal,i), SZ_FNAME) call ccdsubset (refim, SUBSET(cal,i), SZ_FNAME) NSCAN(cal,i) = ccdnscan (refim, CCDTYPE(cal,i)) AMPMERGE(cal,i) = btoi (ccdflag (refim, "ampmerge")) } default: call hdmgstr (refim, Memc[CAL_KEY(cal,i)+1], IMAGE(cal,i), SZ_FNAME) im = immap (IMAGE(cal,i), READ_ONLY, 0) call ccdamp (im, AMP(cal,i), SZ_FNAME) call ccdname (im, CCD(cal,i), SZ_FNAME) call ccdsubset (im, SUBSET(cal,i), SZ_FNAME) NSCAN(cal,i) = ccdnscan (im, CCDTYPE(cal,i)) AMPMERGE(cal,i) = btoi (ccdflag (im, "ampmerge")) call imunmap (im) } end mscred-5.05-2018.07.09/src/ccdred/src/ccdamp.x000066400000000000000000000141411332166314300202110ustar00rootroot00000000000000include # CCDAMP -- Return the CCD amplifier identifier. # # 1. Get the amplifier string and search the record file for the ID string. # 2. If the amplifier string is not in the record file define a default ID # string based on the first word of the amplifier string. If the first # word is not unique append a integer to the first word until it is # unique. # 3. Add the new amplifier 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 ccdamp (im, amp, sz_name) pointer im # Image char amp[sz_name] # CCD amp identifier int sz_name # Size of amp string bool streq() int i, j, fd, ctowrd(), open(), fscan() pointer sp, fname, str1, str2, amp1, amp2, amp3 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 (amp1, SZ_LINE, TY_CHAR) call salloc (amp2, SZ_LINE, TY_CHAR) call salloc (amp3, SZ_LINE, TY_CHAR) # Get the amp record file and the amp string. call clgstr ("ampfile", Memc[fname], SZ_LINE) call hdmgstr (im, "amp", Memc[str1], SZ_LINE) if (Memc[str1] == EOS) call hdmgstr (im, "imageid", Memc[str1], SZ_LINE) if (Memc[str1] == EOS) call hdmgstr (im, "extname", Memc[str1], SZ_LINE) # The default amp identifier is the first word of the amp string. i = 1 i = ctowrd (Memc[str1], i, Memc[amp1], sz_name) # A null amp string is ok. If not null check for conflict # with previous amp IDs. if (Memc[str1] != EOS) { call strcpy (Memc[amp1], Memc[amp3], sz_name) # Search the amp record file for the same amp string. # If found use the ID string. If the amp ID has been # used for another amp 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) if (!streq (Memc[str2], "amp")) next call gargwrd (Memc[str2], SZ_LINE) call gargwrd (Memc[amp2], SZ_LINE) if (streq (Memc[str1], Memc[str2])) { i = 0 call strcpy (Memc[amp2], Memc[amp1], SZ_LINE) break } if (streq (Memc[amp1], Memc[amp2])) { j = log10 (real(i)) Memc[amp3+sz_name-2+j] = EOS call sprintf (Memc[amp1], sz_name, "%s_%d") call pargstr (Memc[amp3]) call pargi (i) i = i + 1 call seek (fd, BOF) } } call close (fd) } # If the amp is not in the record file add it. if (i > 0) { fd = open (Memc[fname], APPEND, TEXT_FILE) call fprintf (fd, "amp\t'%s'\t%s\n") call pargstr (Memc[str1]) call pargstr (Memc[amp1]) call close (fd) } } # Set the amp ID string and replace magic characters by '_' # since the amp ID is used in forming image names. call strcpy (Memc[amp1], amp, sz_name) for (i=1; amp[i]!=EOS; i=i+1) if (!(IS_ALNUM(amp[i])||amp[i]=='.')) amp[i] = '_' call sfree (sp) end # CCDNAME -- Return the CCD name identifier. # # 1. Get the ccd string and search the record file for the ID string. # 2. If the ccd string is not in the record file define a default ID # string based on the first word of the ccd string. If the first # word is not unique append a integer to the first word until it is # unique. # 3. Add the new ccd 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 ccdname (im, ccd, sz_name) pointer im # Image char ccd[sz_name] # CCD identifier int sz_name # Size of ccd string bool streq() int i, j, fd, ctowrd(), open(), fscan() pointer sp, fname, str1, str2, ccd1, ccd2, ccd3 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 (ccd1, SZ_LINE, TY_CHAR) call salloc (ccd2, SZ_LINE, TY_CHAR) call salloc (ccd3, SZ_LINE, TY_CHAR) # Get the ccd record file and the ccd string. call clgstr ("ampfile", Memc[fname], SZ_LINE) call hdmgstr (im, "ccdname", Memc[str1], SZ_LINE) if (Memc[str1] == EOS) call hdmgstr (im, "imageid", Memc[str1], SZ_LINE) if (Memc[str1] == EOS) call hdmgstr (im, "extname", Memc[str1], SZ_LINE) # The default ccd identifier is the first word of the ccd string. i = 1 i = ctowrd (Memc[str1], i, Memc[ccd1], sz_name) # A null ccd string is ok. If not null check for conflict # with previous ccd IDs. if (Memc[str1] != EOS) { call strcpy (Memc[ccd1], Memc[ccd3], sz_name) # Search the ccd record file for the same ccd string. # If found use the ID string. If the ccd ID has been # used for another ccd 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) if (!streq (Memc[str2], "ccd")) next call gargwrd (Memc[str2], SZ_LINE) call gargwrd (Memc[ccd2], SZ_LINE) if (streq (Memc[str1], Memc[str2])) { i = 0 call strcpy (Memc[ccd2], Memc[ccd1], SZ_LINE) break } if (streq (Memc[ccd1], Memc[ccd2])) { j = log10 (real(i)) Memc[ccd3+sz_name-2+j] = EOS call sprintf (Memc[ccd1], sz_name, "%s_%d") call pargstr (Memc[ccd3]) call pargi (i) i = i + 1 call seek (fd, BOF) } } call close (fd) } # If the ccd is not in the record file add it. if (i > 0) { fd = open (Memc[fname], APPEND, TEXT_FILE) call fprintf (fd, "ccd\t'%s'\t%s\n") call pargstr (Memc[str1]) call pargstr (Memc[ccd1]) call close (fd) } } # Set the ccd ID string and replace magic characters by '_' # since the ccd ID is used in forming image names. call strcpy (Memc[ccd1], ccd, sz_name) for (i=1; ccd[i]!=EOS; i=i+1) if (!(IS_ALNUM(ccd[i])||ccd[i]=='.')) ccd[i] = '_' call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/ccdcache.com000066400000000000000000000006251332166314300210100ustar00rootroot00000000000000# Common data defining the cached images and data. int ccd_ncache # Number of images cached int ccd_maxcache # Maximum size of cache int ccd_bufsize # IMIO buffer size 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_bufsize, ccd_szcache, ccd_oldsize, ccd_pcache mscred-5.05-2018.07.09/src/ccdred/src/ccdcache.h000066400000000000000000000006071332166314300204610ustar00rootroot00000000000000# 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdcache.x000066400000000000000000000240501332166314300204770ustar00rootroot00000000000000include include include include "ccdcache.h" include "ccdtypes.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 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, im int sizeof() pointer immap(), imgs2r(), imgs2s() bool streq(), ccdcheck() errchk immap, imgs2r, imgs2s, ccdcheck 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. # Map READ_WRITE in case we want to update the header. if (i > ccd_ncache) { iferr { im = immap (image, READ_WRITE, 0) call imseti (im, IM_WHEADER, NO) } then im = immap (image, READ_ONLY, 0) call imseti (im, IM_BUFSIZE, ccd_bufsize) 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_ # Only cache zero and dark calibrations. # Don't cache unprocessed calibration image data. # This is the only really CCDRED specific code. if (ccdtype != ZERO && ccdtype != DARK) goto done_ 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) && IM_PIXTYPE(im) != TY_USHORT) 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) { # im1 = CCD_IM(pcache1) # call ccd_flush (im1) # 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) call imseti (im, IM_BUFSIZE, ccd_bufsize) 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, im_bufsize) int max_cache #I Maximum cache size in bytes int im_bufsize #I Image I/O buffer size int max_size, begmem() include "ccdcache.com" begin ccd_ncache = 0 ccd_maxcache = max_cache ccd_bufsize = im_bufsize 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) #max_size = max_cache call fixmem (max_size) } end # CCD_UNMAP -- Unmap an image with no cached data. 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) { if (CCD_NACCESS(pcache) <= 1 && CCD_SZDATA(pcache) == 0) call ccd_flush (im) else 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_REAL) 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdcheck.x000066400000000000000000000100651332166314300205120ustar00rootroot00000000000000include include "ccdtypes.h" # CCDCHECK -- Check processing status. bool procedure ccdcheck (im, ccdtype, bpmask) pointer im # IMIO pointer int ccdtype # CCD type char bpmask[ARB] # Output bad pixel mask int imaccess() bool clgetb(), ccdflag() errchk ccdflag begin switch (ccdtype) { case MASK: case ZERO: if (bpmask[1] != EOS && imaccess (bpmask, READ_ONLY) == NO) return (true) if (clgetb ("trim") && !ccdflag (im, "trim")) return (true) if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) return (true) if (clgetb ("overscan") && !ccdflag (im, "overscan")) return (true) if (clgetb ("readcor") && !ccdflag (im, "readcor")) return (true) case DARK: if (bpmask[1] != EOS && imaccess (bpmask, READ_ONLY) == NO) return (true) if (clgetb ("trim") && !ccdflag (im, "trim")) return (true) if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) return (true) if (clgetb ("overscan") && !ccdflag (im, "overscan")) return (true) if (clgetb ("zerocor") && !ccdflag (im, "zerocor")) return (true) case FLAT: if (bpmask[1] != EOS && imaccess (bpmask, READ_ONLY) == NO) return (true) if (clgetb ("trim") && !ccdflag (im, "trim")) return (true) if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) return (true) if (clgetb ("overscan") && !ccdflag (im, "overscan")) return (true) 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 SFLAT: if (bpmask[1] != EOS && imaccess (bpmask, READ_ONLY) == NO) return (true) if (clgetb ("trim") && !ccdflag (im, "trim")) return (true) if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) return (true) if (clgetb ("overscan") && !ccdflag (im, "overscan")) return (true) 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 ("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 (bpmask[1] != EOS && imaccess (bpmask, READ_ONLY) == NO) return (true) if (clgetb ("trim") && !ccdflag (im, "trim")) return (true) if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) return (true) if (clgetb ("overscan") && !ccdflag (im, "overscan")) return (true) 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 ("sflatcor") && !ccdflag (im, "sflatcor")) return (true) # iferr (ccdmean = hdmgetr (im, "ccdmean")) # return (true) default: if (bpmask[1] != EOS && imaccess (bpmask, READ_ONLY) == NO) return (true) if (clgetb ("trim") && !ccdflag (im, "trim")) return (true) if (clgetb ("fixpix") && !ccdflag (im, "fixpix")) return (true) if (clgetb ("overscan") && !ccdflag (im, "overscan")) return (true) 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 ("sflatcor") && !ccdflag (im, "sflatcor")) return (true) if (clgetb ("illumcor") && !ccdflag (im, "illumcor")) return (true) if (clgetb ("fringecor") && !ccdflag (im, "fringcor")) return (true) } return (false) end mscred-5.05-2018.07.09/src/ccdred/src/ccdcmp.x000066400000000000000000000011451332166314300202130ustar00rootroot00000000000000# 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() bool xt_imnameeq() 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) return (xt_imnameeq (image1, image2)) end mscred-5.05-2018.07.09/src/ccdred/src/ccdcopy.x000066400000000000000000000007071332166314300204110ustar00rootroot00000000000000include # CCDCOPY -- Copy pixels. procedure ccdcopy (in, out) pointer in #I IMIO pointer pointer out #I IMIO pointer int i, nc, nl pointer imgl2s(), impl2s(), imgl2r(), impl2r() begin 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) } end mscred-5.05-2018.07.09/src/ccdred/src/ccddelete.x000066400000000000000000000056641332166314300207100ustar00rootroot00000000000000# CCDDELETE -- Delete an image by renaming it to a backup image. # # Determine the type of backup; i.e. none, once, or all. If "none" then # delete the image without a backup. Otherwise get a backup root name which # may be a directory. Supply a default if needed. If only backing up "once" # check if a backup exists and delete the image without making a backup if it # does. Otherwise rename the image to the backup name. If backing up all # images then rename the image to the backup name. # # The backup image name is formed by prepending the backup prefix to the # image name. If a previous backup exists append integers to the backup # prefix until a nonexistant image name is created. define BKUP_TYPES "|none|once|all|" define BKUP_NONE 1 define BKUP_ONCE 2 define BKUP_ALL 3 procedure t_ccddelete () int images # List of images to backup and delete pointer sp, image int imtopenp(), imtgetim() begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) images = imtopenp ("images") while (imtgetim (images, Memc[image], SZ_FNAME) != EOF) call ccddelete (Memc[image]) call imtclose (images) call sfree (sp) end procedure ccddelete (image) char image[ARB] # Image to delete (backup) int i, bkup, clgwrd(), nowhite(), access(), fnldir(), imaccess() pointer sp, bkuproot, backup bool clgetb() errchk imdelete, imrename, fmkdir begin call smark (sp) call salloc (bkuproot, SZ_FNAME, TY_CHAR) call salloc (backup, SZ_FNAME, TY_CHAR) # Get the backup flag. bkup = clgwrd ("backup", Memc[backup], SZ_FNAME, BKUP_TYPES) # Delete image and return if no backup is desired. if (bkup == BKUP_NONE) { call imdelete (image) call sfree (sp) return } # Get the backup root name and supply a default if needed. call clgstr ("bkuproot", Memc[bkuproot], SZ_FNAME) if (nowhite (Memc[bkuproot], Memc[bkuproot], SZ_FNAME) == 0) call sprintf (Memc[bkuproot], SZ_FNAME, "Raw/") # Create a directory if needed. if (fnldir (Memc[bkuproot], Memc[backup], SZ_FNAME) != 0) { if (access (Memc[backup], 0, 0) == NO) call fmkdir (Memc[backup]) } # Create a backup name. i = 0 repeat { if (i == 0) { call sprintf (Memc[backup], SZ_FNAME, "%s%s") call pargstr (Memc[bkuproot]) call pargstr (image) } else { call sprintf (Memc[backup], SZ_FNAME, "%s%d%s") call pargstr (Memc[bkuproot]) call pargi (i) call pargstr (image) } i = i + 1 } until (imaccess (Memc[backup], READ_ONLY) == NO) # Backup up image if needed. switch (bkup) { case BKUP_ONCE: if (i == 1) { if (clgetb ("verbose")) { call eprintf ("Backup %s to %s\n") call pargstr (image) call pargstr (Memc[backup]) } call imrename (image, Memc[backup]) } else call imdelete (image) default: if (clgetb ("verbose")) { call eprintf ("Backup %s to %s\n") call pargstr (image) call pargstr (Memc[backup]) } call imrename (image, Memc[backup]) } call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/ccdflag.x000066400000000000000000000012441332166314300203450ustar00rootroot00000000000000# 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdinst1.key000066400000000000000000000017571332166314300210240ustar00rootroot00000000000000 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) amplifier Amplifier parameter subset Subset or filter parameter exptime Exposure time darktime Dark time (may be same as the exposure time) mscred-5.05-2018.07.09/src/ccdred/src/ccdinst2.key000066400000000000000000000025241332166314300210160ustar00rootroot00000000000000 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) amplifier Amplifier parameter 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdinst3.key000066400000000000000000000035311332166314300210160ustar00rootroot00000000000000 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) amplifier Amplifier parameter 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 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdlog.x000066400000000000000000000051201332166314300202120ustar00rootroot00000000000000include include # CCDLOG - The purpose of these routines is to store up log information # in a string buffer to be flushed later. # CCDLOG_OPEN -- Allocate and open log string buffer. procedure ccdlog_open (maxchar) int maxchar #I Maximum size of string buffer. int logfd, logmaxchar, stropen() pointer logbuf common /ccdlogcom/ logfd, logbuf, logmaxchar errchk stropen begin logmaxchar = maxchar call calloc (logbuf, logmaxchar, TY_CHAR) logfd = stropen (Memc[logbuf], logmaxchar, NEW_FILE) end # CCDLOG_CLOSE -- Close and free log string buffer. procedure ccdlog_close () int logfd, logmaxchar pointer logbuf common /ccdlogcom/ logfd, logbuf, logmaxchar begin call close (logfd) call mfree (logbuf, TY_CHAR) end # CCDLOG -- Log information with the image name. procedure ccdlog (im, str) pointer im # IMIO pointer char str[ARB] # Log string pointer sp, fname int logfd, logmaxchar pointer logbuf common /ccdlogcom/ logfd, logbuf, logmaxchar begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call hdmgstr (im, "tmpfname", Memc[fname], SZ_FNAME) if (Memc[fname] == EOS) call imstats (im, IM_IMAGENAME, Memc[fname], SZ_FNAME) call fprintf (logfd, "%s: %s\n") call pargstr (Memc[fname]) call pargstr (str) call sfree (sp) end # CCDLOG_FLUSH -- Flush output. # # 1. If the package "verbose" parameter is set output to standard error. # 2. If the package "logfile" parameter is not null append to the file. procedure ccdlog_flush () int fd, open(), stropen() bool clgetb() pointer sp, fname errchk open, stropen int logfd, logmaxchar pointer logbuf common /ccdlogcom/ logfd, logbuf, logmaxchar begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) # Close string buffer. call close (logfd) # Write verbose output to standard error. if (clgetb ("verbose")) { # call eprintf ("%s") # call pargstr (Memc[logbuf]) call putline (STDERR, Memc[logbuf]) } # Append to the "logfile". call clgstr ("logfile", Memc[fname], SZ_FNAME) call xt_stripwhite (Memc[fname]) if (Memc[fname] != EOS) { fd = open (Memc[fname], APPEND, TEXT_FILE) # call fprintf (fd, "%s") # call pargstr (Memc[logbuf]) call putline (fd, Memc[logbuf]) call close (fd) } # Reopen string buffer at begining. logfd = stropen (Memc[logbuf], logmaxchar, NEW_FILE) call sfree (sp) end # CCDLOG_CLEAR -- Clear log string buffer. procedure ccdlog_clear () int logfd, logmaxchar, stropen() pointer logbuf common /ccdlogcom/ logfd, logbuf, logmaxchar begin call close (logfd) logfd = stropen (Memc[logbuf], logmaxchar, NEW_FILE) end mscred-5.05-2018.07.09/src/ccdred/src/ccdmean.x000066400000000000000000000021461332166314300203560ustar00rootroot00000000000000include include # CCDMEAN -- Compute mean and add to header if needed. real procedure ccdmean (im) pointer im # IMIO pointer int i, nc, nl, nmean, nsum, hdmgeti() long time, clktime() bool clgetb() real hdmgetr() double mean, sum, procmeanr() pointer imgl2r() begin # Check if this operation has been done. ifnoerr (mean = hdmgetr (im, "ccdmean")) { iferr (time = hdmgeti (im, "ccdmeant")) { time = IM_MTIME(im) call hdmputi (im, "ccdmeant", int (time)) } if (time >= IM_MTIME(im)) { return (mean) } } if (clgetb ("noproc")) { call eprintf (" [TO BE DONE] Compute mean of image\n") return (INDEF) } # Compute and record the mean. nc = IM_LEN(im,1) nl = IM_LEN(im,2) sum = 0. nsum = 0 do i = 1, nl { mean = procmeanr (Memr[imgl2r(im,i)], nc, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } if (nsum > 0) mean = sum / nsum else mean = 1. time = clktime (long(0)) call hdmputr (im, "ccdmean", real (mean)) call hdmputi (im, "ccdmeant", int (time)) call imseti (im, IM_WHEADER, YES) return (real (mean)) end mscred-5.05-2018.07.09/src/ccdred/src/ccdnscan.x000066400000000000000000000012751332166314300205420ustar00rootroot00000000000000include "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 MASK, 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdproc.x000066400000000000000000000332041332166314300204000ustar00rootroot00000000000000include include include "ccdred.h" include "ccdtypes.h" define MEMUNIT 1000000. # Units for memory specifications # 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, a list of output # images for the result, the CCD type to be select from the input list. # If the output list is empty or the image names in the output list match the # input list then the processing is done to a temporary image which # eventually replaces the input image. 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. There are two data type paths; one for short pixel types and # one for all other pixel types (usually real). procedure ccdproc (inlist, outlist, noilist, bpmlist, onerror, selecttype, proctype, calproc) int inlist #I List of input CCD images int outlist #I List of output CCD images int noilist #I List of output no interpolation images int bpmlist #I List of output bad pixel masks int onerror #I Error action char selecttype[ARB] #I CCD type to select (if not null) char proctype[ARB] #I CCD processing type (if not null) int calproc #I Process calibration images? int ccdcode, interactive, proc, listproc, noutlist, nbpmlist, nnoilist int max_cache, bufsize, last_cache, last_bufsize pointer sp, input, output, bpmask, noi, temp, str, in, out, bpm, fdnoi, ccd bool clgetb(), streq(), ccdcheck() real clgetr() int imtlen(), imtgetim(), ccdtypes(), ccdtype() pointer immap() errchk immap, set_input, set_output, ccddelete, cal_open errchk set_fixpix, set_overscan, set_zero, set_dark, set_flat errchk set_illum, set_fringe data last_cache/-1/ begin call smark (sp) call salloc (input, SZ_FNAME, TY_CHAR) call salloc (output, SZ_FNAME, TY_CHAR) call salloc (bpmask, SZ_FNAME, TY_CHAR) call salloc (noi, SZ_FNAME, TY_CHAR) call salloc (temp, SZ_FNAME, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) # Initialize the instrument transation, the calibration images, # caching, and log output. call clgstr ("instrument", Memc[str], SZ_LINE) call hdmopen (Memc[str]) # Initialize calibration images. call cal_open (inlist) call ccdlog_open (10 * SZ_LINE) call set_interactive ("", interactive) if (clgetb ("noproc")) { proc = NO listproc = YES } else { proc = YES listproc = NO } # Set calibration image caching and calibration image buffer size. #if (imtlen (inlist) < 3) # max_cache = 0. #else max_cache = MEMUNIT * clgetr ("max_cache") bufsize = max (1024., MEMUNIT * clgetr ("im_bufsize")) if (last_cache>=0 && (max_cache!=last_cache || bufsize!=last_bufsize)) { call ccd_close () last_cache = -1 } if (last_cache == -1) { call ccd_open (max_cache, bufsize) last_cache = max_cache last_bufsize = bufsize } # Process the images. noutlist = imtlen (outlist) if (noutlist == 1) if (imtgetim (outlist, Memc[output], SZ_FNAME) == EOF) call error (1, "Error in output list") nnoilist = imtlen (noilist) if (nnoilist == 0) Memc[noi] = EOS nbpmlist = imtlen (bpmlist) if (nbpmlist == 0) Memc[bpmask] = EOS while (imtgetim (inlist, Memc[input], SZ_FNAME) != EOF) { if (noutlist == 0) call strcpy (Memc[input], Memc[output], SZ_FNAME) else if (noutlist > 1) if (imtgetim (outlist, Memc[output], SZ_FNAME) == EOF) call error (1, "Error in output list") if (streq (Memc[input], Memc[output])) call mktemp ("tmp", Memc[temp], SZ_FNAME) else call strcpy (Memc[output], Memc[temp], SZ_FNAME) if (nnoilist > 0) if (imtgetim (noilist, Memc[noi], SZ_FNAME) == EOF) call error (1, "Error in output no interpolation list") if (nbpmlist > 0) if (imtgetim (bpmlist, Memc[bpmask], SZ_FNAME) == EOF) call error (1, "Error in bad pixel mask list") if (listproc == YES) { call printf ("%s:\n") call pargstr (Memc[input]) } # Map the input image and check its type. iferr (in = immap (Memc[input], READ_ONLY, 0)) { switch (onerror) { case ONERR_ABORT: call erract (EA_ERROR) case ONERR_EXIT: call erract (EA_WARN) break default: call erract (EA_WARN) next } } call imseti (in, IM_BUFSIZE, bufsize) ccdcode = ccdtypes (in, Memc[str], SZ_LINE) if (selecttype[1] != EOS && !streq (Memc[str], selecttype)) { call imunmap (in) next } # Check if the image needs to be processed. if (proctype[1] != EOS) ccdcode = ccdtype (proctype, NO, Memc[str], SZ_LINE) if (!ccdcheck (in, ccdcode, Memc[bpmask])) { call imunmap (in) next } # Process the image. iferr { # Set the processing parameters. ccd = NULL call set_proc (in, proc, calproc, listproc, ccd) call set_noi (ccd, Memc[noi]) call set_bpmask (ccd, Memc[bpmask]) switch (ccdcode) { case MASK: call set_sections (ccd) case ZERO: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_readcor (ccd) call set_saturate (ccd) case DARK: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_saturate (ccd) case FLAT: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_saturate (ccd) CORS(ccd, FINDMEAN) = YES CORS(ccd, MINREP) = YES case SFLAT: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_saturate (ccd) CORS(ccd, FINDMEAN) = YES CORS(ccd, MINREP) = YES case ILLUM: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_sflat (ccd) call set_saturate (ccd) CORS(ccd, FINDMEAN) = YES case OBJECT, COMP: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_sflat (ccd) iferr { call set_illum (ccd) call set_fringe (ccd) } then call erract (EA_WARN) call set_saturate (ccd) CORS(ccd, FINDMEAN) = YES default: call set_sections (ccd) call set_trim (ccd) call set_overscan (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_sflat (ccd) iferr { call set_illum (ccd) call set_fringe (ccd) } then call erract (EA_WARN) call set_saturate (ccd) CORS(ccd, FINDMEAN) = YES } # Do the processing. if (PROC(ccd) == YES) { if (COR(ccd) == YES) { call ccdlog_flush () call set_output (Memc[temp], Memc[noi], Memc[bpmask], ccd, in, out, fdnoi, bpm) call doproc (ccd) call set_header (ccd) in = IN_IM(ccd) if (fdnoi != NULL) call imunmap (fdnoi) if (bpm != NULL) call imunmap (bpm) if (out != NULL) call imunmap (out) call imunmap (in) if (CORS(ccd, READCOR) == YES) call readcor (Memc[temp], Memc[temp]) } else { call imunmap (in) if (CORS(ccd, READCOR) == YES) call readcor (Memc[input], Memc[temp]) else Memc[temp] = EOS } # Replace input image by the processed image if needed. if (streq(Memc[input],Memc[output])&&Memc[temp]!=EOS) { iferr (call ccddelete (Memc[input])) { call eprintf ( "Warning: Can't delete or make backup of `%s'.") call pargstr (Memc[input]) call eprintf (" Processed image is `%s'.\n") call pargstr (Memc[temp]) PROC(ccd) = NO } else call imrename (Memc[temp], Memc[output]) } } else call ccdlog_clear () call ccdlog_flush () if (ccd != NULL) call free_proc (ccd) if (in != NULL) call imunmap (in) } then { call ccdlog_clear () if (ccd != NULL) call free_proc (ccd) if (in != NULL) call imunmap (in) switch (onerror) { case ONERR_WARN: call erract (EA_WARN) next case ONERR_EXIT: call erract (EA_WARN) break default: call erract (EA_ERROR) } } } # Finish up. call cal_close () call ccdlog_close () #call ccd_close () #last_cache = -1 call hdmclose () call sfree (sp) end # CCDPROC1 -- Process a single CCD image with a specified type. # # This procedure processes a single image and is used to recursively process # a calibration image. It is assumed that the calling procedure has already # determined that the image needs to be processed (there is no call to # CCDCHECK) and that it will not try and process a calibration image (since # this would cause a recursive call). This procedure is like CCDPROC # called with a single image except that it does not need to initialize # the translations or the calibration image database and cache. procedure ccdproc1 (input, output, ccdcode) char input[ARB] #I Input CCD image to process char output[ARB] #I Output processed CCD image int ccdcode #I CCD type of image (independent of header). int proc, bufsize pointer sp, temp, in, out, bpm, fdnoi, ccd, immap() bool streq() real clgetr() errchk immap, set_output, ccddelete errchk set_fixpix, set_zero, set_dark, set_flat, set_illum, set_fringe begin call smark (sp) call salloc (temp, SZ_FNAME, TY_CHAR) if (streq (input, output)) call mktemp ("tmp", Memc[temp], SZ_FNAME) else call strcpy (output, Memc[temp], SZ_FNAME) # Process the image. in = immap (input, READ_ONLY, 0) bufsize = MEMUNIT * clgetr ("im_bufsize") call imseti (in, IM_BUFSIZE, bufsize) # Set the processing parameters. proc = YES call set_proc (in, proc, NO, NO, ccd) call set_bpmask (ccd, "") call set_noi (ccd, "") switch (ccdcode) { case MASK: call set_sections (ccd) case ZERO: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_readcor (ccd) call set_overscan (ccd) case DARK: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_overscan (ccd) case FLAT: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_overscan (ccd) CORS(ccd, FINDMEAN) = YES CORS(ccd, MINREP) = YES case SFLAT: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_overscan (ccd) CORS(ccd, FINDMEAN) = YES CORS(ccd, MINREP) = YES case ILLUM: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_sflat (ccd) call set_overscan (ccd) case OBJECT, COMP: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_sflat (ccd) iferr { call set_illum (ccd) call set_fringe (ccd) } then call erract (EA_WARN) call set_overscan (ccd) default: call set_sections (ccd) call set_trim (ccd) call set_fixpix (ccd) call set_zero (ccd) call set_dark (ccd) call set_flat (ccd) call set_sflat (ccd) iferr { call set_illum (ccd) call set_fringe (ccd) } then call erract (EA_WARN) call set_overscan (ccd) CORS(ccd, FINDMEAN) = YES } # Do the processing. if (PROC(ccd) == YES) { if (COR(ccd) == YES) { call ccdlog_flush () call set_output (Memc[temp], "", "", ccd, in, out, fdnoi, bpm) call doproc (ccd) call set_header (ccd) call imunmap (out) call imunmap (in) if (CORS(ccd, READCOR) == YES) call readcor (Memc[temp], Memc[temp]) } else { call imunmap (in) if (CORS(ccd, READCOR) == YES) call readcor (input, Memc[temp]) else Memc[temp] = EOS } # Replace the input image by the processed image if needed. if (streq (input, output) && Memc[temp] != EOS) { iferr (call ccddelete (input)) { call eprintf ( "Warning: Can't delete or make backup of `%s'.") call pargstr (input) call eprintf (" Processed image is `%s'.\n") call pargstr (Memc[temp]) PROC(ccd) = NO } else call imrename (Memc[temp], output) } } else { call imunmap (in) call ccdlog_clear () } proc = PROC(ccd) call free_proc (ccd) call ccdlog_flush () call sfree (sp) if (proc == NO) call error (2, "Error processing calibration image") end # CCDPROC2 -- Action if not processing calibration images. procedure ccdproc2 (input, output, ccdcode) char input[ARB] #I Input CCD image to process char output[ARB] #I Output processed CCD image int ccdcode #I CCD type of image (independent of header). int fd, open() pointer sp, fname errchk open begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call clgstr ("calproc", Memc[fname], SZ_FNAME) fd = open (Memc[fname], APPEND, TEXT_FILE) call ccdstr (ccdcode, Memc[fname], SZ_FNAME) call fprintf (fd, "%s %s\n") call pargstr (input) call pargstr (Memc[fname]) call close (fd) call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/ccdred.h000066400000000000000000000237421332166314300201750ustar00rootroot00000000000000# 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 1660 # Length of CCD structure define LEN_LOG 199 # Length of log strings define LEN_CCDSTR 99 # Length of strings # Basic control flags define PROC Memi[$1] # Process input image? define CALPROC Memi[$1+1] # Process calibration images? define LISTPROC Memi[$1+2] # List processing to be done? define COR Memi[$1+3] # Call DOPROC? define COROUT Memi[$1+4] # Create output image? define CORBPM Memi[$1+5] # Create output mask? define CORS Memi[$1+6+($2-1)] # Individual correction flags # CCD data coordinates define CCD_C1 Memi[$1+20] # CCD starting column define CCD_C2 Memi[$1+21] # CCD ending column define CCD_CS Memi[$1+22] # CCD step define CCD_L1 Memi[$1+23] # CCD starting line define CCD_L2 Memi[$1+24] # CCD ending line define CCD_LS Memi[$1+25] # CCD step # Input data define IN_IM Memi[$1+30] # Input image pointer define IN_CCDTYPE Memi[$1+31] # Input CCD type define IN_C1 Memi[$1+32] # Input data starting column define IN_C2 Memi[$1+33] # Input data ending column define IN_L1 Memi[$1+34] # Input data starting line define IN_L2 Memi[$1+35] # Input data ending line define IN_CFLIP Memi[$1+36] # Flipped input data section? define IN_LFLIP Memi[$1+37] # Flipped input data section? # Input mask data define BPIN_IM Memi[$1+40] # Input bad pixel mask pointer define BPIN_C1 Memi[$1+41] # Input mask data starting col define BPIN_C2 Memi[$1+42] # Input mask data ending col define BPIN_L1 Memi[$1+43] # Input mask data starting line define BPIN_L2 Memi[$1+44] # Input mask data ending line define BPIN_PM Memi[$1+45] # Input mask pointer define BPIN_FP Memi[$1+46] # Input mask fixpix data # Output data define OUT_IM Memi[$1+50] # Output image pointer define OUT_C1 Memi[$1+51] # Output data starting col define OUT_C2 Memi[$1+52] # Output data ending col define OUT_L1 Memi[$1+53] # Output data starting line define OUT_L2 Memi[$1+54] # Output data ending line # Output mask data define BPOUT_IM Memi[$1+55] # Output mask pointer # Output no interpolation data define NOIOUT_IM Memi[$1+56] # Output image pointer # Saturation and bleed trail data define SATVAL Memr[P2R($1+60)] # Saturation value in ADU define SATVALE Memr[P2R($1+61)] # Saturation value in electrons define SATGROW Memi[$1+62] # Saturated pixel grow radius define BLDVAL Memr[P2R($1+63)] # Bleed value in ADU define BLDVALE Memr[P2R($1+64)] # Bleed value in electrons define BLDTRAIL Memi[$1+65] # Bleed trail minimum length define BLDGROW Memi[$1+66] # Bleed pixel grow radius # Zero level data define ZERO_IM Memi[$1+70] # Zero level image pointer define ZERO_C1 Memi[$1+71] # Zero level data starting col define ZERO_C2 Memi[$1+72] # Zero level data ending col define ZERO_L1 Memi[$1+73] # Zero level data starting line define ZERO_L2 Memi[$1+74] # Zero level data ending line # Dark count data define DARK_IM Memi[$1+80] # Dark count image pointer define DARK_C1 Memi[$1+81] # Dark count data starting col define DARK_C2 Memi[$1+82] # Dark count data ending col define DARK_L1 Memi[$1+83] # Dark count data starting line define DARK_L2 Memi[$1+84] # Dark count data ending line define DARKSCALE Memr[P2R($1+85)] # Dark count scale factor # Flat field data define FLAT_IM Memi[$1+90] # Flat field image pointer define FLAT_C1 Memi[$1+91] # Flat field data starting col define FLAT_C2 Memi[$1+92] # Flat field data ending col define FLAT_L1 Memi[$1+93] # Flat field data starting line define FLAT_L2 Memi[$1+94] # Flat field data ending line define FLATSCALE Memr[P2R($1+95)] # Flat field scale factor define GAINSCALE Memr[P2R($1+96)] # Gain scale factor # Sky flat field data define SFLAT_IM Memi[$1+100] # Sky flat field image pointer define SFLAT_C1 Memi[$1+101] # Sky flat field starting col define SFLAT_C2 Memi[$1+102] # Sky flat field ending col define SFLAT_L1 Memi[$1+103] # Sky flat field starting line define SFLAT_L2 Memi[$1+104] # Sky flat field ending line define SFLATSCALE Memr[P2R($1+105)] # Sky flat field scale factor # Illumination data define ILLUM_IM Memi[$1+110] # Illumination image pointer define ILLUM_C1 Memi[$1+111] # Illumination starting col define ILLUM_C2 Memi[$1+112] # Illumination ending col define ILLUM_L1 Memi[$1+113] # Illumination starting line define ILLUM_L2 Memi[$1+114] # Illumination ending line define ILLUMSCALE Memr[P2R($1+115)] # Illumination factor # Fringe data define FRINGE_IM Memi[$1+120] # Fringe image pointer define FRINGE_C1 Memi[$1+121] # Fringe data starting col define FRINGE_C2 Memi[$1+122] # Fringe data ending col define FRINGE_L1 Memi[$1+123] # Fringe data starting line define FRINGE_L2 Memi[$1+124] # Fringe data ending line define FRINGESCALE Memr[P2R($1+125)] # Fringe scale factor # Trim section define TRIM_C1 Memi[$1+130] # Trim starting col define TRIM_C2 Memi[$1+131] # Trim ending col define TRIM_L1 Memi[$1+132] # Trim starting line define TRIM_L2 Memi[$1+133] # Trim ending line define TRIM_DC1 Memi[$1+134] # Trim from data section define TRIM_DC2 Memi[$1+135] # Trim from data section define TRIM_DL1 Memi[$1+136] # Trim from data section define TRIM_DL2 Memi[$1+137] # Trim from data section # Bias section define BIAS_C1 Memi[$1+140] # Bias starting col define BIAS_C2 Memi[$1+141] # Bias ending col define BIAS_L1 Memi[$1+142] # Bias starting line define BIAS_L2 Memi[$1+143] # Bias ending line define OVERSCAN_TYPE Memi[$1+144] # Pointer to overscan vector define OVERSCAN_VEC Memi[$1+145] # Pointer to overscan vector # Miscellaneous define READAXIS Memi[$1+150] # Readout axis (1=cols, 2=lines) define CALCTYPE Memi[$1+151] # Calculation data type define MINREPLACE Memr[P2R($1+152)] # Minimum replacement value define MEAN Memr[P2R($1+153)] # Mean of output image # Strings define SATLOG Memc[P2C($1+160)] # Saturation log define BLDLOG Memc[P2C($1+260)] # Bleed log define TRIMLOG Memc[P2C($1+360)] # Trim log define FIXLOG Memc[P2C($1+460)] # Fix pixel log define BIASLOG Memc[P2C($1+560)] # Bias log define ZEROLOG Memc[P2C($1+660)] # Zero log define DARKLOG Memc[P2C($1+760)] # Dark count log define FLATLOG Memc[P2C($1+860)] # Flat field log define SFLATLOG Memc[P2C($1+960)] # Sky flat field log define ILLUMLOG Memc[P2C($1+1060)] # Illumination log define FRINGELOG Memc[P2C($1+1160)] # Fringe log define BPOUTLOG Memc[P2C($1+1260)] # Output BP mask log define BPIN_NAME Memc[P2C($1+1360)] # Input bad pixel mask name define BPOUT_NAME Memc[P2C($1+1460)] # Output bad pixel mask name define NOIOUT_NAME Memc[P2C($1+1560)] # Output no interpolation name # The correction array contains the following elements with array indices # given by the macro definitions. define NCORS 13 # Number of corrections define SATURATE 1 # Find saturation and bleed trails define FIXPIX 2 # Fix bad pixels define TRIM 3 # Trim image define OVERSCAN 4 # Apply overscan correction define ZEROCOR 5 # Apply zero level correction define DARKCOR 6 # Apply dark count correction define FLATCOR 7 # Apply flat field correction define SFLATCOR 8 # Apply flat field correction define ILLUMCOR 9 # Apply illumination correction define FRINGECOR 10 # Apply fringe correction define FINDMEAN 11 # Find the mean of the output image define MINREP 12 # Check and replace minimum value define READCOR 13 # Apply 1D read correction # 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 S 020B # sky flat field define I 040B # Illumination define Q 100B # 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 SF 030B # flat field define SFO 031B # flat field + overscan define SFZ 032B # flat field + zero level define SFZO 033B # flat field + zero level + overscan define SFD 034B # flat field + dark count define SFDO 035B # flat field + dark count + overscan define SFDZ 036B # flat field + dark count + zero level define SFDZO 037B # flat field + dark count + zero level + overscan define QI 140B # 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 # The following are error actions for CCDPROC. define ONERROR "|abort|warn|exit|original|" define ONERR_ABORT 1 # Abort on an error define ONERR_WARN 2 # Warn on error and continue define ONERR_EXIT 3 # Warn on error and exit define ONERR_ORIG 4 # Original CCDPROC (warn/error) # The following are CALPROC actions. define CALPROC_YES 1 # Process calibrations define CALPROC_NO 2 # Set calibration to be processed externally define CALPROC_IGNORE 3 # Ignore calibration processing mscred-5.05-2018.07.09/src/ccdred/src/ccdsection.x000066400000000000000000000040561332166314300211040ustar00rootroot00000000000000include # 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 mscred-5.05-2018.07.09/src/ccdred/src/ccdsubsets.x000066400000000000000000000057011332166314300211260ustar00rootroot00000000000000include # 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, j, 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_name) # 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_name) # 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])) { j = log10 (real(i)) Memc[subset3+sz_name-2+j] = EOS call sprintf (Memc[subset1], sz_name, "%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 mscred-5.05-2018.07.09/src/ccdred/src/ccdtypes.h000066400000000000000000000004551332166314300205630ustar00rootroot00000000000000# Standard CCD image types. define CCDTYPES "|object|zero|dark|flat|skyflat|illum|fringe|other|comp|mask|" define NONE -1 define UNKNOWN 0 define OBJECT 1 define ZERO 2 define DARK 3 define FLAT 4 define SFLAT 5 define ILLUM 6 define FRINGE 7 define OTHER 8 define COMP 9 define MASK 10 mscred-5.05-2018.07.09/src/ccdred/src/ccdtypes.x000066400000000000000000000055761332166314300206140ustar00rootroot00000000000000include "ccdtypes.h" # CCDTYPE -- Return the CCD type string and code. # CCDTYPECL -- Return the CCD type code and string from a CL parameter. # CCDTYPES -- Return the CCD type code and string from an image. # CCDSTR -- Return the CCD type string from the code. # CCDTYPE -- Return the CCD type string and code. # Strip any leading and trailing whitespace from the user string. # Translate to standard strings if requested. # The input and output strings may be the same. int procedure ccdtype (user, translate, ccdstr, maxchar) char user[ARB] #I User CCD type string int translate #I Translate user string? char ccdstr[maxchar] #O Standard CCD type string int maxchar #I Maximum size for CCD type string int ccdcode #O CCD type code int nowhite(), strdic() pointer sp, str begin call smark (sp) call salloc (str, maxchar, TY_CHAR) if (nowhite (user, Memc[str], maxchar) == 0) { ccdstr[1] = EOS ccdcode = NONE } else { call strcpy (user, Memc[str], maxchar) if (translate == YES) { call hdmname (Memc[str], Memc[str], maxchar) if (Memc[str] == EOS) call strcpy (user, Memc[str], maxchar) } call strcpy (Memc[str], ccdstr, maxchar) ccdcode = strdic (ccdstr, ccdstr, maxchar, CCDTYPES) } call sfree (sp) return (ccdcode) end # CCDTYPECL -- Return the CCD type string and code from a CL parameter. int procedure ccdtypecl (param, ccdstr, maxchar) char param[ARB] #I CL parameter char ccdstr[maxchar] #O CCD type string int maxchar #I Maximum size for CCD type string int ccdtype() begin call clgstr (param, ccdstr, maxchar) return (ccdtype (ccdstr, YES, ccdstr, maxchar)) end # CCDTYPES -- Return the CCD type string and code from an image. int procedure ccdtypes (im, ccdstr, maxchar) pointer im #I Image pointer char ccdstr[maxchar] #O CCD type string int maxchar #I Maximum size for CCD type string int ccdtype() begin call hdmgstr (im, "imagetyp", ccdstr, maxchar) return (ccdtype (ccdstr, YES, ccdstr, maxchar)) end # CCDSTR -- Return the standard CCD type string from the CCD type code. procedure ccdstr (ccdcode, type, sz_type) int ccdcode #I CCD type code char type[sz_type] #O CCD type string int sz_type #I Maximum size for CCD type string begin switch (ccdcode) { case NONE: call strcpy ("none", type, sz_type) case OBJECT: call strcpy ("object", type, sz_type) case ZERO: call strcpy ("zero", type, sz_type) case DARK: call strcpy ("dark", type, sz_type) case FLAT: call strcpy ("flat", type, sz_type) case SFLAT: call strcpy ("skyflat", type, sz_type) case ILLUM: call strcpy ("illum", type, sz_type) case FRINGE: call strcpy ("fringe", type, sz_type) case OTHER: call strcpy ("other", type, sz_type) case COMP: call strcpy ("comp", type, sz_type) case MASK: call strcpy ("mask", type, sz_type) default: call strcpy ("unknown", type, sz_type) } end mscred-5.05-2018.07.09/src/ccdred/src/combine/000077500000000000000000000000001332166314300202045ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/src/combine/combine.par000066400000000000000000000040541332166314300223270ustar00rootroot00000000000000# COMBINE -- Image combine parameters input,s,a,,,,List of images to combine output,s,a,,,,List of output images headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,List of sigma images (optional) imcmb,s,h,"$I",,,"Keyword for IMCMB keywords " ccdtype,s,h,"",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,no,,,Combine images by subset? delete,b,h,no,,,"Delete input images after combining? " combine,s,h,"average","average|median|sum",,Type of combine operation reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection project,b,h,no,,,Project highest dimension of input images? outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) offsets,f,h,"none",,,Input image offsets masktype,s,h,"none",,,Mask type maskvalue,s,h,"0",,,Mask value blank,r,h,0.,,,"Value if there are no pixels " scale,s,h,"none",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights statsec,s,h,"",,,"Image section for computing statistics " lthreshold,r,h,INDEF,,,Lower threshold hthreshold,r,h,INDEF,,,Upper threshold nlow,i,h,1,0,,minmax: Number of low pixels to reject nhigh,i,h,1,0,,minmax: Number of high pixels to reject nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) mclip,b,h,yes,,,Use median in sigma clipping algorithms? lsigma,r,h,3.,0.,,Lower sigma clipping factor hsigma,r,h,3.,0.,,Upper sigma clipping factor rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections pclip,r,h,-0.5,,,pclip: Percentile clipping parameter grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection mscred-5.05-2018.07.09/src/ccdred/src/combine/coutput.par000066400000000000000000000013021332166314300224070ustar00rootroot00000000000000# COUTPUT input,s,a,,,,List of images to combine output,s,a,,,,List of output images list,f,a,,,,Output file for list of output names headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,"List of sigma images (optional) " ccdtype,s,h,"",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,yes,,,"Combine images by subset? " scale,s,h,"none",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights mscred-5.05-2018.07.09/src/ccdred/src/combine/fcombine.par000066400000000000000000000041071332166314300224740ustar00rootroot00000000000000# ZCOMBINE -- Image combine parameters for zeros input,s,a,,,,List of images to combine output,s,a,,,,List of output images headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,List of sigma images (optional) imcmb,s,h,"$I",,,"Keyword for IMCMB keywords " ccdtype,s,h,"flat",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,no,,,Combine images by subset? delete,b,h,no,,,"Delete input images after combining? " combine,s,h,"average","average|median|sum",,Type of combine operation reject,s,h,"avsigclip","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection project,b,h,no,,,Project highest dimension of input images? outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) offsets,f,h,"none",,,Input image offsets masktype,s,h,"none",,,Mask type maskvalue,s,h,"0",,,Mask value blank,r,h,0.,,,"Value if there are no pixels " scale,s,h,"mode",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights statsec,s,h,"",,,"Image section for computing statistics " lthreshold,r,h,INDEF,,,Lower threshold hthreshold,r,h,INDEF,,,Upper threshold nlow,i,h,0,0,,minmax: Number of low pixels to reject nhigh,i,h,1,0,,minmax: Number of high pixels to reject nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) mclip,b,h,yes,,,Use median in sigma clipping algorithms? lsigma,r,h,3.,0.,,Lower sigma clipping factor hsigma,r,h,3.,0.,,Upper sigma clipping factor rdnoise,s,h,"rdnoise",,,ccdclip: CCD readout noise (electrons) gain,s,h,"gain",,,ccdclip: CCD gain (electrons/DN) snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections pclip,r,h,-0.5,,,pclip: Percentile clipping parameter grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection mscred-5.05-2018.07.09/src/ccdred/src/combine/icmefscale.x000066400000000000000000000176741332166314300225070ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "src/icombine.h" # MEFSCALES -- Compute scaling factors for MEF based on image statistics. # # MEF data requires all extensions from a single file have the same # scaling factor. If the scaling is to be done based on image statistics # it measures the image statistics for each extension (using the standard # icstat routine) and then combines the statistics for all extensions from # a single MEF to give a single statistic. procedure mefscales (images, iimage, nimages, nsubsets, scales, zeros, wts, nims) pointer images[nsubsets] #I Extension image names grouped by amplifier pointer iimage[nsubsets] #I List of image indices for each amplifer int nimages[nsubsets] #I Number of images in each amplifier int nsubsets #I Number of amplifiers real scales[nims] #U Scales for each MEF file real zeros[nims] #U Zeros for each MEF file real wts[nims] #U Weights for each MEF file int nims #I Number of MEF files int i, j, k, l, fd int stype, ztype, wtype bool dos, doz, dow, domode, domedian, domean pointer sp, str, section, offsets, modes, medians, means pointer im, imname int strdic(), nowhite(), open(), fscan() pointer immap() errchk open, ic_statr include "src/icombine.com" begin call smark (sp) call salloc (str, SZ_FNAME, TY_CHAR) call salloc (section, SZ_FNAME, TY_CHAR) call salloc (offsets, IM_MAXDIM, TY_INT) call aclri (Memi[offsets], IM_MAXDIM) # Check if anything needs to be calculated. call clgstr ("scale", Memc[str], SZ_FNAME) stype = strdic (Memc[str], Memc[str], SZ_FNAME, STYPES) call clgstr ("zero", Memc[str], SZ_FNAME) ztype = strdic (Memc[str], Memc[str], SZ_FNAME, ZTYPES) call clgstr ("weight", Memc[str], SZ_FNAME) wtype = strdic (Memc[str], Memc[str], SZ_FNAME, WTYPES) dos = ((stype==S_MODE)||(stype==S_MEDIAN)||(stype==S_MEAN)) doz = ((ztype==S_MODE)||(ztype==S_MEDIAN)||(ztype==S_MEAN)) dow = ((wtype==S_MODE)||(wtype==S_MEDIAN)||(wtype==S_MEAN)) if (dos) { dos = false do i = 1, nims if (IS_INDEFR(scales[i])) { dos = true break } } if (doz) { doz = false do i = 1, nims if (IS_INDEFR(zeros[i])) { doz = true break } } if (dow) { dow = false do i = 1, nims if (IS_INDEFR(wts[i])) { dow = true break } } if (!(dos || doz || dow)) { call sfree (sp) return } # Compute the statistics. i = nims * nsubsets call salloc (modes, i, TY_REAL) call salloc (medians, i, TY_REAL) call salloc (means, i, TY_REAL) call amovkr (INDEFR, Memr[modes], i) call amovkr (INDEFR, Memr[medians], i) call amovkr (INDEFR, Memr[means], i) 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)) # Compute the statistics for each extension. Memc[section] = EOS if (nowhite (Memc[statsec], Memc[statsec], ARB) != 0) { if (Memc[statsec] == '@') fd = open (Memc[statsec+1], READ_ONLY, TEXT_FILE) else call strcpy (Memc[statsec], Memc[section], SZ_FNAME) } do j = 1, nsubsets { if (Memc[statsec] == '@') { if (j == 1) call seek (fd, BOF) if (fscan (fd) != EOF) call gargwrd (Memc[section], SZ_FNAME) if (Memc[section] != '[') next } do k = 1, nimages[j] { i = Memi[iimage[j]+k-1] if (! (IS_INDEFR(scales[i]) || IS_INDEFR(zeros[i]) || IS_INDEFR(wts[i]))) next imname = images[j] + (k - 1) * SZ_FNAME im = immap (Memc[imname], READ_ONLY, 0) call ic_mopen (im, im, 1, Memi[offsets], 0) l = (j - 1) * nims + i - 1 call ic_statr (im, im, Memc[section], Memi[offsets], 1, 1, domode, domedian, domean, Memr[modes+l], Memr[medians+l], Memr[means+l]) call ic_mclose (1) call imunmap (im) } } if (Memc[statsec] == '@') call close (fd) # Compute final statistics for each MEF image. if (dos) { if (stype == S_MODE) call mefscales1 (Memr[modes], scales, nims, nsubsets) else if (stype == S_MEDIAN) call mefscales1 (Memr[medians], scales, nims, nsubsets) else if (stype == S_MEAN) call mefscales1 (Memr[means], scales, nims, nsubsets) } if (doz) { if (ztype == S_MODE) call mefscales1 (Memr[modes], zeros, nims, nsubsets) else if (ztype == S_MEDIAN) call mefscales1 (Memr[medians], zeros, nims, nsubsets) else if (ztype == S_MEAN) call mefscales1 (Memr[means], zeros, nims, nsubsets) } if (dow) { if (wtype == S_MODE) call mefscales1 (Memr[modes], wts, nims, nsubsets) else if (wtype == S_MEDIAN) call mefscales1 (Memr[medians], wts, nims, nsubsets) else if (wtype == S_MEAN) call mefscales1 (Memr[means], wts, nims, nsubsets) } call sfree (sp) end # MEFSCALES1 -- Combine image statistics from extensions into composite values. # # For each input MEF file the statistics for all extensions in the file # are combined by averaging the individual statistics. If there are enough # images deviant statistics are removed and uniform balance factors for # each image are measured and used. define MINIMS 4 # Minimum number of images for clipping define SIGCLIP 2. # Sigma clipping factor. define DEBUG NO procedure mefscales1 (stats, final, nims, nsubsets) real stats[nims,nsubsets] #I Input statistics real final[nims] #O Final averages int nims #I Number of images int nsubsets #I Number of subsets int i, j, n, aravr() real a, sig pointer sp, avgs, avgr, ratios begin # Number of images to use. n = 0 do i = 1, nims if (IS_INDEFR(final[i])) n = n + 1 # If only a few images just compute an average. if (n < MINIMS) { do i = 1, nims { if (!IS_INDEFR(final[i])) next a = 0. n = 0 do j = 1, nsubsets { if (IS_INDEFR(stats[i,j])) next a = a + stats[i,j] n = n + 1 } if (n > 0) final[i] = a / n } return } call smark (sp) call salloc (avgs, nims, TY_REAL) call salloc (avgr, nsubsets, TY_REAL) call salloc (ratios, max (nims, nsubsets), TY_REAL) if (DEBUG == YES) { do i = 1, nims do j = 1, nsubsets { call printf ("%d %d %g\n") call pargi (i) call pargi (j) call pargr (stats[i,j]) } } # Average value for each image with no rejection. do i = 1, nims { if (!IS_INDEFR(final[i])) next a = 0. n = 0 do j = 1, nsubsets { if (IS_INDEFR(stats[i,j])) next a = a + stats[i,j] n = n + 1 } if (n > 0) Memr[avgs+i-1] = a / n else Memr[avgs+i-1] = INDEFR if (DEBUG == YES) { call printf ("image %d: average = %g\n") call pargi (i) call pargr (Memr[avgs+i-1]) } } # Average balance factor for each subset with rejection. do j = 1, nsubsets { n = 0 do i = 1, nims { if (!IS_INDEFR(final[i]) || IS_INDEFR(stats[i,j]) || IS_INDEFR(Memr[avgs+i-1])) next Memr[ratios+i-1] = stats[i,j] / Memr[avgs+i-1] n = n + 1 if (DEBUG == YES) { call printf ("subset %d, image %d: ratio = %g\n") call pargi (j) call pargi (i) call pargr (Memr[ratios+i-1]) } } i = aravr (Memr[ratios], n, Memr[avgr+j-1], sig, 2.) if (DEBUG == YES) { call printf ("subset %d: n = %d, average = %g, sig = %g\n") call pargi (j) call pargi (i) call pargr (Memr[avgr+j-1]) call pargr (sig) } } # Average balance corrected value for each image with rejection. do i = 1, nims { if (!IS_INDEFR(final[i])) next n = 0 do j = 1, nsubsets { if (IS_INDEFR(stats[i,j]) || IS_INDEFR(Memr[avgr+j-1])) next Memr[ratios+j-1] = stats[i,j] / Memr[avgr+j-1] n = n + 1 if (DEBUG == YES) { call printf ("image %d, subset %d: ratio = %g\n") call pargi (i) call pargi (j) call pargr (Memr[ratios+j-1]) } } j = aravr (Memr[ratios], n, final[i], sig, 2.) if (DEBUG == YES) { call printf ("image %d: n = %d, average = %g, sig = %g\n") call pargi (i) call pargi (j) call pargr (final[i]) call pargr (sig) } } call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/mergeamps.par000066400000000000000000000042101332166314300226650ustar00rootroot00000000000000# MERGEAMPS input,s,a,,,,List of images to combine output,s,a,,,,List of output images outmasks,s,a,,,,List of output masks headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,List of sigma images (optional) imcmb,s,h,"$I",,,Keyword for IMCMB keywords outnames,s,h,"",,,"File for list of output names " ccdtype,s,h,"",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,no,,,Combine images by subset? delete,b,h,no,,,"Delete input images after combining? " combine,s,h,"average","average|median|sum",,Type of combine operation reject,s,h,"none","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection project,b,h,no,,,Project highest dimension of input images? outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) offsets,f,h,"physical",,,Input image offsets masktype,s,h,"none",,,Mask type maskvalue,s,h,"0",,,Mask value blank,r,h,1.,,,"Value if there are no pixels " scale,s,h,"none",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights statsec,s,h,"",,,"Image section for computing statistics " lthreshold,r,h,INDEF,,,Lower threshold hthreshold,r,h,INDEF,,,Upper threshold nlow,i,h,1,0,,minmax: Number of low pixels to reject nhigh,i,h,1,0,,minmax: Number of high pixels to reject nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) mclip,b,h,yes,,,Use median in sigma clipping algorithms? lsigma,r,h,3.,0.,,Lower sigma clipping factor hsigma,r,h,3.,0.,,Upper sigma clipping factor rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections pclip,r,h,-0.5,,,pclip: Percentile clipping parameter grow,r,h,0.,0.,,"Radius (pixels) for neighbor rejection " verbose,b,h,no,,,Verbose? mscred-5.05-2018.07.09/src/ccdred/src/combine/mkpkg000066400000000000000000000016561332166314300212500ustar00rootroot00000000000000# Make COMBINE Package. $call lcombine $call relink $exit update: $call relink $call install ; relink: $checkout x_combine.o mscbin$ $iffile (lib$libimc.a) $set LIBS1 = "-limc -lccdred -lmscred -lxtools -lcurfit -lsurfit" $set LIBS2 = "-lgsurfit -liminterp -lnlfit -lslalib -lncar -lgks" $else $set LIBS1 = "-lccdred -lmscred -lxtools -lcurfit -lsurfit" $set LIBS2 = "-lgsurfit -liminterp -lnlfit -lslalib -lncar -lgks" $endif $omake x_combine.x $link x_combine.o -lcombine $(LIBS1) $(LIBS2) -o xx_combine.e $checkin x_combine.o mscbin$ ; install: $move xx_combine.e mscbin$x_combine.e ; lcombine: $checkout libcombine.a mscbin$ $update libcombine.a $checkin libcombine.a mscbin$ ; libcombine.a: $ifnfile (lib$libimc.a) @src $endif icmefscale.x src/icombine.com src/icombine.h t_combine.x ../ccdred.h src/icombine.com src/icombine.h \ ; mscred-5.05-2018.07.09/src/ccdred/src/combine/scombine.par000066400000000000000000000041131332166314300225060ustar00rootroot00000000000000# SCOMBINE -- Image combine parameters for sky flats input,s,a,,,,List of images to combine output,s,a,,,,List of output images headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,List of sigma images (optional) imcmb,s,h,"$I",,,"Keyword for IMCMB keywords " ccdtype,s,h,"object",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,no,,,Combine images by subset? delete,b,h,no,,,"Delete input images after combining? " combine,s,h,"average","average|median|sum",,Type of combine operation reject,s,h,"ccdclip","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection project,b,h,no,,,Project highest dimension of input images? outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) offsets,f,h,"none",,,Input image offsets masktype,s,h,"none",,,Mask type maskvalue,s,h,"0",,,Mask value blank,r,h,1.,,,"Value if there are no pixels " scale,s,h,"mode",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights statsec,s,h,"",,,"Image section for computing statistics " lthreshold,r,h,INDEF,,,Lower threshold hthreshold,r,h,INDEF,,,Upper threshold nlow,i,h,0,0,,minmax: Number of low pixels to reject nhigh,i,h,1,0,,minmax: Number of high pixels to reject nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) mclip,b,h,yes,,,Use median in sigma clipping algorithms? lsigma,r,h,3.,0.,,Lower sigma clipping factor hsigma,r,h,3.,0.,,Upper sigma clipping factor rdnoise,s,h,"rdnoise",,,ccdclip: CCD readout noise (electrons) gain,s,h,"gain",,,ccdclip: CCD gain (electrons/DN) snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections pclip,r,h,-0.5,,,pclip: Percentile clipping parameter grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection mscred-5.05-2018.07.09/src/ccdred/src/combine/src/000077500000000000000000000000001332166314300207735ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/src/combine/src/Revisions000066400000000000000000000015171332166314300227030ustar00rootroot00000000000000.help revisions Jul04 imcombine/src .nf This directory contains generic code used in various tasks that combine images. ======= V2.13 ======= icgdata.gx Fixed a problem where 3-D images were closing an image in the case of many bands leading to a slow execution (10/20/06, Valdes) ======= V2.12.3 ======= icmask.x iclog.x icombine.h As a special unadvertised feature the "maskvalue" parameter may be specified with a leading '<' or '>'. Ultimately a full expression should be added and documented. (7/26/04, Valdes) icmask.x Added a feature to allow masks specified without a path to be found either in the current directory or the directory with the image. This is useful when images to be combined are distributed across multiple directories. (7/16/04, Valdes) ======== V2.12.2a ======== .endhelp mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/000077500000000000000000000000001332166314300224075ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icaclip.x000066400000000000000000001344571332166314300242220ustar00rootroot00000000000000# 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 = max (0, n[1]) s = 0. n2 = 0 do i = 1, npts { k = i - 1 n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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) sig = sqrt (s / (n2 - 1)) else { call sfree (sp) return } # Compute individual sigmas and iteratively clip. do i = 1, npts { k = i - 1 n1 = max (0, 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) && sig > 0.) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) for (; nl <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Mems[d[n3-1]+k] high = Mems[d[n3]+k] med = (low + high) / 2. } else med = Mems[d[n3]+k] } else med = blank } } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mems[d[l]+k] = Mems[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Mems[d[l]+k] = Mems[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag that the median is computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average # The average sigma is normalized by the expected poisson sigma. procedure ic_aavsigclipi (d, m, n, scales, zeros, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line real average[npts] # Average int i, j, k, l, jj, n1, n2, nin, nk, maxkeep real d1, low, high, sum, a, s, s1, r, one data one /1.0/ pointer sp, sums, resid, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are insufficient pixels go on to the combining. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (sums, npts, TY_REAL) call salloc (resid, nimages+1, TY_REAL) # Since the unweighted average is computed here possibly skip combining if (dowts || combine != AVERAGE) docombine = true else docombine = false # Compute the unweighted average with the high and low rejected and # the poisson scaled average sigma. There must be at least three # pixels at each point to define the average and contributions to # the mean sigma. Corrections for differences in the image # scale factors are selected by the doscale1 flag. nin = max (0, n[1]) s = 0. n2 = 0 do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (n1 < 3) next # Unweighted average with the high and low rejected low = Memi[d[1]+k] high = Memi[d[2]+k] if (low > high) { d1 = low low = high high = d1 } sum = 0. do j = 3, n1 { d1 = Memi[d[j]+k] if (d1 < low) { sum = sum + low low = d1 } else if (d1 > high) { sum = sum + high high = d1 } else sum = sum + d1 } a = sum / (n1 - 2) sum = sum + low + high # Poisson scaled sigma accumulation if (doscale1) { do j = 1, n1 { dp1 = d[j] + k mp1 = m[j] + k d1 = Memi[dp1] l = Memi[mp1] s1 = max (one, (a + zeros[l]) / scales[l]) s = s + (d1 - a) ** 2 / s1 } } else { s1 = max (one, a) do j = 1, n1 s = s + (Memi[d[j]+k] - a) ** 2 / s1 } n2 = n2 + n1 # Save the average and sum for later. average[i] = a Memr[sums+k] = sum } # Here is the final sigma. if (n2 > 1) s = sqrt (s / (n2 - 1)) # Reject pixels and compute the final average (if needed). # There must be at least three pixels at each point for rejection. # Iteratively scale the mean sigma and reject pixels # Compact the data and keep track of the image IDs if needed. do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) if (n1 <= max (2, maxkeep)) { if (!docombine) { if (n1 == 0) average[i] = blank else { sum = Memi[d[1]+k] do j = 2, n1 sum = sum + Memi[d[j]+k] average[i] = sum / n1 } } next } a = average[i] sum = Memr[sums+k] repeat { n2 = n1 if (s > 0.) { if (doscale1) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k d1 = Memi[dp1] l = Memi[mp1] s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) r = (d1 - a) / s1 if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memi[dp1] = Memi[dp2] Memi[dp2] = d1 mp2 = m[n1] + k Memi[mp1] = Memi[mp2] Memi[mp2] = l j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } else { s1 = s * sqrt (max (one, a)) for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k d1 = Memi[dp1] r = (d1 - a) / s1 if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memi[dp1] = Memi[dp2] Memi[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l } j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } if (n1 > 1) a = sum / n1 } until (n1 == n2 || n1 <= max (2, maxkeep)) # If too many are rejected add some back in. # Pixels with equal residuals are added together. if (n1 < maxkeep) { nk = maxkeep if (doscale1) { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memi[dp1] Memi[dp1] = Memi[dp2] Memi[dp2] = d1 mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } sum = sum + Memi[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } else { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memi[dp1] Memi[dp1] = Memi[dp2] Memi[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } } sum = sum + Memi[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } if (n1 > 1) a = sum / n1 } # Save the average if needed. n[i] = n1 if (!docombine) { if (n1 > 0) average[i] = a else average[i] = blank } } # Check if the data flag has to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } call sfree (sp) end # IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median # The average sigma is normalized by the expected poisson sigma. procedure ic_mavsigclipi (d, m, n, scales, zeros, nimages, npts, median) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line real median[npts] # Median int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep pointer sp, resid, mp1, mp2 real med, low, high, sig, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (n1 < 3) { if (n1 == 0) median[i] = blank else if (n1 == 1) median[i] = Memi[d[1]+k] else { low = Memi[d[1]+k] high = Memi[d[2]+k] median[i] = (low + high) / 2. } next } # Median n3 = 1 + n1 / 2 if (mod (n1, 2) == 0) { low = Memi[d[n3-1]+k] high = Memi[d[n3]+k] med = (low + high) / 2. } else med = Memi[d[n3]+k] # Poisson scaled sigma accumulation if (doscale1) { do j = 1, n1 { l = Memi[m[j]+k] s1 = max (one, (med + zeros[l]) / scales[l]) s = s + (Memi[d[j]+k] - med) ** 2 / s1 } } else { s1 = max (one, med) do j = 1, n1 s = s + (Memi[d[j]+k] - med) ** 2 / s1 } n2 = n2 + n1 # Save the median for later. median[i] = med } # Here is the final sigma. if (n2 > 1) sig = sqrt (s / (n2 - 1)) else { call sfree (sp) return } # Compute individual sigmas and iteratively clip. do i = 1, npts { k = i - 1 n1 = max (0, 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) && sig > 0.) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) r = (med - Memi[d[nl]+k]) / s1 if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { l = Memi[m[nh]+k] s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) r = (Memi[d[nh]+k] - med) / s1 if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } else { s1 = sig * sqrt (max (one, med)) for (; nl <= nh; nl = nl + 1) { r = (med - Memi[d[nl]+k]) / s1 if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { r = (Memi[d[nh]+k] - med) / s1 if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Memi[d[n3-1]+k] high = Memi[d[n3]+k] med = (low + high) / 2. } else med = Memi[d[n3]+k] } else med = blank } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) # If too many are rejected add some back in. # Pixels with equal residuals are added together. while (n1 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Memi[d[n3-1]+k] high = Memi[d[n3]+k] med = (low + high) / 2. } else med = Memi[d[n3]+k] } else med = blank } } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memi[d[l]+k] = Memi[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memi[d[l]+k] = Memi[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 = max (0, n[1]) s = 0. n2 = 0 do i = 1, npts { k = i - 1 n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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) sig = sqrt (s / (n2 - 1)) else { call sfree (sp) return } # Compute individual sigmas and iteratively clip. do i = 1, npts { k = i - 1 n1 = max (0, 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) && sig > 0.) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) for (; nl <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Memr[d[n3-1]+k] high = Memr[d[n3]+k] med = (low + high) / 2. } else med = Memr[d[n3]+k] } else med = blank } } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memr[d[l]+k] = Memr[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memr[d[l]+k] = Memr[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag that the median is computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average # The average sigma is normalized by the expected poisson sigma. procedure ic_aavsigclipd (d, m, n, scales, zeros, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line double average[npts] # Average int i, j, k, l, jj, n1, n2, nin, nk, maxkeep double d1, low, high, sum, a, s, s1, r, one data one /1.0D0/ pointer sp, sums, resid, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are insufficient pixels go on to the combining. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (sums, npts, TY_REAL) call salloc (resid, nimages+1, TY_REAL) # Since the unweighted average is computed here possibly skip combining if (dowts || combine != AVERAGE) docombine = true else docombine = false # Compute the unweighted average with the high and low rejected and # the poisson scaled average sigma. There must be at least three # pixels at each point to define the average and contributions to # the mean sigma. Corrections for differences in the image # scale factors are selected by the doscale1 flag. nin = max (0, n[1]) s = 0. n2 = 0 do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (n1 < 3) next # Unweighted average with the high and low rejected low = Memd[d[1]+k] high = Memd[d[2]+k] if (low > high) { d1 = low low = high high = d1 } sum = 0. do j = 3, n1 { d1 = Memd[d[j]+k] if (d1 < low) { sum = sum + low low = d1 } else if (d1 > high) { sum = sum + high high = d1 } else sum = sum + d1 } a = sum / (n1 - 2) sum = sum + low + high # Poisson scaled sigma accumulation if (doscale1) { do j = 1, n1 { dp1 = d[j] + k mp1 = m[j] + k d1 = Memd[dp1] l = Memi[mp1] s1 = max (one, (a + zeros[l]) / scales[l]) s = s + (d1 - a) ** 2 / s1 } } else { s1 = max (one, a) do j = 1, n1 s = s + (Memd[d[j]+k] - a) ** 2 / s1 } n2 = n2 + n1 # Save the average and sum for later. average[i] = a Memr[sums+k] = sum } # Here is the final sigma. if (n2 > 1) s = sqrt (s / (n2 - 1)) # Reject pixels and compute the final average (if needed). # There must be at least three pixels at each point for rejection. # Iteratively scale the mean sigma and reject pixels # Compact the data and keep track of the image IDs if needed. do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) if (n1 <= max (2, maxkeep)) { if (!docombine) { if (n1 == 0) average[i] = blank else { sum = Memd[d[1]+k] do j = 2, n1 sum = sum + Memd[d[j]+k] average[i] = sum / n1 } } next } a = average[i] sum = Memr[sums+k] repeat { n2 = n1 if (s > 0.) { if (doscale1) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k d1 = Memd[dp1] l = Memi[mp1] s1 = s * sqrt (max (one, (a+zeros[l]) / scales[l])) r = (d1 - a) / s1 if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memd[dp1] = Memd[dp2] Memd[dp2] = d1 mp2 = m[n1] + k Memi[mp1] = Memi[mp2] Memi[mp2] = l j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } else { s1 = s * sqrt (max (one, a)) for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k d1 = Memd[dp1] r = (d1 - a) / s1 if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memd[dp1] = Memd[dp2] Memd[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l } j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } if (n1 > 1) a = sum / n1 } until (n1 == n2 || n1 <= max (2, maxkeep)) # If too many are rejected add some back in. # Pixels with equal residuals are added together. if (n1 < maxkeep) { nk = maxkeep if (doscale1) { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memd[dp1] Memd[dp1] = Memd[dp2] Memd[dp2] = d1 mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } sum = sum + Memd[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } else { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memd[dp1] Memd[dp1] = Memd[dp2] Memd[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } } sum = sum + Memd[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } if (n1 > 1) a = sum / n1 } # Save the average if needed. n[i] = n1 if (!docombine) { if (n1 > 0) average[i] = a else average[i] = blank } } # Check if the data flag has to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } call sfree (sp) end # IC_MAVSIGCLIP -- Reject pixels using an average sigma about the median # The average sigma is normalized by the expected poisson sigma. procedure ic_mavsigclipd (d, m, n, scales, zeros, nimages, npts, median) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line double median[npts] # Median int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep pointer sp, resid, mp1, mp2 double med, low, high, sig, r, s, s1, one data one /1.0D0/ include "../icombine.com" begin # If there are insufficient pixels go on to the combining. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (resid, nimages+1, TY_REAL) # Compute the poisson scaled average sigma about the median. # There must be at least three pixels at each point to define # the mean sigma. Corrections for differences in the image # scale factors are selected by the doscale1 flag. s = 0. n2 = 0 nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (n1 < 3) { if (n1 == 0) median[i] = blank else if (n1 == 1) median[i] = Memd[d[1]+k] else { low = Memd[d[1]+k] high = Memd[d[2]+k] median[i] = (low + high) / 2. } next } # Median n3 = 1 + n1 / 2 if (mod (n1, 2) == 0) { low = Memd[d[n3-1]+k] high = Memd[d[n3]+k] med = (low + high) / 2. } else med = Memd[d[n3]+k] # Poisson scaled sigma accumulation if (doscale1) { do j = 1, n1 { l = Memi[m[j]+k] s1 = max (one, (med + zeros[l]) / scales[l]) s = s + (Memd[d[j]+k] - med) ** 2 / s1 } } else { s1 = max (one, med) do j = 1, n1 s = s + (Memd[d[j]+k] - med) ** 2 / s1 } n2 = n2 + n1 # Save the median for later. median[i] = med } # Here is the final sigma. if (n2 > 1) sig = sqrt (s / (n2 - 1)) else { call sfree (sp) return } # Compute individual sigmas and iteratively clip. do i = 1, npts { k = i - 1 n1 = max (0, 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) && sig > 0.) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) r = (med - Memd[d[nl]+k]) / s1 if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { l = Memi[m[nh]+k] s1 = sig * sqrt (max (one, (med+zeros[l])/scales[l])) r = (Memd[d[nh]+k] - med) / s1 if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } else { s1 = sig * sqrt (max (one, med)) for (; nl <= nh; nl = nl + 1) { r = (med - Memd[d[nl]+k]) / s1 if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { r = (Memd[d[nh]+k] - med) / s1 if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Memd[d[n3-1]+k] high = Memd[d[n3]+k] med = (low + high) / 2. } else med = Memd[d[n3]+k] } else med = blank } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) # If too many are rejected add some back in. # Pixels with equal residuals are added together. while (n1 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Memd[d[n3-1]+k] high = Memd[d[n3]+k] med = (low + high) / 2. } else med = Memd[d[n3]+k] } else med = blank } } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memd[d[l]+k] = Memd[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memd[d[l]+k] = Memd[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icaverage.x000066400000000000000000000224371332166314300245360ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" include "../icmask.h" # IC_AVERAGE -- Compute the average (or summed) image line. # Options include a weighted average/sum. procedure ic_averages (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real sumwt, wt real sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Mems[d[1]+k] * wt do j = 2, n[i] { wt = wts[Memi[m[j]+k]] sum = sum + Mems[d[j]+k] * wt } average[i] = sum } } else { do i = 1, npts { k = i - 1 sum = Mems[d[1]+k] do j = 2, n[i] sum = sum + Mems[d[j]+k] if (doaverage == YES) average[i] = sum / n[i] else average[i] = sum } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Mems[d[1]+k] * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + Mems[d[j]+k] * wt sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sum / sumwt else { sum = Mems[d[1]+k] do j = 2, n1 sum = sum + Mems[d[j]+k] average[i] = sum / n1 } } else average[i] = sum } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 sum = Mems[d[1]+k] do j = 2, n1 sum = sum + Mems[d[j]+k] if (doaverage == YES) average[i] = sum / n1 else average[i] = sum } else if (doblank == YES) average[i] = blank } } } end # IC_AVERAGE -- Compute the average (or summed) image line. # Options include a weighted average/sum. procedure ic_averagei (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real sumwt, wt real sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Memi[d[1]+k] * wt do j = 2, n[i] { wt = wts[Memi[m[j]+k]] sum = sum + Memi[d[j]+k] * wt } average[i] = sum } } else { do i = 1, npts { k = i - 1 sum = Memi[d[1]+k] do j = 2, n[i] sum = sum + Memi[d[j]+k] if (doaverage == YES) average[i] = sum / n[i] else average[i] = sum } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Memi[d[1]+k] * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + Memi[d[j]+k] * wt sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sum / sumwt else { sum = Memi[d[1]+k] do j = 2, n1 sum = sum + Memi[d[j]+k] average[i] = sum / n1 } } else average[i] = sum } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 sum = Memi[d[1]+k] do j = 2, n1 sum = sum + Memi[d[j]+k] if (doaverage == YES) average[i] = sum / n1 else average[i] = sum } else if (doblank == YES) average[i] = blank } } } end # IC_AVERAGE -- Compute the average (or summed) image line. # Options include a weighted average/sum. procedure ic_averager (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real sumwt, wt real sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Memr[d[1]+k] * wt do j = 2, n[i] { wt = wts[Memi[m[j]+k]] sum = sum + Memr[d[j]+k] * wt } average[i] = sum } } else { do i = 1, npts { k = i - 1 sum = Memr[d[1]+k] do j = 2, n[i] sum = sum + Memr[d[j]+k] if (doaverage == YES) average[i] = sum / n[i] else average[i] = sum } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Memr[d[1]+k] * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + Memr[d[j]+k] * wt sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sum / sumwt else { sum = Memr[d[1]+k] do j = 2, n1 sum = sum + Memr[d[j]+k] average[i] = sum / n1 } } else average[i] = sum } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 sum = Memr[d[1]+k] do j = 2, n1 sum = sum + Memr[d[j]+k] if (doaverage == YES) average[i] = sum / n1 else average[i] = sum } else if (doblank == YES) average[i] = blank } } } end # IC_AVERAGE -- Compute the average (or summed) image line. # Options include a weighted average/sum. procedure ic_averaged (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? double average[npts] # Average (returned) int i, j, k, n1 real sumwt, wt double sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Memd[d[1]+k] * wt do j = 2, n[i] { wt = wts[Memi[m[j]+k]] sum = sum + Memd[d[j]+k] * wt } average[i] = sum } } else { do i = 1, npts { k = i - 1 sum = Memd[d[1]+k] do j = 2, n[i] sum = sum + Memd[d[j]+k] if (doaverage == YES) average[i] = sum / n[i] else average[i] = sum } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Memd[d[1]+k] * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + Memd[d[j]+k] * wt sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sum / sumwt else { sum = Memd[d[1]+k] do j = 2, n1 sum = sum + Memd[d[j]+k] average[i] = sum / n1 } } else average[i] = sum } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 sum = Memd[d[1]+k] do j = 2, n1 sum = sum + Memd[d[j]+k] if (doaverage == YES) average[i] = sum / n1 else average[i] = sum } else if (doblank == YES) average[i] = blank } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/iccclip.x000066400000000000000000001132321332166314300242100ustar00rootroot00000000000000# 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mems[d[l]+k] = Mems[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Mems[d[l]+k] = Mems[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag that the median is computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average procedure ic_accdclipi (d, m, n, scales, zeros, nm, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros real nm[3,nimages] # Noise model parameters int nimages # Number of images int npts # Number of output points per line real average[npts] # Average int i, j, k, l, jj, n1, n2, nin, nk, maxkeep real d1, low, high, sum, a, s, r, zero data zero /0.0/ pointer sp, resid, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are no pixels go on to the combining. Since the unweighted # average is computed here possibly skip the combining later. # There must be at least max (1, nkeep) pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } else if (dowts || combine != AVERAGE) docombine = true else docombine = false call smark (sp) call salloc (resid, nimages+1, TY_REAL) # There must be at least two pixels for rejection. The initial # average is the low/high rejected average except in the case of # just two pixels. The rejections are iterated and the average # is recomputed. Corrections for scaling may be performed. # Depending on other flags the image IDs may also need to be adjusted. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) if (n1 <= max (MINCLIP-1, maxkeep)) { if (!docombine) { if (n1 == 0) average[i] = blank else { sum = Memi[d[1]+k] do j = 2, n1 sum = sum + Memi[d[j]+k] average[i] = sum / n1 } } next } repeat { if (n1 == 2) { sum = Memi[d[1]+k] sum = sum + Memi[d[2]+k] a = sum / 2 } else { low = Memi[d[1]+k] high = Memi[d[2]+k] if (low > high) { d1 = low low = high high = d1 } sum = 0. do j = 3, n1 { d1 = Memi[d[j]+k] if (d1 < low) { sum = sum + low low = d1 } else if (d1 > high) { sum = sum + high high = d1 } else sum = sum + d1 } a = sum / (n1 - 2) sum = sum + low + high } n2 = n1 if (doscale1) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k l = Memi[mp1] s = scales[l] d1 = max (zero, s * (a + zeros[l])) s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s d1 = Memi[dp1] r = (d1 - a) / s if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memi[dp1] = Memi[dp2] Memi[dp2] = d1 mp2 = m[n1] + k Memi[mp1] = Memi[mp2] Memi[mp2] = l j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } else { if (!keepids) { s = max (zero, a) s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) } for (j=1; j<=n1; j=j+1) { if (keepids) { l = Memi[m[j]+k] s = max (zero, a) s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) } dp1 = d[j] + k d1 = Memi[dp1] r = (d1 - a) / s if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memi[dp1] = Memi[dp2] Memi[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l } j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) if (n1 < maxkeep) { nk = maxkeep if (doscale1) { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memi[dp1] Memi[dp1] = Memi[dp2] Memi[dp2] = d1 mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } sum = sum + Memi[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } else { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memi[dp1] Memi[dp1] = Memi[dp2] Memi[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } } sum = sum + Memi[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } } n[i] = n1 if (!docombine) if (n1 > 0) average[i] = sum / n1 else average[i] = blank } # Check if the data flag has to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } call sfree (sp) end # IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median procedure ic_mccdclipi (d, m, n, scales, zeros, nm, nimages, npts, median) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros real nm[3,nimages] # Noise model int nimages # Number of images int npts # Number of output points per line real median[npts] # Median int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep real r, s pointer sp, resid, mp1, mp2 real med, zero data zero /0.0/ include "../icombine.com" begin # There must be at least max (MINCLIP, nkeep+1) pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (resid, nimages+1, TY_REAL) # Compute median and sigma and iteratively clip. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) nl = 1 nh = n1 repeat { n2 = n1 n3 = nl + n1 / 2 if (n1 == 0) med = blank else if (mod (n1, 2) == 0) { med = Memi[d[n3-1]+k] med = (med + Memi[d[n3]+k]) / 2. } else med = Memi[d[n3]+k] if (n1 >= max (MINCLIP, maxkeep+1)) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s = scales[l] r = max (zero, s * (med + zeros[l])) s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s r = (med - Memi[d[nl]+k]) / s if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { l = Memi[m[nh]+k] s = scales[l] r = max (zero, s * (med + zeros[l])) s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s r = (Memi[d[nh]+k] - med) / s if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } else { if (!keepids) { s = max (zero, med) s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) } for (; nl <= nh; nl = nl + 1) { if (keepids) { l = Memi[m[nl]+k] s = max (zero, med) s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) } r = (med - Memi[d[nl]+k]) / s if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { if (keepids) { l = Memi[m[nh]+k] s = max (zero, med) s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) } r = (Memi[d[nh]+k] - med) / s if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) while (n1 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memi[d[l]+k] = Memi[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memi[d[l]+k] = Memi[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memr[d[l]+k] = Memr[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memr[d[l]+k] = Memr[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag that the median is computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average procedure ic_accdclipd (d, m, n, scales, zeros, nm, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros real nm[3,nimages] # Noise model parameters int nimages # Number of images int npts # Number of output points per line double average[npts] # Average int i, j, k, l, jj, n1, n2, nin, nk, maxkeep double d1, low, high, sum, a, s, r, zero data zero /0.0D0/ pointer sp, resid, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are no pixels go on to the combining. Since the unweighted # average is computed here possibly skip the combining later. # There must be at least max (1, nkeep) pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } else if (dowts || combine != AVERAGE) docombine = true else docombine = false call smark (sp) call salloc (resid, nimages+1, TY_REAL) # There must be at least two pixels for rejection. The initial # average is the low/high rejected average except in the case of # just two pixels. The rejections are iterated and the average # is recomputed. Corrections for scaling may be performed. # Depending on other flags the image IDs may also need to be adjusted. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) if (n1 <= max (MINCLIP-1, maxkeep)) { if (!docombine) { if (n1 == 0) average[i] = blank else { sum = Memd[d[1]+k] do j = 2, n1 sum = sum + Memd[d[j]+k] average[i] = sum / n1 } } next } repeat { if (n1 == 2) { sum = Memd[d[1]+k] sum = sum + Memd[d[2]+k] a = sum / 2 } else { low = Memd[d[1]+k] high = Memd[d[2]+k] if (low > high) { d1 = low low = high high = d1 } sum = 0. do j = 3, n1 { d1 = Memd[d[j]+k] if (d1 < low) { sum = sum + low low = d1 } else if (d1 > high) { sum = sum + high high = d1 } else sum = sum + d1 } a = sum / (n1 - 2) sum = sum + low + high } n2 = n1 if (doscale1) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k l = Memi[mp1] s = scales[l] d1 = max (zero, s * (a + zeros[l])) s = sqrt (nm[1,l] + d1/nm[2,l] + (d1*nm[3,l])**2) / s d1 = Memd[dp1] r = (d1 - a) / s if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memd[dp1] = Memd[dp2] Memd[dp2] = d1 mp2 = m[n1] + k Memi[mp1] = Memi[mp2] Memi[mp2] = l j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } else { if (!keepids) { s = max (zero, a) s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) } for (j=1; j<=n1; j=j+1) { if (keepids) { l = Memi[m[j]+k] s = max (zero, a) s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) } dp1 = d[j] + k d1 = Memd[dp1] r = (d1 - a) / s if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs(r) if (j < n1) { dp2 = d[n1] + k Memd[dp1] = Memd[dp2] Memd[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l } j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) if (n1 < maxkeep) { nk = maxkeep if (doscale1) { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memd[dp1] Memd[dp1] = Memd[dp2] Memd[dp2] = d1 mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } sum = sum + Memd[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } else { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memd[dp1] Memd[dp1] = Memd[dp2] Memd[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } } sum = sum + Memd[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } } n[i] = n1 if (!docombine) if (n1 > 0) average[i] = sum / n1 else average[i] = blank } # Check if the data flag has to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } call sfree (sp) end # IC_CCDCLIP -- Reject pixels using CCD noise parameters about the median procedure ic_mccdclipd (d, m, n, scales, zeros, nm, nimages, npts, median) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros real nm[3,nimages] # Noise model int nimages # Number of images int npts # Number of output points per line double median[npts] # Median int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep real r, s pointer sp, resid, mp1, mp2 double med, zero data zero /0.0D0/ include "../icombine.com" begin # There must be at least max (MINCLIP, nkeep+1) pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (resid, nimages+1, TY_REAL) # Compute median and sigma and iteratively clip. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) nl = 1 nh = n1 repeat { n2 = n1 n3 = nl + n1 / 2 if (n1 == 0) med = blank else if (mod (n1, 2) == 0) { med = Memd[d[n3-1]+k] med = (med + Memd[d[n3]+k]) / 2. } else med = Memd[d[n3]+k] if (n1 >= max (MINCLIP, maxkeep+1)) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s = scales[l] r = max (zero, s * (med + zeros[l])) s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s r = (med - Memd[d[nl]+k]) / s if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { l = Memi[m[nh]+k] s = scales[l] r = max (zero, s * (med + zeros[l])) s = sqrt (nm[1,l] + r/nm[2,l] + (r*nm[3,l])**2) / s r = (Memd[d[nh]+k] - med) / s if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } else { if (!keepids) { s = max (zero, med) s = sqrt (nm[1,1] + s/nm[2,1] + (s*nm[3,1])**2) } for (; nl <= nh; nl = nl + 1) { if (keepids) { l = Memi[m[nl]+k] s = max (zero, med) s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) } r = (med - Memd[d[nl]+k]) / s if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { if (keepids) { l = Memi[m[nh]+k] s = max (zero, med) s = sqrt (nm[1,l] + s/nm[2,l] + (s*nm[3,l])**2) } r = (Memd[d[nh]+k] - med) / s if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) while (n1 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memd[d[l]+k] = Memd[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memd[d[l]+k] = Memd[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icgdata.x000066400000000000000000001002331332166314300241730ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" # IC_GDATA -- Get line of image and mask data and apply threshold and scaling. # Entirely empty lines are excluded. The data are compacted within the # input data buffers. If it is required, the connection to the original # image index is kept in the returned m data pointers. procedure ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, v1, v2) pointer in[nimages] # Input images pointer out[ARB] # Output images pointer dbuf[nimages] # Data buffers pointer d[nimages] # Data pointers pointer id[nimages] # ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Empty mask flags int offsets[nimages,ARB] # Image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors int nimages # Number of input images int npts # NUmber of output points per line long v1[ARB], v2[ARB] # Line vectors short temp int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnls() real a, b pointer buf, dp, ip, mp errchk xt_cpix, xt_imgnls short max_pixel data max_pixel/MAX_SHORT/ include "../icombine.com" begin # Get masks and return if there is no data call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) if (dflag == D_NONE) { call aclri (n, npts) return } # Close images which are not needed. nout = IM_LEN(out[1],1) ndim = IM_NDIM(out[1]) if (!project && ndim < 3) { do i = 1, nimages { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) call xt_cpix (i) if (ndim > 1) { j = v1[2] - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } } } # Get data and fill data buffers. Correct for offsets if needed. do i = 1, nimages { if (lflag[i] == D_NONE) next if (dbuf[i] == NULL) { call amovl (v1, v2, IM_MAXDIM) if (project) v2[ndim+1] = i j = xt_imgnls (in[i], i, d[i], v2, v1[2]) } else { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) { lflag[i] = D_NONE next } k = 1 + j - offsets[i,1] v2[1] = k do l = 2, ndim { v2[l] = v1[l] - offsets[i,l] if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { lflag[i] = D_NONE break } } if (lflag[i] == D_NONE) next if (project) v2[ndim+1] = i l = xt_imgnls (in[i], i, buf, v2, v1[2]) call amovs (Mems[buf+k-1], Mems[dbuf[i]+j], npix) d[i] = dbuf[i] } } # Set values to max_pixel if needed. if (mtype == M_NOVAL) { do i = 1, nimages { dp = d[i]; mp = m[i] if (lflag[i] == D_NONE || dp == NULL) next else if (lflag[i] == D_MIX) { do j = 1, npts { if (Memi[mp] == 1) Mems[dp] = max_pixel dp = dp + 1 mp = mp + 1 } } } } # Apply threshold if needed if (dothresh) { do i = 1, nimages { if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { a = Mems[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 lflag[i] = D_MIX dflag = D_MIX } dp = dp + 1 } # Check for completely empty lines if (lflag[i] == D_MIX) { lflag[i] = D_NONE mp = m[i] do j = 1, npts { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) { a = Mems[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 dflag = D_MIX } } dp = dp + 1 mp = mp + 1 } # Check for completely empty lines lflag[i] = D_NONE mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } } # Apply scaling (avoiding masked pixels which might overflow?) if (doscale) { if (dflag == D_ALL) { do i = 1, nimages { dp = d[i] a = scales[i] b = -zeros[i] do j = 1, npts { Mems[dp] = Mems[dp] / a + b dp = dp + 1 } } } else if (dflag == D_MIX) { do i = 1, nimages { a = scales[i] b = -zeros[i] if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { Mems[dp] = Mems[dp] / a + b dp = dp + 1 } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) 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 } } do i = nused+1, nimages d[i] = NULL if (nused == 0) dflag = D_NONE } # Compact data to remove bad pixels # Keep track of the image indices if needed # If growing mark the end of the included image indices with zero if (dflag == D_ALL) { call amovki (nused, n, npts) if (keepids) do i = 1, nimages call amovki (i, Memi[id[i]], npts) } else if (dflag == D_NONE) call aclri (n, npts) else { call aclri (n, npts) if (keepids) { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 ip = id[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { Memi[ip] = l if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Mems[d[k]+j-1] Mems[d[k]+j-1] = Mems[dp] Mems[dp] = temp Memi[ip] = Memi[id[k]+j-1] Memi[id[k]+j-1] = l Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 ip = ip + 1 mp = mp + 1 } } if (grow >= 1.) { do j = 1, npts { do i = n[j]+1, nused Memi[id[i]+j-1] = 0 } } } else { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Mems[d[k]+j-1] Mems[d[k]+j-1] = Mems[dp] Mems[dp] = temp Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 mp = mp + 1 } } } } # Sort the pixels and IDs if needed if (mclip) { call malloc (dp, nused, TY_SHORT) if (keepids) { call malloc (ip, nused, 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) } # If no good pixels set the number of usable values as -n and # shift them to lower values. if (mtype == M_NOVAL) { if (keepids) { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 ip = id[i] + j - 1 if (Mems[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) { Mems[d[k]+j-1] = Mems[dp] Memi[id[k]+j-1] = Memi[ip] } } } } } else { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 if (Mems[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) Mems[d[k]+j-1] = Mems[dp] } } } } } end # IC_GDATA -- Get line of image and mask data and apply threshold and scaling. # Entirely empty lines are excluded. The data are compacted within the # input data buffers. If it is required, the connection to the original # image index is kept in the returned m data pointers. procedure ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, v1, v2) pointer in[nimages] # Input images pointer out[ARB] # Output images pointer dbuf[nimages] # Data buffers pointer d[nimages] # Data pointers pointer id[nimages] # ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Empty mask flags int offsets[nimages,ARB] # Image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors int nimages # Number of input images int npts # NUmber of output points per line long v1[ARB], v2[ARB] # Line vectors int temp int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnli() real a, b pointer buf, dp, ip, mp errchk xt_cpix, xt_imgnli int max_pixel data max_pixel/MAX_INT/ include "../icombine.com" begin # Get masks and return if there is no data call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) if (dflag == D_NONE) { call aclri (n, npts) return } # Close images which are not needed. nout = IM_LEN(out[1],1) ndim = IM_NDIM(out[1]) if (!project && ndim < 3) { do i = 1, nimages { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) call xt_cpix (i) if (ndim > 1) { j = v1[2] - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } } } # Get data and fill data buffers. Correct for offsets if needed. do i = 1, nimages { if (lflag[i] == D_NONE) next if (dbuf[i] == NULL) { call amovl (v1, v2, IM_MAXDIM) if (project) v2[ndim+1] = i j = xt_imgnli (in[i], i, d[i], v2, v1[2]) } else { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) { lflag[i] = D_NONE next } k = 1 + j - offsets[i,1] v2[1] = k do l = 2, ndim { v2[l] = v1[l] - offsets[i,l] if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { lflag[i] = D_NONE break } } if (lflag[i] == D_NONE) next if (project) v2[ndim+1] = i l = xt_imgnli (in[i], i, buf, v2, v1[2]) call amovi (Memi[buf+k-1], Memi[dbuf[i]+j], npix) d[i] = dbuf[i] } } # Set values to max_pixel if needed. if (mtype == M_NOVAL) { do i = 1, nimages { dp = d[i]; mp = m[i] if (lflag[i] == D_NONE || dp == NULL) next else if (lflag[i] == D_MIX) { do j = 1, npts { if (Memi[mp] == 1) Memi[dp] = max_pixel dp = dp + 1 mp = mp + 1 } } } } # Apply threshold if needed if (dothresh) { do i = 1, nimages { if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { a = Memi[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 lflag[i] = D_MIX dflag = D_MIX } dp = dp + 1 } # Check for completely empty lines if (lflag[i] == D_MIX) { lflag[i] = D_NONE mp = m[i] do j = 1, npts { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) { a = Memi[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 dflag = D_MIX } } dp = dp + 1 mp = mp + 1 } # Check for completely empty lines lflag[i] = D_NONE mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } } # Apply scaling (avoiding masked pixels which might overflow?) if (doscale) { if (dflag == D_ALL) { do i = 1, nimages { dp = d[i] a = scales[i] b = -zeros[i] do j = 1, npts { Memi[dp] = Memi[dp] / a + b dp = dp + 1 } } } else if (dflag == D_MIX) { do i = 1, nimages { a = scales[i] b = -zeros[i] if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { Memi[dp] = Memi[dp] / a + b dp = dp + 1 } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) Memi[dp] = Memi[dp] / a + b dp = dp + 1 mp = mp + 1 } } } } } # Sort pointers to exclude unused images. # Use the lflag array to keep track of the image index. if (dflag == D_ALL) nused = nimages else { nused = 0 do i = 1, nimages { if (lflag[i] != D_NONE) { nused = nused + 1 d[nused] = d[i] m[nused] = m[i] lflag[nused] = i } } do i = nused+1, nimages d[i] = NULL if (nused == 0) dflag = D_NONE } # Compact data to remove bad pixels # Keep track of the image indices if needed # If growing mark the end of the included image indices with zero if (dflag == D_ALL) { call amovki (nused, n, npts) if (keepids) do i = 1, nimages call amovki (i, Memi[id[i]], npts) } else if (dflag == D_NONE) call aclri (n, npts) else { call aclri (n, npts) if (keepids) { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 ip = id[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { Memi[ip] = l if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Memi[d[k]+j-1] Memi[d[k]+j-1] = Memi[dp] Memi[dp] = temp Memi[ip] = Memi[id[k]+j-1] Memi[id[k]+j-1] = l Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 ip = ip + 1 mp = mp + 1 } } if (grow >= 1.) { do j = 1, npts { do i = n[j]+1, nused Memi[id[i]+j-1] = 0 } } } else { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Memi[d[k]+j-1] Memi[d[k]+j-1] = Memi[dp] Memi[dp] = temp Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 mp = mp + 1 } } } } # Sort the pixels and IDs if needed if (mclip) { call malloc (dp, nused, TY_INT) if (keepids) { call malloc (ip, nused, TY_INT) call ic_2sorti (d, Memi[dp], id, Memi[ip], n, npts) call mfree (ip, TY_INT) } else call ic_sorti (d, Memi[dp], n, npts) call mfree (dp, TY_INT) } # If no good pixels set the number of usable values as -n and # shift them to lower values. if (mtype == M_NOVAL) { if (keepids) { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 ip = id[i] + j - 1 if (Memi[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) { Memi[d[k]+j-1] = Memi[dp] Memi[id[k]+j-1] = Memi[ip] } } } } } else { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 if (Memi[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) Memi[d[k]+j-1] = Memi[dp] } } } } } end # IC_GDATA -- Get line of image and mask data and apply threshold and scaling. # Entirely empty lines are excluded. The data are compacted within the # input data buffers. If it is required, the connection to the original # image index is kept in the returned m data pointers. procedure ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, v1, v2) pointer in[nimages] # Input images pointer out[ARB] # Output images pointer dbuf[nimages] # Data buffers pointer d[nimages] # Data pointers pointer id[nimages] # ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Empty mask flags int offsets[nimages,ARB] # Image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors int nimages # Number of input images int npts # NUmber of output points per line long v1[ARB], v2[ARB] # Line vectors real temp int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnlr() real a, b pointer buf, dp, ip, mp errchk xt_cpix, xt_imgnlr real max_pixel data max_pixel/MAX_REAL/ include "../icombine.com" begin # Get masks and return if there is no data call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) if (dflag == D_NONE) { call aclri (n, npts) return } # Close images which are not needed. nout = IM_LEN(out[1],1) ndim = IM_NDIM(out[1]) if (!project && ndim < 3) { do i = 1, nimages { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) call xt_cpix (i) if (ndim > 1) { j = v1[2] - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } } } # Get data and fill data buffers. Correct for offsets if needed. do i = 1, nimages { if (lflag[i] == D_NONE) next if (dbuf[i] == NULL) { call amovl (v1, v2, IM_MAXDIM) if (project) v2[ndim+1] = i j = xt_imgnlr (in[i], i, d[i], v2, v1[2]) } else { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) { lflag[i] = D_NONE next } k = 1 + j - offsets[i,1] v2[1] = k do l = 2, ndim { v2[l] = v1[l] - offsets[i,l] if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { lflag[i] = D_NONE break } } if (lflag[i] == D_NONE) next if (project) v2[ndim+1] = i l = xt_imgnlr (in[i], i, buf, v2, v1[2]) call amovr (Memr[buf+k-1], Memr[dbuf[i]+j], npix) d[i] = dbuf[i] } } # Set values to max_pixel if needed. if (mtype == M_NOVAL) { do i = 1, nimages { dp = d[i]; mp = m[i] if (lflag[i] == D_NONE || dp == NULL) next else if (lflag[i] == D_MIX) { do j = 1, npts { if (Memi[mp] == 1) Memr[dp] = max_pixel dp = dp + 1 mp = mp + 1 } } } } # Apply threshold if needed if (dothresh) { do i = 1, nimages { if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { a = Memr[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 lflag[i] = D_MIX dflag = D_MIX } dp = dp + 1 } # Check for completely empty lines if (lflag[i] == D_MIX) { lflag[i] = D_NONE mp = m[i] do j = 1, npts { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) { a = Memr[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 dflag = D_MIX } } dp = dp + 1 mp = mp + 1 } # Check for completely empty lines lflag[i] = D_NONE mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } } # Apply scaling (avoiding masked pixels which might overflow?) if (doscale) { if (dflag == D_ALL) { do i = 1, nimages { dp = d[i] a = scales[i] b = -zeros[i] do j = 1, npts { Memr[dp] = Memr[dp] / a + b dp = dp + 1 } } } else if (dflag == D_MIX) { do i = 1, nimages { a = scales[i] b = -zeros[i] if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { Memr[dp] = Memr[dp] / a + b dp = dp + 1 } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) 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 } } do i = nused+1, nimages d[i] = NULL if (nused == 0) dflag = D_NONE } # Compact data to remove bad pixels # Keep track of the image indices if needed # If growing mark the end of the included image indices with zero if (dflag == D_ALL) { call amovki (nused, n, npts) if (keepids) do i = 1, nimages call amovki (i, Memi[id[i]], npts) } else if (dflag == D_NONE) call aclri (n, npts) else { call aclri (n, npts) if (keepids) { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 ip = id[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { Memi[ip] = l if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Memr[d[k]+j-1] Memr[d[k]+j-1] = Memr[dp] Memr[dp] = temp Memi[ip] = Memi[id[k]+j-1] Memi[id[k]+j-1] = l Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 ip = ip + 1 mp = mp + 1 } } if (grow >= 1.) { do j = 1, npts { do i = n[j]+1, nused Memi[id[i]+j-1] = 0 } } } else { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Memr[d[k]+j-1] Memr[d[k]+j-1] = Memr[dp] Memr[dp] = temp Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 mp = mp + 1 } } } } # Sort the pixels and IDs if needed if (mclip) { call malloc (dp, nused, TY_REAL) if (keepids) { call malloc (ip, nused, 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) } # If no good pixels set the number of usable values as -n and # shift them to lower values. if (mtype == M_NOVAL) { if (keepids) { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 ip = id[i] + j - 1 if (Memr[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) { Memr[d[k]+j-1] = Memr[dp] Memi[id[k]+j-1] = Memi[ip] } } } } } else { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 if (Memr[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) Memr[d[k]+j-1] = Memr[dp] } } } } } end # IC_GDATA -- Get line of image and mask data and apply threshold and scaling. # Entirely empty lines are excluded. The data are compacted within the # input data buffers. If it is required, the connection to the original # image index is kept in the returned m data pointers. procedure ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, v1, v2) pointer in[nimages] # Input images pointer out[ARB] # Output images pointer dbuf[nimages] # Data buffers pointer d[nimages] # Data pointers pointer id[nimages] # ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Empty mask flags int offsets[nimages,ARB] # Image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors int nimages # Number of input images int npts # NUmber of output points per line long v1[ARB], v2[ARB] # Line vectors double temp int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnld() real a, b pointer buf, dp, ip, mp errchk xt_cpix, xt_imgnld double max_pixel data max_pixel/MAX_DOUBLE/ include "../icombine.com" begin # Get masks and return if there is no data call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) if (dflag == D_NONE) { call aclri (n, npts) return } # Close images which are not needed. nout = IM_LEN(out[1],1) ndim = IM_NDIM(out[1]) if (!project && ndim < 3) { do i = 1, nimages { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) call xt_cpix (i) if (ndim > 1) { j = v1[2] - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } } } # Get data and fill data buffers. Correct for offsets if needed. do i = 1, nimages { if (lflag[i] == D_NONE) next if (dbuf[i] == NULL) { call amovl (v1, v2, IM_MAXDIM) if (project) v2[ndim+1] = i j = xt_imgnld (in[i], i, d[i], v2, v1[2]) } else { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) { lflag[i] = D_NONE next } k = 1 + j - offsets[i,1] v2[1] = k do l = 2, ndim { v2[l] = v1[l] - offsets[i,l] if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { lflag[i] = D_NONE break } } if (lflag[i] == D_NONE) next if (project) v2[ndim+1] = i l = xt_imgnld (in[i], i, buf, v2, v1[2]) call amovd (Memd[buf+k-1], Memd[dbuf[i]+j], npix) d[i] = dbuf[i] } } # Set values to max_pixel if needed. if (mtype == M_NOVAL) { do i = 1, nimages { dp = d[i]; mp = m[i] if (lflag[i] == D_NONE || dp == NULL) next else if (lflag[i] == D_MIX) { do j = 1, npts { if (Memi[mp] == 1) Memd[dp] = max_pixel dp = dp + 1 mp = mp + 1 } } } } # Apply threshold if needed if (dothresh) { do i = 1, nimages { if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { a = Memd[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 lflag[i] = D_MIX dflag = D_MIX } dp = dp + 1 } # Check for completely empty lines if (lflag[i] == D_MIX) { lflag[i] = D_NONE mp = m[i] do j = 1, npts { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) { a = Memd[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 dflag = D_MIX } } dp = dp + 1 mp = mp + 1 } # Check for completely empty lines lflag[i] = D_NONE mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } } # Apply scaling (avoiding masked pixels which might overflow?) if (doscale) { if (dflag == D_ALL) { do i = 1, nimages { dp = d[i] a = scales[i] b = -zeros[i] do j = 1, npts { Memd[dp] = Memd[dp] / a + b dp = dp + 1 } } } else if (dflag == D_MIX) { do i = 1, nimages { a = scales[i] b = -zeros[i] if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { Memd[dp] = Memd[dp] / a + b dp = dp + 1 } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) Memd[dp] = Memd[dp] / a + b dp = dp + 1 mp = mp + 1 } } } } } # Sort pointers to exclude unused images. # Use the lflag array to keep track of the image index. if (dflag == D_ALL) nused = nimages else { nused = 0 do i = 1, nimages { if (lflag[i] != D_NONE) { nused = nused + 1 d[nused] = d[i] m[nused] = m[i] lflag[nused] = i } } do i = nused+1, nimages d[i] = NULL if (nused == 0) dflag = D_NONE } # Compact data to remove bad pixels # Keep track of the image indices if needed # If growing mark the end of the included image indices with zero if (dflag == D_ALL) { call amovki (nused, n, npts) if (keepids) do i = 1, nimages call amovki (i, Memi[id[i]], npts) } else if (dflag == D_NONE) call aclri (n, npts) else { call aclri (n, npts) if (keepids) { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 ip = id[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { Memi[ip] = l if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Memd[d[k]+j-1] Memd[d[k]+j-1] = Memd[dp] Memd[dp] = temp Memi[ip] = Memi[id[k]+j-1] Memi[id[k]+j-1] = l Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 ip = ip + 1 mp = mp + 1 } } if (grow >= 1.) { do j = 1, npts { do i = n[j]+1, nused Memi[id[i]+j-1] = 0 } } } else { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Memd[d[k]+j-1] Memd[d[k]+j-1] = Memd[dp] Memd[dp] = temp Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 mp = mp + 1 } } } } # Sort the pixels and IDs if needed if (mclip) { call malloc (dp, nused, TY_DOUBLE) if (keepids) { call malloc (ip, nused, TY_INT) call ic_2sortd (d, Memd[dp], id, Memi[ip], n, npts) call mfree (ip, TY_INT) } else call ic_sortd (d, Memd[dp], n, npts) call mfree (dp, TY_DOUBLE) } # If no good pixels set the number of usable values as -n and # shift them to lower values. if (mtype == M_NOVAL) { if (keepids) { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 ip = id[i] + j - 1 if (Memd[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) { Memd[d[k]+j-1] = Memd[dp] Memi[id[k]+j-1] = Memi[ip] } } } } } else { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 if (Memd[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) Memd[d[k]+j-1] = Memd[dp] } } } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icgrow.x000066400000000000000000000126171332166314300241010ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" # IC_GROW -- Mark neigbors of rejected pixels. # The rejected pixels (original plus grown) are saved in pixel masks. procedure ic_grow (out, v, m, n, buf, nimages, npts, pms) pointer out # Output image pointer long v[ARB] # Output vector pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[npts,nimages] # Working buffer int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k, l, line, nl, rop, igrow, nset, ncompress, or() real grow2, i2 pointer mp, pm, pm_newmask() errchk pm_newmask() include "../icombine.com" begin if (dflag == D_NONE || grow == 0.) return line = v[2] nl = IM_LEN(out,2) rop = or (PIX_SRC, PIX_DST) igrow = grow grow2 = grow**2 do l = 0, igrow { i2 = grow2 - l * l call aclri (buf, npts*nimages) nset = 0 do j = 1, npts { do k = n[j]+1, nimages { mp = Memi[m[k]+j-1] if (mp == 0) next do i = 0, igrow { if (i**2 > i2) next if (j > i) buf[j-i,mp] = 1 if (j+i <= npts) buf[j+i,mp] = 1 nset = nset + 1 } } } if (nset == 0) return if (pms == NULL) { call malloc (pms, nimages, TY_POINTER) do i = 1, nimages Memi[pms+i-1] = pm_newmask (out, 1) ncompress = 0 } do i = 1, nimages { pm = Memi[pms+i-1] v[2] = line - l if (v[2] > 0) call pmplpi (pm, v, buf[1,i], 1, npts, rop) if (l > 0) { v[2] = line + l if (v[2] <= nl) call pmplpi (pm, v, buf[1,i], 1, npts, rop) } } } v[2] = line if (ncompress > 10) { do i = 1, nimages { pm = Memi[pms+i-1] call pm_compress (pm) } ncompress = 0 } else ncompress = ncompress + 1 end # IC_GROW$T -- Reject pixels. procedure ic_grows (v, d, m, n, buf, nimages, npts, pms) long v[ARB] # Output vector pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[ARB] # Buffer of npts int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k pointer pm bool pl_linenotempty() include "../icombine.com" begin do k = 1, nimages { pm = Memi[pms+k-1] if (!pl_linenotempty (pm, v)) next call pmglpi (pm, v, buf, 1, npts, PIX_SRC) do i = 1, npts { if (buf[i] == 0) next for (j = 1; j <= n[i]; j = j + 1) { if (Memi[m[j]+i-1] == k) { if (j < n[i]) { Mems[d[j]+i-1] = Mems[d[n[i]]+i-1] Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] } n[i] = n[i] - 1 dflag = D_MIX break } } } } end # IC_GROW$T -- Reject pixels. procedure ic_growi (v, d, m, n, buf, nimages, npts, pms) long v[ARB] # Output vector pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[ARB] # Buffer of npts int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k pointer pm bool pl_linenotempty() include "../icombine.com" begin do k = 1, nimages { pm = Memi[pms+k-1] if (!pl_linenotempty (pm, v)) next call pmglpi (pm, v, buf, 1, npts, PIX_SRC) do i = 1, npts { if (buf[i] == 0) next for (j = 1; j <= n[i]; j = j + 1) { if (Memi[m[j]+i-1] == k) { if (j < n[i]) { Memi[d[j]+i-1] = Memi[d[n[i]]+i-1] Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] } n[i] = n[i] - 1 dflag = D_MIX break } } } } end # IC_GROW$T -- Reject pixels. procedure ic_growr (v, d, m, n, buf, nimages, npts, pms) long v[ARB] # Output vector pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[ARB] # Buffer of npts int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k pointer pm bool pl_linenotempty() include "../icombine.com" begin do k = 1, nimages { pm = Memi[pms+k-1] if (!pl_linenotempty (pm, v)) next call pmglpi (pm, v, buf, 1, npts, PIX_SRC) do i = 1, npts { if (buf[i] == 0) next for (j = 1; j <= n[i]; j = j + 1) { if (Memi[m[j]+i-1] == k) { if (j < n[i]) { Memr[d[j]+i-1] = Memr[d[n[i]]+i-1] Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] } n[i] = n[i] - 1 dflag = D_MIX break } } } } end # IC_GROW$T -- Reject pixels. procedure ic_growd (v, d, m, n, buf, nimages, npts, pms) long v[ARB] # Output vector pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[ARB] # Buffer of npts int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k pointer pm bool pl_linenotempty() include "../icombine.com" begin do k = 1, nimages { pm = Memi[pms+k-1] if (!pl_linenotempty (pm, v)) next call pmglpi (pm, v, buf, 1, npts, PIX_SRC) do i = 1, npts { if (buf[i] == 0) next for (j = 1; j <= n[i]; j = j + 1) { if (Memi[m[j]+i-1] == k) { if (j < n[i]) { Memd[d[j]+i-1] = Memd[d[n[i]]+i-1] Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] } n[i] = n[i] - 1 dflag = D_MIX break } } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icmedian.x000066400000000000000000000403101332166314300243470ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" # IC_MEDIAN -- Median of lines procedure ic_medians (d, n, npts, doblank, median) pointer d[ARB] # Input data line pointers int n[npts] # Number of good pixels int npts # Number of output points per line int doblank # Set blank values? real median[npts] # Median int i, j, k, j1, j2, n1, lo, up, lo1, up1 bool even real val1, val2, val3 short temp, wtemp include "../icombine.com" begin # If no data return after possibly setting blank values. if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts median[i]= blank } return } # If the data were previously sorted then directly compute the median. if (mclip) { if (dflag == D_ALL) { n1 = n[1] j1 = n1 / 2 + 1 j2 = n1 / 2 even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] } return } else { # Check for negative n values. If found then there are # pixels with no good values but with values we want to # use as a substitute median. In this case ignore that # the good pixels have been sorted. do i = 1, npts { if (n[i] < 0) break } if (n[i] >= 0) { do i = 1, npts { k = i - 1 n1 = n[i] if (n1 > 0) { j1 = n1 / 2 + 1 if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { j2 = n1 / 2 val1 = Mems[d[j1]+k] val2 = Mems[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Mems[d[j1]+k] } else if (doblank == YES) median[i] = blank } return } } } # Compute the median. do i = 1, npts { k = i - 1 n1 = abs(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 && (medtype==MEDAVG || n1 > 2)) { 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] if (medtype == MEDAVG) median[i] = (val1 + val2) / 2 else median[i] = min (val1, val2) # If 1 point return the value. } else if (n1 == 1) median[i] = Mems[d[1]+k] # If no points return with a possibly blank value. else if (doblank == YES) median[i] = blank } end # IC_MEDIAN -- Median of lines procedure ic_mediani (d, n, npts, doblank, median) pointer d[ARB] # Input data line pointers int n[npts] # Number of good pixels int npts # Number of output points per line int doblank # Set blank values? real median[npts] # Median int i, j, k, j1, j2, n1, lo, up, lo1, up1 bool even real val1, val2, val3 int temp, wtemp include "../icombine.com" begin # If no data return after possibly setting blank values. if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts median[i]= blank } return } # If the data were previously sorted then directly compute the median. if (mclip) { if (dflag == D_ALL) { n1 = n[1] j1 = n1 / 2 + 1 j2 = n1 / 2 even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) do i = 1, npts { k = i - 1 if (even) { val1 = Memi[d[j1]+k] val2 = Memi[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Memi[d[j1]+k] } return } else { # Check for negative n values. If found then there are # pixels with no good values but with values we want to # use as a substitute median. In this case ignore that # the good pixels have been sorted. do i = 1, npts { if (n[i] < 0) break } if (n[i] >= 0) { do i = 1, npts { k = i - 1 n1 = n[i] if (n1 > 0) { j1 = n1 / 2 + 1 if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { j2 = n1 / 2 val1 = Memi[d[j1]+k] val2 = Memi[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Memi[d[j1]+k] } else if (doblank == YES) median[i] = blank } return } } } # Compute the median. do i = 1, npts { k = i - 1 n1 = abs(n[i]) # If there are more than 3 points use Wirth algorithm. This # is the same as vops$amed.gx except for an even number of # points it selects the middle two and averages. if (n1 > 3) { lo = 1 up = n1 j = max (lo, min (up, (up+1)/2)) while (lo < up) { if (! (lo < up)) break temp = Memi[d[j]+k]; lo1 = lo; up1 = up repeat { while (Memi[d[lo1]+k] < temp) lo1 = lo1 + 1 while (temp < Memi[d[up1]+k]) up1 = up1 - 1 if (lo1 <= up1) { wtemp = Memi[d[lo1]+k] Memi[d[lo1]+k] = Memi[d[up1]+k] Memi[d[up1]+k] = wtemp lo1 = lo1 + 1; up1 = up1 - 1 } } until (lo1 > up1) if (up1 < j) lo = lo1 if (j < lo1) up = up1 } median[i] = Memi[d[j]+k] if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { lo = 1 up = n1 j = max (lo, min (up, (up+1)/2)+1) while (lo < up) { if (! (lo < up)) break temp = Memi[d[j]+k]; lo1 = lo; up1 = up repeat { while (Memi[d[lo1]+k] < temp) lo1 = lo1 + 1 while (temp < Memi[d[up1]+k]) up1 = up1 - 1 if (lo1 <= up1) { wtemp = Memi[d[lo1]+k] Memi[d[lo1]+k] = Memi[d[up1]+k] Memi[d[up1]+k] = wtemp lo1 = lo1 + 1; up1 = up1 - 1 } } until (lo1 > up1) if (up1 < j) lo = lo1 if (j < lo1) up = up1 } median[i] = (median[i] + Memi[d[j]+k]) / 2 } # If 3 points find the median directly. } else if (n1 == 3) { val1 = Memi[d[1]+k] val2 = Memi[d[2]+k] val3 = Memi[d[3]+k] if (val1 < val2) { if (val2 < val3) # abc median[i] = val2 else if (val1 < val3) # acb median[i] = val3 else # cab median[i] = val1 } else { if (val2 > val3) # cba median[i] = val2 else if (val1 > val3) # bca median[i] = val3 else # bac median[i] = val1 } # If 2 points average. } else if (n1 == 2) { val1 = Memi[d[1]+k] val2 = Memi[d[2]+k] if (medtype == MEDAVG) median[i] = (val1 + val2) / 2 else median[i] = min (val1, val2) # If 1 point return the value. } else if (n1 == 1) median[i] = Memi[d[1]+k] # If no points return with a possibly blank value. else if (doblank == YES) median[i] = blank } end # IC_MEDIAN -- Median of lines procedure ic_medianr (d, n, npts, doblank, median) pointer d[ARB] # Input data line pointers int n[npts] # Number of good pixels int npts # Number of output points per line int doblank # Set blank values? real median[npts] # Median int i, j, k, j1, j2, n1, lo, up, lo1, up1 bool even real val1, val2, val3 real temp, wtemp include "../icombine.com" begin # If no data return after possibly setting blank values. if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts median[i]= blank } return } # If the data were previously sorted then directly compute the median. if (mclip) { if (dflag == D_ALL) { n1 = n[1] j1 = n1 / 2 + 1 j2 = n1 / 2 even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] } return } else { # Check for negative n values. If found then there are # pixels with no good values but with values we want to # use as a substitute median. In this case ignore that # the good pixels have been sorted. do i = 1, npts { if (n[i] < 0) break } if (n[i] >= 0) { do i = 1, npts { k = i - 1 n1 = n[i] if (n1 > 0) { j1 = n1 / 2 + 1 if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { j2 = n1 / 2 val1 = Memr[d[j1]+k] val2 = Memr[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Memr[d[j1]+k] } else if (doblank == YES) median[i] = blank } return } } } # Compute the median. do i = 1, npts { k = i - 1 n1 = abs(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 && (medtype==MEDAVG || n1 > 2)) { 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] if (medtype == MEDAVG) median[i] = (val1 + val2) / 2 else median[i] = min (val1, val2) # If 1 point return the value. } else if (n1 == 1) median[i] = Memr[d[1]+k] # If no points return with a possibly blank value. else if (doblank == YES) median[i] = blank } end # IC_MEDIAN -- Median of lines procedure ic_mediand (d, n, npts, doblank, median) pointer d[ARB] # Input data line pointers int n[npts] # Number of good pixels int npts # Number of output points per line int doblank # Set blank values? double median[npts] # Median int i, j, k, j1, j2, n1, lo, up, lo1, up1 bool even double val1, val2, val3 double temp, wtemp include "../icombine.com" begin # If no data return after possibly setting blank values. if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts median[i]= blank } return } # If the data were previously sorted then directly compute the median. if (mclip) { if (dflag == D_ALL) { n1 = n[1] j1 = n1 / 2 + 1 j2 = n1 / 2 even = (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) do i = 1, npts { k = i - 1 if (even) { val1 = Memd[d[j1]+k] val2 = Memd[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Memd[d[j1]+k] } return } else { # Check for negative n values. If found then there are # pixels with no good values but with values we want to # use as a substitute median. In this case ignore that # the good pixels have been sorted. do i = 1, npts { if (n[i] < 0) break } if (n[i] >= 0) { do i = 1, npts { k = i - 1 n1 = n[i] if (n1 > 0) { j1 = n1 / 2 + 1 if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { j2 = n1 / 2 val1 = Memd[d[j1]+k] val2 = Memd[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Memd[d[j1]+k] } else if (doblank == YES) median[i] = blank } return } } } # Compute the median. do i = 1, npts { k = i - 1 n1 = abs(n[i]) # If there are more than 3 points use Wirth algorithm. This # is the same as vops$amed.gx except for an even number of # points it selects the middle two and averages. if (n1 > 3) { lo = 1 up = n1 j = max (lo, min (up, (up+1)/2)) while (lo < up) { if (! (lo < up)) break temp = Memd[d[j]+k]; lo1 = lo; up1 = up repeat { while (Memd[d[lo1]+k] < temp) lo1 = lo1 + 1 while (temp < Memd[d[up1]+k]) up1 = up1 - 1 if (lo1 <= up1) { wtemp = Memd[d[lo1]+k] Memd[d[lo1]+k] = Memd[d[up1]+k] Memd[d[up1]+k] = wtemp lo1 = lo1 + 1; up1 = up1 - 1 } } until (lo1 > up1) if (up1 < j) lo = lo1 if (j < lo1) up = up1 } median[i] = Memd[d[j]+k] if (mod(n1,2)==0 && (medtype==MEDAVG || n1 > 2)) { lo = 1 up = n1 j = max (lo, min (up, (up+1)/2)+1) while (lo < up) { if (! (lo < up)) break temp = Memd[d[j]+k]; lo1 = lo; up1 = up repeat { while (Memd[d[lo1]+k] < temp) lo1 = lo1 + 1 while (temp < Memd[d[up1]+k]) up1 = up1 - 1 if (lo1 <= up1) { wtemp = Memd[d[lo1]+k] Memd[d[lo1]+k] = Memd[d[up1]+k] Memd[d[up1]+k] = wtemp lo1 = lo1 + 1; up1 = up1 - 1 } } until (lo1 > up1) if (up1 < j) lo = lo1 if (j < lo1) up = up1 } median[i] = (median[i] + Memd[d[j]+k]) / 2 } # If 3 points find the median directly. } else if (n1 == 3) { val1 = Memd[d[1]+k] val2 = Memd[d[2]+k] val3 = Memd[d[3]+k] if (val1 < val2) { if (val2 < val3) # abc median[i] = val2 else if (val1 < val3) # acb median[i] = val3 else # cab median[i] = val1 } else { if (val2 > val3) # cba median[i] = val2 else if (val1 > val3) # bca median[i] = val3 else # bac median[i] = val1 } # If 2 points average. } else if (n1 == 2) { val1 = Memd[d[1]+k] val2 = Memd[d[2]+k] if (medtype == MEDAVG) median[i] = (val1 + val2) / 2 else median[i] = min (val1, val2) # If 1 point return the value. } else if (n1 == 1) median[i] = Memd[d[1]+k] # If no points return with a possibly blank value. else if (doblank == YES) median[i] = blank } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icmm.x000066400000000000000000000312741332166314300235340ustar00rootroot00000000000000# 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 = max (0, 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 = max (0, n[i]) if (dflag == D_MIX) { nlow = flow * n1 + 0.001 nhigh = fhigh * n1 + 0.001 ncombine = max (ncombine, n1 - nlow - nhigh) npairs = min (nlow, nhigh) nlow = nlow - npairs nhigh = nhigh - npairs } # Reject the npairs low and high points. do np = 1, npairs { k = d[1] + i1 d1 = Mems[k] dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k do j = 2, n1 { d2 = d1 k = d[j] + i1 d1 = Mems[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } else if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } j = n1 - 1 if (keepids) { if (jmax < j) { if (jmin != j) { Mems[kmax] = d2 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } else { Mems[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } if (jmin < j) { if (jmax != n1) { Mems[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } else { Mems[kmin] = d2 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } } } else { if (jmax < j) { if (jmin != j) Mems[kmax] = d2 else Mems[kmax] = d1 } if (jmin < j) { if (jmax != n1) Mems[kmin] = d1 else Mems[kmin] = d2 } } n1 = n1 - 2 } # Reject the excess low points. do np = 1, nlow { k = d[1] + i1 d1 = Mems[k] dmin = d1; jmin = 1; kmin = k do j = 2, n1 { k = d[j] + i1 d1 = Mems[k] if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } if (keepids) { if (jmin < n1) { Mems[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmin < n1) Mems[kmin] = d1 } n1 = n1 - 1 } # Reject the excess high points. do np = 1, nhigh { k = d[1] + i1 d1 = Mems[k] dmax = d1; jmax = 1; kmax = k do j = 2, n1 { k = d[j] + i1 d1 = Mems[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } } if (keepids) { if (jmax < n1) { Mems[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmax < n1) Mems[kmax] = d1 } n1 = n1 - 1 } n[i] = n1 } if (dflag == D_ALL && npairs + nlow + nhigh > 0) dflag = D_MIX end # IC_MM -- Reject a specified number of high and low pixels procedure ic_mmi (d, m, n, npts) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of good pixels int npts # Number of output points per line int n1, ncombine, npairs, nlow, nhigh, np int i, i1, j, jmax, jmin pointer k, kmax, kmin int d1, d2, dmin, dmax include "../icombine.com" begin if (dflag == D_NONE) return if (dflag == D_ALL) { n1 = max (0, 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 = max (0, n[i]) if (dflag == D_MIX) { nlow = flow * n1 + 0.001 nhigh = fhigh * n1 + 0.001 ncombine = max (ncombine, n1 - nlow - nhigh) npairs = min (nlow, nhigh) nlow = nlow - npairs nhigh = nhigh - npairs } # Reject the npairs low and high points. do np = 1, npairs { k = d[1] + i1 d1 = Memi[k] dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k do j = 2, n1 { d2 = d1 k = d[j] + i1 d1 = Memi[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } else if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } j = n1 - 1 if (keepids) { if (jmax < j) { if (jmin != j) { Memi[kmax] = d2 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } else { Memi[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } if (jmin < j) { if (jmax != n1) { Memi[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } else { Memi[kmin] = d2 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } } } else { if (jmax < j) { if (jmin != j) Memi[kmax] = d2 else Memi[kmax] = d1 } if (jmin < j) { if (jmax != n1) Memi[kmin] = d1 else Memi[kmin] = d2 } } n1 = n1 - 2 } # Reject the excess low points. do np = 1, nlow { k = d[1] + i1 d1 = Memi[k] dmin = d1; jmin = 1; kmin = k do j = 2, n1 { k = d[j] + i1 d1 = Memi[k] if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } if (keepids) { if (jmin < n1) { Memi[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmin < n1) Memi[kmin] = d1 } n1 = n1 - 1 } # Reject the excess high points. do np = 1, nhigh { k = d[1] + i1 d1 = Memi[k] dmax = d1; jmax = 1; kmax = k do j = 2, n1 { k = d[j] + i1 d1 = Memi[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } } if (keepids) { if (jmax < n1) { Memi[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmax < n1) Memi[kmax] = d1 } n1 = n1 - 1 } n[i] = n1 } if (dflag == D_ALL && npairs + nlow + nhigh > 0) dflag = D_MIX end # IC_MM -- Reject a specified number of high and low pixels procedure ic_mmr (d, m, n, npts) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of good pixels int npts # Number of output points per line int n1, ncombine, npairs, nlow, nhigh, np int i, i1, j, jmax, jmin pointer k, kmax, kmin real d1, d2, dmin, dmax include "../icombine.com" begin if (dflag == D_NONE) return if (dflag == D_ALL) { n1 = max (0, 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 = max (0, n[i]) if (dflag == D_MIX) { nlow = flow * n1 + 0.001 nhigh = fhigh * n1 + 0.001 ncombine = max (ncombine, n1 - nlow - nhigh) npairs = min (nlow, nhigh) nlow = nlow - npairs nhigh = nhigh - npairs } # Reject the npairs low and high points. do np = 1, npairs { k = d[1] + i1 d1 = Memr[k] dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k do j = 2, n1 { d2 = d1 k = d[j] + i1 d1 = Memr[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } else if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } j = n1 - 1 if (keepids) { if (jmax < j) { if (jmin != j) { Memr[kmax] = d2 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } else { Memr[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } if (jmin < j) { if (jmax != n1) { Memr[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } else { Memr[kmin] = d2 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } } } else { if (jmax < j) { if (jmin != j) Memr[kmax] = d2 else Memr[kmax] = d1 } if (jmin < j) { if (jmax != n1) Memr[kmin] = d1 else Memr[kmin] = d2 } } n1 = n1 - 2 } # Reject the excess low points. do np = 1, nlow { k = d[1] + i1 d1 = Memr[k] dmin = d1; jmin = 1; kmin = k do j = 2, n1 { k = d[j] + i1 d1 = Memr[k] if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } if (keepids) { if (jmin < n1) { Memr[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmin < n1) Memr[kmin] = d1 } n1 = n1 - 1 } # Reject the excess high points. do np = 1, nhigh { k = d[1] + i1 d1 = Memr[k] dmax = d1; jmax = 1; kmax = k do j = 2, n1 { k = d[j] + i1 d1 = Memr[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } } if (keepids) { if (jmax < n1) { Memr[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmax < n1) Memr[kmax] = d1 } n1 = n1 - 1 } n[i] = n1 } if (dflag == D_ALL && npairs + nlow + nhigh > 0) dflag = D_MIX end # IC_MM -- Reject a specified number of high and low pixels procedure ic_mmd (d, m, n, npts) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of good pixels int npts # Number of output points per line int n1, ncombine, npairs, nlow, nhigh, np int i, i1, j, jmax, jmin pointer k, kmax, kmin double d1, d2, dmin, dmax include "../icombine.com" begin if (dflag == D_NONE) return if (dflag == D_ALL) { n1 = max (0, 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 = max (0, n[i]) if (dflag == D_MIX) { nlow = flow * n1 + 0.001 nhigh = fhigh * n1 + 0.001 ncombine = max (ncombine, n1 - nlow - nhigh) npairs = min (nlow, nhigh) nlow = nlow - npairs nhigh = nhigh - npairs } # Reject the npairs low and high points. do np = 1, npairs { k = d[1] + i1 d1 = Memd[k] dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k do j = 2, n1 { d2 = d1 k = d[j] + i1 d1 = Memd[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } else if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } j = n1 - 1 if (keepids) { if (jmax < j) { if (jmin != j) { Memd[kmax] = d2 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } else { Memd[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } if (jmin < j) { if (jmax != n1) { Memd[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } else { Memd[kmin] = d2 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } } } else { if (jmax < j) { if (jmin != j) Memd[kmax] = d2 else Memd[kmax] = d1 } if (jmin < j) { if (jmax != n1) Memd[kmin] = d1 else Memd[kmin] = d2 } } n1 = n1 - 2 } # Reject the excess low points. do np = 1, nlow { k = d[1] + i1 d1 = Memd[k] dmin = d1; jmin = 1; kmin = k do j = 2, n1 { k = d[j] + i1 d1 = Memd[k] if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } if (keepids) { if (jmin < n1) { Memd[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmin < n1) Memd[kmin] = d1 } n1 = n1 - 1 } # Reject the excess high points. do np = 1, nhigh { k = d[1] + i1 d1 = Memd[k] dmax = d1; jmax = 1; kmax = k do j = 2, n1 { k = d[j] + i1 d1 = Memd[k] if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } } if (keepids) { if (jmax < n1) { Memd[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmax < n1) Memd[kmax] = d1 } n1 = n1 - 1 } n[i] = n1 } if (dflag == D_ALL && npairs + nlow + nhigh > 0) dflag = D_MIX end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icnmodel.x000066400000000000000000000322051332166314300243740ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" include "../icmask.h" # IC_NMODEL -- Compute the quadrature average (or summed) noise model. # Options include a weighted average/sum. procedure ic_nmodels (d, m, n, nm, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real nm[3,nimages] # Noise model parameters real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt real sum, zero data zero /0.0/ include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = max (zero, Mems[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 do j = 2, n[i] { val = max (zero, Mems[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = max (zero, Mems[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n[i] { val = max (zero, Mems[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Mems[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 sumwt = wt do j = 2, n1 { val = max (zero, Mems[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = max (zero, Mems[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = Mems[d[1]+k]**2 do j = 2, n1 { val = max (zero, Mems[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Mems[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n1 { val = max (zero, Mems[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end # IC_NMODEL -- Compute the quadrature average (or summed) noise model. # Options include a weighted average/sum. procedure ic_nmodeli (d, m, n, nm, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real nm[3,nimages] # Noise model parameters real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt real sum, zero data zero /0.0/ include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = max (zero, Memi[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 do j = 2, n[i] { val = max (zero, Memi[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = max (zero, Memi[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n[i] { val = max (zero, Memi[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Memi[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 sumwt = wt do j = 2, n1 { val = max (zero, Memi[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = max (zero, Memi[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = Memi[d[1]+k]**2 do j = 2, n1 { val = max (zero, Memi[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Memi[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n1 { val = max (zero, Memi[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end # IC_NMODEL -- Compute the quadrature average (or summed) noise model. # Options include a weighted average/sum. procedure ic_nmodelr (d, m, n, nm, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real nm[3,nimages] # Noise model parameters real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt real sum, zero data zero /0.0/ include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = max (zero, Memr[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 do j = 2, n[i] { val = max (zero, Memr[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = max (zero, Memr[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n[i] { val = max (zero, Memr[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Memr[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 sumwt = wt do j = 2, n1 { val = max (zero, Memr[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = max (zero, Memr[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = Memr[d[1]+k]**2 do j = 2, n1 { val = max (zero, Memr[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Memr[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n1 { val = max (zero, Memr[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end # IC_NMODEL -- Compute the quadrature average (or summed) noise model. # Options include a weighted average/sum. procedure ic_nmodeld (d, m, n, nm, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real nm[3,nimages] # Noise model parameters real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? double average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt double sum, zero data zero /0.0D0/ include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = max (zero, Memd[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 do j = 2, n[i] { val = max (zero, Memd[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = max (zero, Memd[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n[i] { val = max (zero, Memd[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Memd[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 sumwt = wt do j = 2, n1 { val = max (zero, Memd[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = max (zero, Memd[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = Memd[d[1]+k]**2 do j = 2, n1 { val = max (zero, Memd[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Memd[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n1 { val = max (zero, Memd[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icomb.x000066400000000000000000001541311332166314300236760ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include "../icombine.h" # The following is for compiling under V2.11. define IM_BUFFRAC IM_BUFSIZE include # ICOMBINE -- Combine images # # The memory and open file descriptor limits are checked and an attempt # to recover is made either by setting the image pixel files to be # closed after I/O or by notifying the calling program that memory # ran out and the IMIO buffer size should be reduced. After the checks # a procedure for the selected combine option is called. # Because there may be several failure modes when reaching the file # limits we first assume an error is due to the file limit, except for # out of memory, and close some pixel files. If the error then repeats # on accessing the pixels the error is passed back. procedure icombines (in, out, scales, zeros, wts, offsets, nimages, bufsize) pointer in[nimages] # Input images pointer out[ARB] # Output images real scales[nimages] # Scales real zeros[nimages] # Zeros real wts[nimages] # Weights int offsets[nimages,ARB] # Input image offsets int nimages # Number of input images int bufsize # IMIO buffer size char str[1] int i, j, k, npts, fd, stropen(), xt_imgnls() pointer sp, d, id, n, m, lflag, v, dbuf pointer im, buf, xt_opix(), impl1i() errchk stropen, xt_cpix, xt_opix, xt_imgnls, impl1i, ic_combines pointer impl1r() errchk impl1r include "../icombine.com" begin npts = IM_LEN(out[1],1) # Allocate memory. call smark (sp) call salloc (dbuf, nimages, TY_POINTER) call salloc (d, nimages, TY_POINTER) call salloc (id, nimages, TY_POINTER) call salloc (n, npts, TY_INT) call salloc (m, nimages, TY_POINTER) call salloc (lflag, nimages, TY_INT) call salloc (v, IM_MAXDIM, TY_LONG) call amovki (D_ALL, Memi[lflag], nimages) call amovkl (1, Meml[v], IM_MAXDIM) # If not aligned or growing create data buffers of output length # otherwise use the IMIO buffers. if (!aligned || grow >= 1.) { do i = 1, nimages { call salloc (Memi[dbuf+i-1], npts, TY_SHORT) call aclrs (Mems[Memi[dbuf+i-1]], npts) } } else { do i = 1, nimages { im = xt_opix (in[i], i, 1) if (im != in[i]) { call salloc (Memi[dbuf+i-1], npts, TY_SHORT) call aclrs (Mems[Memi[dbuf+i-1]], npts) } } call amovki (NULL, Memi[dbuf], nimages) } if (project) { call imseti (in[1], IM_NBUFS, nimages) call imseti (in[1], IM_BUFFRAC, 0) call imseti (in[1], IM_BUFSIZE, bufsize) do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } } else { # Reserve FD for string operations. fd = stropen (str, 1, NEW_FILE) # Do I/O to the images. do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } buf = impl1r (out[1]) call aclrr (Memr[buf], npts) if (out[3] != NULL) { buf = impl1r (out[3]) call aclrr (Memr[buf], npts) } if (out[2] != NULL) { buf = impl1i (out[2]) call aclri (Memi[buf], npts) } if (out[4] != NULL) { buf = impl1i (out[4]) call aclri (Memi[buf], npts) } if (out[5] != NULL) { buf = impl1i (out[5]) call aclri (Memi[buf], npts) } if (out[6] != NULL) { buf = impl1i (out[6]) call aclri (Memi[buf], npts) } # Do I/O for first input image line. if (!project) { do i = 1, nimages { call xt_imseti (i, "bufsize", bufsize) j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) call xt_cpix (i) j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } do i = 1, nimages { j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) next j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) next iferr { Meml[v+1] = j j = xt_imgnls (in[i], i, buf, Meml[v], 1) } then { call imseti (im, IM_PIXFD, NULL) call sfree (sp) call strclose (fd) call erract (EA_ERROR) } } } call strclose (fd) } call ic_combines (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) end # IC_COMBINE -- Combine images. procedure ic_combines (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, wts, nimages, npts) pointer in[nimages] # Input images pointer out[ARB] # Output image pointer dbuf[nimages] # Data buffers for nonaligned images pointer d[nimages] # Data pointers pointer id[nimages] # Image index ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Line flags int offsets[nimages,ARB] # Input image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors real wts[nimages] # Combining weights int nimages # Number of input images int npts # Number of points per output line int i, ext, ctor(), errcode() real r, imgetr() pointer sp, fname, imname, v1, v2, v3, work pointer outdata, buf, nmod, nm, pms pointer immap(), impnli() pointer impnlr(), imgnlr() errchk immap, ic_scale, imgetr, ic_grow, ic_grows, ic_rmasks, ic_emask errchk ic_gdatas include "../icombine.com" data ext/0/ begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (v3, IM_MAXDIM, TY_LONG) call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) call ic_scale (in, out, offsets, scales, zeros, wts, nimages) # Set combine parameters switch (combine) { case AVERAGE, SUM, QUAD, NMODEL: if (dowts) keepids = true else keepids = false case MEDIAN: dowts = false keepids = false } docombine = true # Get noise model parameters. if (combine==NMODEL) { call salloc (nmod, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)] = r } else { do i = 1, nimages Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nmod+3*(i-1)+2] = r } } } # Set rejection algorithm specific parameters switch (reject) { case CCDCLIP, CRREJECT: call salloc (nm, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)] = r } else { do i = 1, nimages Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nm+3*(i-1)+2] = r } } if (!keepids) { if (doscale1) keepids = true else { do i = 2, nimages { if (Memr[nm+3*(i-1)] != Memr[nm] || Memr[nm+3*(i-1)+1] != Memr[nm+1] || Memr[nm+3*(i-1)+2] != Memr[nm+2]) { keepids = true break } } } } if (reject == CRREJECT) lsigma = MAX_REAL case MINMAX: mclip = false case PCLIP: mclip = true case AVSIGCLIP, SIGCLIP: if (doscale1) keepids = true case NONE: mclip = false } if (out[4] != NULL) keepids = true if (out[6] != NULL) { keepids = true call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) } if (grow >= 1.) { keepids = true call salloc (work, npts * nimages, TY_INT) } pms = NULL if (keepids) { do i = 1, nimages call salloc (id[i], npts, TY_INT) } # Reduce header memory use. do i = 1, nimages call xt_minhdr (i) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) switch (reject) { case CCDCLIP, CRREJECT: if (mclip) call ic_mccdclips (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) else call ic_accdclips (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) case MINMAX: call ic_mms (d, id, n, npts) case PCLIP: call ic_pclips (d, id, n, nimages, npts, Memr[outdata]) case SIGCLIP: if (mclip) call ic_msigclips (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_asigclips (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) case AVSIGCLIP: if (mclip) call ic_mavsigclips (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_aavsigclips (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) } if (pms == NULL || nkeep > 0) { if (docombine) { switch (combine) { case AVERAGE: call ic_averages (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case MEDIAN: call ic_medians (d, n, npts, YES, Memr[outdata]) case SUM: call ic_averages (d, id, n, wts, nimages, npts, YES, NO, Memr[outdata]) case QUAD: call ic_quads (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case NMODEL: call ic_nmodels (d, id, n, Memr[nmod], wts, nimages, npts, YES, YES, Memr[outdata]) } } } if (grow >= 1.) call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, pms) if (pms == NULL) { if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigmas (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) } call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } if (pms != NULL) { if (nkeep > 0) { call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) call imunmap (out[1]) iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { switch (errcode()) { case SYS_FXFOPNOEXTNV: call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) ext = ext + 1 call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext) iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { buf = NULL ext = 0 } repeat { call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext+1) iferr (outdata = immap (Memc[imname],READ_WRITE,0)) break if (buf != NULL) call imunmap (buf) buf = outdata ext = ext + 1 } default: call erract (EA_ERROR) } } out[1] = buf } call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatas (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) call ic_grows (Meml[v2], d, id, n, Memi[work], nimages, npts, pms) if (nkeep > 0) { do i = 1, npts { if (n[i] < nkeep) { Meml[v1+1] = Meml[v1+1] - 1 if (imgnlr (out[1], buf, Meml[v1]) == EOF) ; call amovr (Memr[buf], Memr[outdata], npts) break } } } switch (combine) { case AVERAGE: call ic_averages (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case MEDIAN: call ic_medians (d, n, npts, NO, Memr[outdata]) case SUM: call ic_averages (d, id, n, wts, nimages, npts, NO, NO, Memr[outdata]) case QUAD: call ic_quads (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case NMODEL: call ic_nmodels (d, id, n, Memr[nmod], wts, nimages, npts, NO, YES, Memr[outdata]) } if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigmas (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } do i = 1, nimages call pm_close (Memi[pms+i-1]) call mfree (pms, TY_POINTER) } call sfree (sp) end procedure icombinei (in, out, scales, zeros, wts, offsets, nimages, bufsize) pointer in[nimages] # Input images pointer out[ARB] # Output images real scales[nimages] # Scales real zeros[nimages] # Zeros real wts[nimages] # Weights int offsets[nimages,ARB] # Input image offsets int nimages # Number of input images int bufsize # IMIO buffer size char str[1] int i, j, k, npts, fd, stropen(), xt_imgnli() pointer sp, d, id, n, m, lflag, v, dbuf pointer im, buf, xt_opix(), impl1i() errchk stropen, xt_cpix, xt_opix, xt_imgnli, impl1i, ic_combinei pointer impl1r() errchk impl1r include "../icombine.com" begin npts = IM_LEN(out[1],1) # Allocate memory. call smark (sp) call salloc (dbuf, nimages, TY_POINTER) call salloc (d, nimages, TY_POINTER) call salloc (id, nimages, TY_POINTER) call salloc (n, npts, TY_INT) call salloc (m, nimages, TY_POINTER) call salloc (lflag, nimages, TY_INT) call salloc (v, IM_MAXDIM, TY_LONG) call amovki (D_ALL, Memi[lflag], nimages) call amovkl (1, Meml[v], IM_MAXDIM) # If not aligned or growing create data buffers of output length # otherwise use the IMIO buffers. if (!aligned || grow >= 1.) { do i = 1, nimages { call salloc (Memi[dbuf+i-1], npts, TY_INT) call aclri (Memi[Memi[dbuf+i-1]], npts) } } else { do i = 1, nimages { im = xt_opix (in[i], i, 1) if (im != in[i]) { call salloc (Memi[dbuf+i-1], npts, TY_INT) call aclri (Memi[Memi[dbuf+i-1]], npts) } } call amovki (NULL, Memi[dbuf], nimages) } if (project) { call imseti (in[1], IM_NBUFS, nimages) call imseti (in[1], IM_BUFFRAC, 0) call imseti (in[1], IM_BUFSIZE, bufsize) do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } } else { # Reserve FD for string operations. fd = stropen (str, 1, NEW_FILE) # Do I/O to the images. do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } buf = impl1r (out[1]) call aclrr (Memr[buf], npts) if (out[3] != NULL) { buf = impl1r (out[3]) call aclrr (Memr[buf], npts) } if (out[2] != NULL) { buf = impl1i (out[2]) call aclri (Memi[buf], npts) } if (out[4] != NULL) { buf = impl1i (out[4]) call aclri (Memi[buf], npts) } if (out[5] != NULL) { buf = impl1i (out[5]) call aclri (Memi[buf], npts) } if (out[6] != NULL) { buf = impl1i (out[6]) call aclri (Memi[buf], npts) } # Do I/O for first input image line. if (!project) { do i = 1, nimages { call xt_imseti (i, "bufsize", bufsize) j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) call xt_cpix (i) j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } do i = 1, nimages { j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) next j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) next iferr { Meml[v+1] = j j = xt_imgnli (in[i], i, buf, Meml[v], 1) } then { call imseti (im, IM_PIXFD, NULL) call sfree (sp) call strclose (fd) call erract (EA_ERROR) } } } call strclose (fd) } call ic_combinei (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) end # IC_COMBINE -- Combine images. procedure ic_combinei (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, wts, nimages, npts) pointer in[nimages] # Input images pointer out[ARB] # Output image pointer dbuf[nimages] # Data buffers for nonaligned images pointer d[nimages] # Data pointers pointer id[nimages] # Image index ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Line flags int offsets[nimages,ARB] # Input image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors real wts[nimages] # Combining weights int nimages # Number of input images int npts # Number of points per output line int i, ext, ctor(), errcode() real r, imgetr() pointer sp, fname, imname, v1, v2, v3, work pointer outdata, buf, nmod, nm, pms pointer immap(), impnli() pointer impnlr(), imgnlr() errchk immap, ic_scale, imgetr, ic_grow, ic_growi, ic_rmasks, ic_emask errchk ic_gdatai include "../icombine.com" data ext/0/ begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (v3, IM_MAXDIM, TY_LONG) call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) call ic_scale (in, out, offsets, scales, zeros, wts, nimages) # Set combine parameters switch (combine) { case AVERAGE, SUM, QUAD, NMODEL: if (dowts) keepids = true else keepids = false case MEDIAN: dowts = false keepids = false } docombine = true # Get noise model parameters. if (combine==NMODEL) { call salloc (nmod, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)] = r } else { do i = 1, nimages Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nmod+3*(i-1)+2] = r } } } # Set rejection algorithm specific parameters switch (reject) { case CCDCLIP, CRREJECT: call salloc (nm, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)] = r } else { do i = 1, nimages Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nm+3*(i-1)+2] = r } } if (!keepids) { if (doscale1) keepids = true else { do i = 2, nimages { if (Memr[nm+3*(i-1)] != Memr[nm] || Memr[nm+3*(i-1)+1] != Memr[nm+1] || Memr[nm+3*(i-1)+2] != Memr[nm+2]) { keepids = true break } } } } if (reject == CRREJECT) lsigma = MAX_REAL case MINMAX: mclip = false case PCLIP: mclip = true case AVSIGCLIP, SIGCLIP: if (doscale1) keepids = true case NONE: mclip = false } if (out[4] != NULL) keepids = true if (out[6] != NULL) { keepids = true call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) } if (grow >= 1.) { keepids = true call salloc (work, npts * nimages, TY_INT) } pms = NULL if (keepids) { do i = 1, nimages call salloc (id[i], npts, TY_INT) } # Reduce header memory use. do i = 1, nimages call xt_minhdr (i) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) switch (reject) { case CCDCLIP, CRREJECT: if (mclip) call ic_mccdclipi (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) else call ic_accdclipi (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) case MINMAX: call ic_mmi (d, id, n, npts) case PCLIP: call ic_pclipi (d, id, n, nimages, npts, Memr[outdata]) case SIGCLIP: if (mclip) call ic_msigclipi (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_asigclipi (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) case AVSIGCLIP: if (mclip) call ic_mavsigclipi (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_aavsigclipi (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) } if (pms == NULL || nkeep > 0) { if (docombine) { switch (combine) { case AVERAGE: call ic_averagei (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case MEDIAN: call ic_mediani (d, n, npts, YES, Memr[outdata]) case SUM: call ic_averagei (d, id, n, wts, nimages, npts, YES, NO, Memr[outdata]) case QUAD: call ic_quadi (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case NMODEL: call ic_nmodeli (d, id, n, Memr[nmod], wts, nimages, npts, YES, YES, Memr[outdata]) } } } if (grow >= 1.) call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, pms) if (pms == NULL) { if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigmai (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) } call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } if (pms != NULL) { if (nkeep > 0) { call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) call imunmap (out[1]) iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { switch (errcode()) { case SYS_FXFOPNOEXTNV: call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) ext = ext + 1 call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext) iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { buf = NULL ext = 0 } repeat { call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext+1) iferr (outdata = immap (Memc[imname],READ_WRITE,0)) break if (buf != NULL) call imunmap (buf) buf = outdata ext = ext + 1 } default: call erract (EA_ERROR) } } out[1] = buf } call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatai (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) call ic_growi (Meml[v2], d, id, n, Memi[work], nimages, npts, pms) if (nkeep > 0) { do i = 1, npts { if (n[i] < nkeep) { Meml[v1+1] = Meml[v1+1] - 1 if (imgnlr (out[1], buf, Meml[v1]) == EOF) ; call amovr (Memr[buf], Memr[outdata], npts) break } } } switch (combine) { case AVERAGE: call ic_averagei (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case MEDIAN: call ic_mediani (d, n, npts, NO, Memr[outdata]) case SUM: call ic_averagei (d, id, n, wts, nimages, npts, NO, NO, Memr[outdata]) case QUAD: call ic_quadi (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case NMODEL: call ic_nmodeli (d, id, n, Memr[nmod], wts, nimages, npts, NO, YES, Memr[outdata]) } if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigmai (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } do i = 1, nimages call pm_close (Memi[pms+i-1]) call mfree (pms, TY_POINTER) } call sfree (sp) end procedure icombiner (in, out, scales, zeros, wts, offsets, nimages, bufsize) pointer in[nimages] # Input images pointer out[ARB] # Output images real scales[nimages] # Scales real zeros[nimages] # Zeros real wts[nimages] # Weights int offsets[nimages,ARB] # Input image offsets int nimages # Number of input images int bufsize # IMIO buffer size char str[1] int i, j, k, npts, fd, stropen(), xt_imgnlr() pointer sp, d, id, n, m, lflag, v, dbuf pointer im, buf, xt_opix(), impl1i() errchk stropen, xt_cpix, xt_opix, xt_imgnlr, impl1i, ic_combiner pointer impl1r() errchk impl1r include "../icombine.com" begin npts = IM_LEN(out[1],1) # Allocate memory. call smark (sp) call salloc (dbuf, nimages, TY_POINTER) call salloc (d, nimages, TY_POINTER) call salloc (id, nimages, TY_POINTER) call salloc (n, npts, TY_INT) call salloc (m, nimages, TY_POINTER) call salloc (lflag, nimages, TY_INT) call salloc (v, IM_MAXDIM, TY_LONG) call amovki (D_ALL, Memi[lflag], nimages) call amovkl (1, Meml[v], IM_MAXDIM) # If not aligned or growing create data buffers of output length # otherwise use the IMIO buffers. if (!aligned || grow >= 1.) { do i = 1, nimages { call salloc (Memi[dbuf+i-1], npts, TY_REAL) call aclrr (Memr[Memi[dbuf+i-1]], npts) } } else { do i = 1, nimages { im = xt_opix (in[i], i, 1) if (im != in[i]) { call salloc (Memi[dbuf+i-1], npts, TY_REAL) call aclrr (Memr[Memi[dbuf+i-1]], npts) } } call amovki (NULL, Memi[dbuf], nimages) } if (project) { call imseti (in[1], IM_NBUFS, nimages) call imseti (in[1], IM_BUFFRAC, 0) call imseti (in[1], IM_BUFSIZE, bufsize) do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } } else { # Reserve FD for string operations. fd = stropen (str, 1, NEW_FILE) # Do I/O to the images. do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } buf = impl1r (out[1]) call aclrr (Memr[buf], npts) if (out[3] != NULL) { buf = impl1r (out[3]) call aclrr (Memr[buf], npts) } if (out[2] != NULL) { buf = impl1i (out[2]) call aclri (Memi[buf], npts) } if (out[4] != NULL) { buf = impl1i (out[4]) call aclri (Memi[buf], npts) } if (out[5] != NULL) { buf = impl1i (out[5]) call aclri (Memi[buf], npts) } if (out[6] != NULL) { buf = impl1i (out[6]) call aclri (Memi[buf], npts) } # Do I/O for first input image line. if (!project) { do i = 1, nimages { call xt_imseti (i, "bufsize", bufsize) j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) call xt_cpix (i) j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } do i = 1, nimages { j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) next j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) next iferr { Meml[v+1] = j j = xt_imgnlr (in[i], i, buf, Meml[v], 1) } then { call imseti (im, IM_PIXFD, NULL) call sfree (sp) call strclose (fd) call erract (EA_ERROR) } } } call strclose (fd) } call ic_combiner (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) end # IC_COMBINE -- Combine images. procedure ic_combiner (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, wts, nimages, npts) pointer in[nimages] # Input images pointer out[ARB] # Output image pointer dbuf[nimages] # Data buffers for nonaligned images pointer d[nimages] # Data pointers pointer id[nimages] # Image index ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Line flags int offsets[nimages,ARB] # Input image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors real wts[nimages] # Combining weights int nimages # Number of input images int npts # Number of points per output line int i, ext, ctor(), errcode() real r, imgetr() pointer sp, fname, imname, v1, v2, v3, work pointer outdata, buf, nmod, nm, pms pointer immap(), impnli() pointer impnlr(), imgnlr errchk immap, ic_scale, imgetr, ic_grow, ic_growr, ic_rmasks, ic_emask errchk ic_gdatar include "../icombine.com" data ext/0/ begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (v3, IM_MAXDIM, TY_LONG) call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) call ic_scale (in, out, offsets, scales, zeros, wts, nimages) # Set combine parameters switch (combine) { case AVERAGE, SUM, QUAD, NMODEL: if (dowts) keepids = true else keepids = false case MEDIAN: dowts = false keepids = false } docombine = true # Get noise model parameters. if (combine==NMODEL) { call salloc (nmod, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)] = r } else { do i = 1, nimages Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nmod+3*(i-1)+2] = r } } } # Set rejection algorithm specific parameters switch (reject) { case CCDCLIP, CRREJECT: call salloc (nm, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)] = r } else { do i = 1, nimages Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nm+3*(i-1)+2] = r } } if (!keepids) { if (doscale1) keepids = true else { do i = 2, nimages { if (Memr[nm+3*(i-1)] != Memr[nm] || Memr[nm+3*(i-1)+1] != Memr[nm+1] || Memr[nm+3*(i-1)+2] != Memr[nm+2]) { keepids = true break } } } } if (reject == CRREJECT) lsigma = MAX_REAL case MINMAX: mclip = false case PCLIP: mclip = true case AVSIGCLIP, SIGCLIP: if (doscale1) keepids = true case NONE: mclip = false } if (out[4] != NULL) keepids = true if (out[6] != NULL) { keepids = true call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) } if (grow >= 1.) { keepids = true call salloc (work, npts * nimages, TY_INT) } pms = NULL if (keepids) { do i = 1, nimages call salloc (id[i], npts, TY_INT) } # Reduce header memory use. do i = 1, nimages call xt_minhdr (i) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) switch (reject) { case CCDCLIP, CRREJECT: if (mclip) call ic_mccdclipr (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) else call ic_accdclipr (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) case MINMAX: call ic_mmr (d, id, n, npts) case PCLIP: call ic_pclipr (d, id, n, nimages, npts, Memr[outdata]) case SIGCLIP: if (mclip) call ic_msigclipr (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_asigclipr (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) case AVSIGCLIP: if (mclip) call ic_mavsigclipr (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_aavsigclipr (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) } if (pms == NULL || nkeep > 0) { if (docombine) { switch (combine) { case AVERAGE: call ic_averager (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case MEDIAN: call ic_medianr (d, n, npts, YES, Memr[outdata]) case SUM: call ic_averager (d, id, n, wts, nimages, npts, YES, NO, Memr[outdata]) case QUAD: call ic_quadr (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case NMODEL: call ic_nmodelr (d, id, n, Memr[nmod], wts, nimages, npts, YES, YES, Memr[outdata]) } } } if (grow >= 1.) call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, pms) if (pms == NULL) { if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigmar (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) } call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } if (pms != NULL) { if (nkeep > 0) { call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) call imunmap (out[1]) iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { switch (errcode()) { case SYS_FXFOPNOEXTNV: call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) ext = ext + 1 call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext) iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { buf = NULL ext = 0 } repeat { call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext+1) iferr (outdata = immap (Memc[imname],READ_WRITE,0)) break if (buf != NULL) call imunmap (buf) buf = outdata ext = ext + 1 } default: call erract (EA_ERROR) } } out[1] = buf } call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatar (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) call ic_growr (Meml[v2], d, id, n, Memi[work], nimages, npts, pms) if (nkeep > 0) { do i = 1, npts { if (n[i] < nkeep) { Meml[v1+1] = Meml[v1+1] - 1 if (imgnlr (out[1], buf, Meml[v1]) == EOF) ; call amovr (Memr[buf], Memr[outdata], npts) break } } } switch (combine) { case AVERAGE: call ic_averager (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case MEDIAN: call ic_medianr (d, n, npts, NO, Memr[outdata]) case SUM: call ic_averager (d, id, n, wts, nimages, npts, NO, NO, Memr[outdata]) case QUAD: call ic_quadr (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case NMODEL: call ic_nmodelr (d, id, n, Memr[nmod], wts, nimages, npts, NO, YES, Memr[outdata]) } if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigmar (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } do i = 1, nimages call pm_close (Memi[pms+i-1]) call mfree (pms, TY_POINTER) } call sfree (sp) end procedure icombined (in, out, scales, zeros, wts, offsets, nimages, bufsize) pointer in[nimages] # Input images pointer out[ARB] # Output images real scales[nimages] # Scales real zeros[nimages] # Zeros real wts[nimages] # Weights int offsets[nimages,ARB] # Input image offsets int nimages # Number of input images int bufsize # IMIO buffer size char str[1] int i, j, k, npts, fd, stropen(), xt_imgnld() pointer sp, d, id, n, m, lflag, v, dbuf pointer im, buf, xt_opix(), impl1i() errchk stropen, xt_cpix, xt_opix, xt_imgnld, impl1i, ic_combined pointer impl1d() errchk impl1d include "../icombine.com" begin npts = IM_LEN(out[1],1) # Allocate memory. call smark (sp) call salloc (dbuf, nimages, TY_POINTER) call salloc (d, nimages, TY_POINTER) call salloc (id, nimages, TY_POINTER) call salloc (n, npts, TY_INT) call salloc (m, nimages, TY_POINTER) call salloc (lflag, nimages, TY_INT) call salloc (v, IM_MAXDIM, TY_LONG) call amovki (D_ALL, Memi[lflag], nimages) call amovkl (1, Meml[v], IM_MAXDIM) # If not aligned or growing create data buffers of output length # otherwise use the IMIO buffers. if (!aligned || grow >= 1.) { do i = 1, nimages { call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) call aclrd (Memd[Memi[dbuf+i-1]], npts) } } else { do i = 1, nimages { im = xt_opix (in[i], i, 1) if (im != in[i]) { call salloc (Memi[dbuf+i-1], npts, TY_DOUBLE) call aclrd (Memd[Memi[dbuf+i-1]], npts) } } call amovki (NULL, Memi[dbuf], nimages) } if (project) { call imseti (in[1], IM_NBUFS, nimages) call imseti (in[1], IM_BUFFRAC, 0) call imseti (in[1], IM_BUFSIZE, bufsize) do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } } else { # Reserve FD for string operations. fd = stropen (str, 1, NEW_FILE) # Do I/O to the images. do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } buf = impl1d (out[1]) call aclrd (Memd[buf], npts) if (out[3] != NULL) { buf = impl1d (out[3]) call aclrd (Memd[buf], npts) } if (out[2] != NULL) { buf = impl1i (out[2]) call aclri (Memi[buf], npts) } if (out[4] != NULL) { buf = impl1i (out[4]) call aclri (Memi[buf], npts) } if (out[5] != NULL) { buf = impl1i (out[5]) call aclri (Memi[buf], npts) } if (out[6] != NULL) { buf = impl1i (out[6]) call aclri (Memi[buf], npts) } # Do I/O for first input image line. if (!project) { do i = 1, nimages { call xt_imseti (i, "bufsize", bufsize) j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) call xt_cpix (i) j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } do i = 1, nimages { j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) next j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) next iferr { Meml[v+1] = j j = xt_imgnld (in[i], i, buf, Meml[v], 1) } then { call imseti (im, IM_PIXFD, NULL) call sfree (sp) call strclose (fd) call erract (EA_ERROR) } } } call strclose (fd) } call ic_combined (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) end # IC_COMBINE -- Combine images. procedure ic_combined (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, wts, nimages, npts) pointer in[nimages] # Input images pointer out[ARB] # Output image pointer dbuf[nimages] # Data buffers for nonaligned images pointer d[nimages] # Data pointers pointer id[nimages] # Image index ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Line flags int offsets[nimages,ARB] # Input image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors real wts[nimages] # Combining weights int nimages # Number of input images int npts # Number of points per output line int i, ext, ctor(), errcode() real r, imgetr() pointer sp, fname, imname, v1, v2, v3, work pointer outdata, buf, nmod, nm, pms pointer immap(), impnli() pointer impnld(), imgnld errchk immap, ic_scale, imgetr, ic_grow, ic_growd, ic_rmasks, ic_emask errchk ic_gdatad include "../icombine.com" data ext/0/ begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (v3, IM_MAXDIM, TY_LONG) call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) call ic_scale (in, out, offsets, scales, zeros, wts, nimages) # Set combine parameters switch (combine) { case AVERAGE, SUM, QUAD, NMODEL: if (dowts) keepids = true else keepids = false case MEDIAN: dowts = false keepids = false } docombine = true # Get noise model parameters. if (combine==NMODEL) { call salloc (nmod, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)] = r } else { do i = 1, nimages Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nmod+3*(i-1)+2] = r } } } # Set rejection algorithm specific parameters switch (reject) { case CCDCLIP, CRREJECT: call salloc (nm, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)] = r } else { do i = 1, nimages Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nm+3*(i-1)+2] = r } } if (!keepids) { if (doscale1) keepids = true else { do i = 2, nimages { if (Memr[nm+3*(i-1)] != Memr[nm] || Memr[nm+3*(i-1)+1] != Memr[nm+1] || Memr[nm+3*(i-1)+2] != Memr[nm+2]) { keepids = true break } } } } if (reject == CRREJECT) lsigma = MAX_REAL case MINMAX: mclip = false case PCLIP: mclip = true case AVSIGCLIP, SIGCLIP: if (doscale1) keepids = true case NONE: mclip = false } if (out[4] != NULL) keepids = true if (out[6] != NULL) { keepids = true call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) } if (grow >= 1.) { keepids = true call salloc (work, npts * nimages, TY_INT) } pms = NULL if (keepids) { do i = 1, nimages call salloc (id[i], npts, TY_INT) } # Reduce header memory use. do i = 1, nimages call xt_minhdr (i) while (impnld (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) switch (reject) { case CCDCLIP, CRREJECT: if (mclip) call ic_mccdclipd (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memd[outdata]) else call ic_accdclipd (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memd[outdata]) case MINMAX: call ic_mmd (d, id, n, npts) case PCLIP: call ic_pclipd (d, id, n, nimages, npts, Memd[outdata]) case SIGCLIP: if (mclip) call ic_msigclipd (d, id, n, scales, zeros, nimages, npts, Memd[outdata]) else call ic_asigclipd (d, id, n, scales, zeros, nimages, npts, Memd[outdata]) case AVSIGCLIP: if (mclip) call ic_mavsigclipd (d, id, n, scales, zeros, nimages, npts, Memd[outdata]) else call ic_aavsigclipd (d, id, n, scales, zeros, nimages, npts, Memd[outdata]) } if (pms == NULL || nkeep > 0) { if (docombine) { switch (combine) { case AVERAGE: call ic_averaged (d, id, n, wts, nimages, npts, YES, YES, Memd[outdata]) case MEDIAN: call ic_mediand (d, n, npts, YES, Memd[outdata]) case SUM: call ic_averaged (d, id, n, wts, nimages, npts, YES, NO, Memd[outdata]) case QUAD: call ic_quadd (d, id, n, wts, nimages, npts, YES, YES, Memd[outdata]) case NMODEL: call ic_nmodeld (d, id, n, Memr[nmod], wts, nimages, npts, YES, YES, Memd[outdata]) } } } if (grow >= 1.) call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, pms) if (pms == NULL) { if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnld (out[3], buf, Meml[v1]) call ic_sigmad (d, id, n, wts, npts, Memd[outdata], Memd[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) } call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } if (pms != NULL) { if (nkeep > 0) { call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) call imunmap (out[1]) iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { switch (errcode()) { case SYS_FXFOPNOEXTNV: call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) ext = ext + 1 call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext) iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { buf = NULL ext = 0 } repeat { call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext+1) iferr (outdata = immap (Memc[imname],READ_WRITE,0)) break if (buf != NULL) call imunmap (buf) buf = outdata ext = ext + 1 } default: call erract (EA_ERROR) } } out[1] = buf } call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) while (impnld (out[1], outdata, Meml[v1]) != EOF) { call ic_gdatad (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) call ic_growd (Meml[v2], d, id, n, Memi[work], nimages, npts, pms) if (nkeep > 0) { do i = 1, npts { if (n[i] < nkeep) { Meml[v1+1] = Meml[v1+1] - 1 if (imgnld (out[1], buf, Meml[v1]) == EOF) ; call amovd (Memd[buf], Memd[outdata], npts) break } } } switch (combine) { case AVERAGE: call ic_averaged (d, id, n, wts, nimages, npts, NO, YES, Memd[outdata]) case MEDIAN: call ic_mediand (d, n, npts, NO, Memd[outdata]) case SUM: call ic_averaged (d, id, n, wts, nimages, npts, NO, NO, Memd[outdata]) case QUAD: call ic_quadd (d, id, n, wts, nimages, npts, NO, YES, Memd[outdata]) case NMODEL: call ic_nmodeld (d, id, n, Memr[nmod], wts, nimages, npts, NO, YES, Memd[outdata]) } if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnld (out[3], buf, Meml[v1]) call ic_sigmad (d, id, n, wts, npts, Memd[outdata], Memd[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } do i = 1, nimages call pm_close (Memi[pms+i-1]) call mfree (pms, TY_POINTER) } call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icpclip.x000066400000000000000000000450131332166314300242260ustar00rootroot00000000000000# 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 = max (0, 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 = max (0, 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n4 = nh - nl + 1 } # If any pixels are rejected recompute the median. if (nl > 1 || nh < n1) { n5 = nl + n4 / 2 if (mod (n4, 2) == 0) { med = Mems[d[n5-1]+j] med = (med + Mems[d[n5]+j]) / 2. } else med = Mems[d[n5]+j] n[i] = n4 } if (combine == MEDIAN) median[i] = med # Reorder if pixels only if necessary. if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { k = max (nl, n4 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mems[d[l]+j] = Mems[d[k]+j] if (grow >= 1.) { mp1 = m[l] + j mp2 = m[k] + j id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+j] = Memi[m[k]+j] k = k + 1 } } else { do l = 1, min (n1, nl - 1) { Mems[d[l]+j] = Mems[d[k]+j] k = k + 1 } } } } # Check if data flag needs to be reset for rejected pixels. if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag whether the median has been computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_PCLIP -- Percentile clip # # 1) Find the median # 2) Find the pixel which is the specified order index away # 3) Use the data value difference as a sigma and apply clipping # 4) Since the median is known return it so it does not have to be recomputed procedure ic_pclipi (d, m, n, nimages, npts, median) pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[npts] # Number of good pixels int nimages # Number of input images int npts # Number of output points per line real median[npts] # Median int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep bool even, fp_equalr() real sigma, r, s, t pointer sp, resid, mp1, mp2 real med include "../icombine.com" begin # There must be at least MINCLIP and more than nkeep pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (resid, nimages+1, TY_REAL) # Set sign of pclip parameter if (pclip < 0) t = -1. else t = 1. # If there are no rejected pixels compute certain parameters once. if (dflag == D_ALL) { n1 = max (0, 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 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) if (n1 == 0) { if (combine == MEDIAN) median[i] = blank next } n2 = 1 + n1 / 2 even = (mod (n1, 2) == 0) if (pclip < 0) { if (even) n3 = max (1, nint (n2 - 1 + pclip)) else n3 = max (1, nint (n2 + pclip)) } else n3 = min (n1, nint (n2 + pclip)) } j = i - 1 if (even) { med = Memi[d[n2-1]+j] med = (med + Memi[d[n2]+j]) / 2. } else med = Memi[d[n2]+j] if (n1 < max (MINCLIP, maxkeep+1)) { if (combine == MEDIAN) median[i] = med next } # Define sigma for clipping sigma = t * (Memi[d[n3]+j] - med) if (fp_equalr (sigma, 0.)) { if (combine == MEDIAN) median[i] = med next } # Reject pixels and save residuals. # Check if any pixels are clipped. # If so recompute the median and reset the number of good pixels. # Only reorder if needed. for (nl=1; nl<=n1; nl=nl+1) { r = (med - Memi[d[nl]+j]) / sigma if (r < lsigma) break Memr[resid+nl] = r } for (nh=n1; nh>=1; nh=nh-1) { r = (Memi[d[nh]+j] - med) / sigma if (r < hsigma) break Memr[resid+nh] = r } n4 = nh - nl + 1 # If too many pixels are rejected add some back in. # All pixels with the same residual are added. while (n4 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n4 = nh - nl + 1 } # If any pixels are rejected recompute the median. if (nl > 1 || nh < n1) { n5 = nl + n4 / 2 if (mod (n4, 2) == 0) { med = Memi[d[n5-1]+j] med = (med + Memi[d[n5]+j]) / 2. } else med = Memi[d[n5]+j] n[i] = n4 } if (combine == MEDIAN) median[i] = med # Reorder if pixels only if necessary. if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { k = max (nl, n4 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memi[d[l]+j] = Memi[d[k]+j] if (grow >= 1.) { mp1 = m[l] + j mp2 = m[k] + j id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+j] = Memi[m[k]+j] k = k + 1 } } else { do l = 1, min (n1, nl - 1) { Memi[d[l]+j] = Memi[d[k]+j] k = k + 1 } } } } # Check if data flag needs to be reset for rejected pixels. if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 = max (0, 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 = max (0, 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n4 = nh - nl + 1 } # If any pixels are rejected recompute the median. if (nl > 1 || nh < n1) { n5 = nl + n4 / 2 if (mod (n4, 2) == 0) { med = Memr[d[n5-1]+j] med = (med + Memr[d[n5]+j]) / 2. } else med = Memr[d[n5]+j] n[i] = n4 } if (combine == MEDIAN) median[i] = med # Reorder if pixels only if necessary. if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { k = max (nl, n4 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memr[d[l]+j] = Memr[d[k]+j] if (grow >= 1.) { mp1 = m[l] + j mp2 = m[k] + j id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+j] = Memi[m[k]+j] k = k + 1 } } else { do l = 1, min (n1, nl - 1) { Memr[d[l]+j] = Memr[d[k]+j] k = k + 1 } } } } # Check if data flag needs to be reset for rejected pixels. if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag whether the median has been computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_PCLIP -- Percentile clip # # 1) Find the median # 2) Find the pixel which is the specified order index away # 3) Use the data value difference as a sigma and apply clipping # 4) Since the median is known return it so it does not have to be recomputed procedure ic_pclipd (d, m, n, nimages, npts, median) pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[npts] # Number of good pixels int nimages # Number of input images int npts # Number of output points per line double median[npts] # Median int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep bool even, fp_equalr() real sigma, r, s, t pointer sp, resid, mp1, mp2 double med include "../icombine.com" begin # There must be at least MINCLIP and more than nkeep pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (resid, nimages+1, TY_REAL) # Set sign of pclip parameter if (pclip < 0) t = -1. else t = 1. # If there are no rejected pixels compute certain parameters once. if (dflag == D_ALL) { n1 = max (0, 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 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) if (n1 == 0) { if (combine == MEDIAN) median[i] = blank next } n2 = 1 + n1 / 2 even = (mod (n1, 2) == 0) if (pclip < 0) { if (even) n3 = max (1, nint (n2 - 1 + pclip)) else n3 = max (1, nint (n2 + pclip)) } else n3 = min (n1, nint (n2 + pclip)) } j = i - 1 if (even) { med = Memd[d[n2-1]+j] med = (med + Memd[d[n2]+j]) / 2. } else med = Memd[d[n2]+j] if (n1 < max (MINCLIP, maxkeep+1)) { if (combine == MEDIAN) median[i] = med next } # Define sigma for clipping sigma = t * (Memd[d[n3]+j] - med) if (fp_equalr (sigma, 0.)) { if (combine == MEDIAN) median[i] = med next } # Reject pixels and save residuals. # Check if any pixels are clipped. # If so recompute the median and reset the number of good pixels. # Only reorder if needed. for (nl=1; nl<=n1; nl=nl+1) { r = (med - Memd[d[nl]+j]) / sigma if (r < lsigma) break Memr[resid+nl] = r } for (nh=n1; nh>=1; nh=nh-1) { r = (Memd[d[nh]+j] - med) / sigma if (r < hsigma) break Memr[resid+nh] = r } n4 = nh - nl + 1 # If too many pixels are rejected add some back in. # All pixels with the same residual are added. while (n4 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n4 = nh - nl + 1 } # If any pixels are rejected recompute the median. if (nl > 1 || nh < n1) { n5 = nl + n4 / 2 if (mod (n4, 2) == 0) { med = Memd[d[n5-1]+j] med = (med + Memd[d[n5]+j]) / 2. } else med = Memd[d[n5]+j] n[i] = n4 } if (combine == MEDIAN) median[i] = med # Reorder if pixels only if necessary. if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { k = max (nl, n4 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memd[d[l]+j] = Memd[d[k]+j] if (grow >= 1.) { mp1 = m[l] + j mp2 = m[k] + j id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+j] = Memi[m[k]+j] k = k + 1 } } else { do l = 1, min (n1, nl - 1) { Memd[d[l]+j] = Memd[d[k]+j] k = k + 1 } } } } # Check if data flag needs to be reset for rejected pixels. if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icquad.x000066400000000000000000000245671332166314300240640ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" include "../icmask.h" # IC_QUAD -- Compute the quadrature average (or summed) image line. # Options include a weighted average/sum. procedure ic_quads (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt real sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = Mems[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 do j = 2, n[i] { val = Mems[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val * wt) ** 2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = Mems[d[1]+k] sum = val**2 do j = 2, n[i] { val = Mems[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Mems[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 sumwt = wt do j = 2, n1 { val = Mems[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val* wt) ** 2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = Mems[d[1]+k] sum = val**2 do j = 2, n1 { val = Mems[d[j]+k] sum = sum + val**2 } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Mems[d[1]+k] sum = val**2 do j = 2, n1 { val = Mems[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end # IC_QUAD -- Compute the quadrature average (or summed) image line. # Options include a weighted average/sum. procedure ic_quadi (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt real sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = Memi[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 do j = 2, n[i] { val = Memi[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val * wt) ** 2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = Memi[d[1]+k] sum = val**2 do j = 2, n[i] { val = Memi[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Memi[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 sumwt = wt do j = 2, n1 { val = Memi[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val* wt) ** 2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = Memi[d[1]+k] sum = val**2 do j = 2, n1 { val = Memi[d[j]+k] sum = sum + val**2 } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Memi[d[1]+k] sum = val**2 do j = 2, n1 { val = Memi[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end # IC_QUAD -- Compute the quadrature average (or summed) image line. # Options include a weighted average/sum. procedure ic_quadr (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? real average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt real sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = Memr[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 do j = 2, n[i] { val = Memr[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val * wt) ** 2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = Memr[d[1]+k] sum = val**2 do j = 2, n[i] { val = Memr[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Memr[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 sumwt = wt do j = 2, n1 { val = Memr[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val* wt) ** 2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = Memr[d[1]+k] sum = val**2 do j = 2, n1 { val = Memr[d[j]+k] sum = sum + val**2 } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Memr[d[1]+k] sum = val**2 do j = 2, n1 { val = Memr[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end # IC_QUAD -- Compute the quadrature average (or summed) image line. # Options include a weighted average/sum. procedure ic_quadd (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? double average[npts] # Average (returned) int i, j, k, n1 real val, wt, sumwt double sum include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = Memd[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 do j = 2, n[i] { val = Memd[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val * wt) ** 2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = Memd[d[1]+k] sum = val**2 do j = 2, n[i] { val = Memd[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Memd[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 sumwt = wt do j = 2, n1 { val = Memd[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val* wt) ** 2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = Memd[d[1]+k] sum = val**2 do j = 2, n1 { val = Memd[d[j]+k] sum = sum + val**2 } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Memd[d[1]+k] sum = val**2 do j = 2, n1 { val = Memd[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icsclip.x000066400000000000000000001210561332166314300242330ustar00rootroot00000000000000# 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mems[d[l]+k] = Mems[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Mems[d[l]+k] = Mems[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag that the median has been computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_ASIGCLIP -- Reject pixels using sigma clipping about the average # The initial average rejects the high and low pixels. A correction for # different scalings of the images may be made. Weights are not used. procedure ic_asigclipi (d, m, n, scales, zeros, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line real average[npts] # Average int i, j, k, l, jj, n1, n2, nin, nk, maxkeep real d1, low, high, sum, a, s, r, one data one /1.0/ pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are insufficient pixels go on to the combining if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } # Flag whether returned average needs to be recomputed. if (dowts || combine != AVERAGE) docombine = true else docombine = false # Save the residuals and the sigma scaling corrections if needed. call smark (sp) call salloc (resid, nimages+1, TY_REAL) if (doscale1) call salloc (w, nimages, TY_REAL) # Do sigma clipping. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) # If there are not enough pixels simply compute the average. if (n1 < max (3, maxkeep)) { if (!docombine) { if (n1 == 0) average[i] = blank else { sum = Memi[d[1]+k] do j = 2, n1 sum = sum + Memi[d[j]+k] average[i] = sum / n1 } } next } # Compute average with the high and low rejected. low = Memi[d[1]+k] high = Memi[d[2]+k] if (low > high) { d1 = low low = high high = d1 } sum = 0. do j = 3, n1 { d1 = Memi[d[j]+k] if (d1 < low) { sum = sum + low low = d1 } else if (d1 > high) { sum = sum + high high = d1 } else sum = sum + d1 } a = sum / (n1 - 2) sum = sum + low + high # Iteratively reject pixels and compute the final average if needed. # Compact the data and keep track of the image IDs if needed. repeat { n2 = n1 if (doscale1) { # Compute sigma corrected for scaling. s = 0. wp = w - 1 do j = 1, n1 { dp1 = d[j] + k mp1 = m[j] + k wp = wp + 1 d1 = Memi[dp1] l = Memi[mp1] r = sqrt (max (one, (a + zeros[l]) / scales[l])) s = s + ((d1 - a) / r) ** 2 Memr[wp] = r } s = sqrt (s / (n1 - 1)) # Reject pixels. Save the residuals and data values. wp = w - 1 if (s > 0.) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k wp = wp + 1 d1 = Memi[dp1] r = (d1 - a) / (s * Memr[wp]) if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs (r) if (j < n1) { dp2 = d[n1] + k Memi[dp1] = Memi[dp2] Memi[dp2] = d1 Memr[wp] = Memr[w+n1-1] mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } else { # Compute the sigma without scale correction. s = 0. do j = 1, n1 s = s + (Memi[d[j]+k] - a) ** 2 s = sqrt (s / (n1 - 1)) # Reject pixels. Save the residuals and data values. if (s > 0.) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k d1 = Memi[dp1] r = (d1 - a) / s if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs (r) if (j < n1) { dp2 = d[n1] + k Memi[dp1] = Memi[dp2] Memi[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l } j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } # Recompute the average. if (n1 > 1) a = sum / n1 } until (n1 == n2 || n1 <= max (2, maxkeep)) # If too many pixels are rejected add some back. # All pixels with equal residuals are added back. if (n1 < maxkeep) { nk = maxkeep if (doscale1) { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memi[dp1] Memi[dp1] = Memi[dp2] Memi[dp2] = d1 mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } sum = sum + Memi[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } else { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memi[dp1] Memi[dp1] = Memi[dp2] Memi[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } } sum = sum + Memi[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } # Recompute the average. if (n1 > 1) a = sum / n1 } # Save the average if needed. n[i] = n1 if (!docombine) { if (n1 > 0) average[i] = a else average[i] = blank } } # Check if the data flag has to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } call sfree (sp) end # IC_MSIGCLIP -- Reject pixels using sigma clipping about the median procedure ic_msigclipi (d, m, n, scales, zeros, nimages, npts, median) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line real median[npts] # Median int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep real r, s pointer sp, resid, w, mp1, mp2 real med, one data one /1.0/ include "../icombine.com" begin # If there are insufficient pixels go on to the combining if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } # Save the residuals and sigma scaling corrections if needed. call smark (sp) call salloc (resid, nimages+1, TY_REAL) if (doscale1) call salloc (w, nimages, TY_REAL) # Compute median and sigma and iteratively clip. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) nl = 1 nh = n1 repeat { n2 = n1 n3 = nl + n1 / 2 if (n1 == 0) med = blank else if (mod (n1, 2) == 0) med = (Memi[d[n3-1]+k] + Memi[d[n3]+k]) / 2. else med = Memi[d[n3]+k] if (n1 >= max (MINCLIP, maxkeep+1)) { if (doscale1) { # Compute the sigma with scaling correction. s = 0. do j = nl, nh { l = Memi[m[j]+k] r = sqrt (max (one, (med + zeros[l]) / scales[l])) s = s + ((Memi[d[j]+k] - med) / r) ** 2 Memr[w+j-1] = r } s = sqrt (s / (n1 - 1)) # Reject pixels and save the residuals. if (s > 0.) { for (; nl <= nh; nl = nl + 1) { r = (med - Memi[d[nl]+k]) / (s * Memr[w+nl-1]) if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { r = (Memi[d[nh]+k] - med) / (s * Memr[w+nh-1]) if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } } else { # Compute the sigma without scaling correction. s = 0. do j = nl, nh s = s + (Memi[d[j]+k] - med) ** 2 s = sqrt (s / (n1 - 1)) # Reject pixels and save the residuals. if (s > 0.) { for (; nl <= nh; nl = nl + 1) { r = (med - Memi[d[nl]+k]) / s if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { r = (Memi[d[nh]+k] - med) / s if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) # If too many pixels are rejected add some back. # All pixels with equal residuals are added back. while (n1 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memi[d[l]+k] = Memi[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memi[d[l]+k] = Memi[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memr[d[l]+k] = Memr[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memr[d[l]+k] = Memr[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } # Flag that the median has been computed. if (combine == MEDIAN) docombine = false else docombine = true call sfree (sp) end # IC_ASIGCLIP -- Reject pixels using sigma clipping about the average # The initial average rejects the high and low pixels. A correction for # different scalings of the images may be made. Weights are not used. procedure ic_asigclipd (d, m, n, scales, zeros, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line double average[npts] # Average int i, j, k, l, jj, n1, n2, nin, nk, maxkeep double d1, low, high, sum, a, s, r, one data one /1.0D0/ pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are insufficient pixels go on to the combining if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } # Flag whether returned average needs to be recomputed. if (dowts || combine != AVERAGE) docombine = true else docombine = false # Save the residuals and the sigma scaling corrections if needed. call smark (sp) call salloc (resid, nimages+1, TY_REAL) if (doscale1) call salloc (w, nimages, TY_REAL) # Do sigma clipping. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) # If there are not enough pixels simply compute the average. if (n1 < max (3, maxkeep)) { if (!docombine) { if (n1 == 0) average[i] = blank else { sum = Memd[d[1]+k] do j = 2, n1 sum = sum + Memd[d[j]+k] average[i] = sum / n1 } } next } # Compute average with the high and low rejected. low = Memd[d[1]+k] high = Memd[d[2]+k] if (low > high) { d1 = low low = high high = d1 } sum = 0. do j = 3, n1 { d1 = Memd[d[j]+k] if (d1 < low) { sum = sum + low low = d1 } else if (d1 > high) { sum = sum + high high = d1 } else sum = sum + d1 } a = sum / (n1 - 2) sum = sum + low + high # Iteratively reject pixels and compute the final average if needed. # Compact the data and keep track of the image IDs if needed. repeat { n2 = n1 if (doscale1) { # Compute sigma corrected for scaling. s = 0. wp = w - 1 do j = 1, n1 { dp1 = d[j] + k mp1 = m[j] + k wp = wp + 1 d1 = Memd[dp1] l = Memi[mp1] r = sqrt (max (one, (a + zeros[l]) / scales[l])) s = s + ((d1 - a) / r) ** 2 Memr[wp] = r } s = sqrt (s / (n1 - 1)) # Reject pixels. Save the residuals and data values. wp = w - 1 if (s > 0.) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k wp = wp + 1 d1 = Memd[dp1] r = (d1 - a) / (s * Memr[wp]) if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs (r) if (j < n1) { dp2 = d[n1] + k Memd[dp1] = Memd[dp2] Memd[dp2] = d1 Memr[wp] = Memr[w+n1-1] mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } else { # Compute the sigma without scale correction. s = 0. do j = 1, n1 s = s + (Memd[d[j]+k] - a) ** 2 s = sqrt (s / (n1 - 1)) # Reject pixels. Save the residuals and data values. if (s > 0.) { for (j=1; j<=n1; j=j+1) { dp1 = d[j] + k d1 = Memd[dp1] r = (d1 - a) / s if (r < -lsigma || r > hsigma) { Memr[resid+n1] = abs (r) if (j < n1) { dp2 = d[n1] + k Memd[dp1] = Memd[dp2] Memd[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[n1] + k l = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = l } j = j - 1 } sum = sum - d1 n1 = n1 - 1 } } } } # Recompute the average. if (n1 > 1) a = sum / n1 } until (n1 == n2 || n1 <= max (2, maxkeep)) # If too many pixels are rejected add some back. # All pixels with equal residuals are added back. if (n1 < maxkeep) { nk = maxkeep if (doscale1) { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k mp1 = m[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memd[dp1] Memd[dp1] = Memd[dp2] Memd[dp2] = d1 mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } sum = sum + Memd[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } else { for (j=n1+1; j<=nk; j=j+1) { dp1 = d[j] + k r = Memr[resid+j] jj = 0 do l = j+1, n2 { s = Memr[resid+l] if (s < r + TOL) { if (s > r - TOL) jj = jj + 1 else { jj = 0 Memr[resid+l] = r r = s dp2 = d[l] + k d1 = Memd[dp1] Memd[dp1] = Memd[dp2] Memd[dp2] = d1 if (keepids) { mp1 = m[j] + k mp2 = m[l] + k s = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = s } } } } sum = sum + Memd[dp1] n1 = n1 + 1 nk = max (nk, j+jj) } } # Recompute the average. if (n1 > 1) a = sum / n1 } # Save the average if needed. n[i] = n1 if (!docombine) { if (n1 > 0) average[i] = a else average[i] = blank } } # Check if the data flag has to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, n[i]) != nin) { dflag = D_MIX break } } } call sfree (sp) end # IC_MSIGCLIP -- Reject pixels using sigma clipping about the median procedure ic_msigclipd (d, m, n, scales, zeros, nimages, npts, median) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line double median[npts] # Median int i, j, k, l, id, n1, n2, n3, nl, nh, nin, maxkeep real r, s pointer sp, resid, w, mp1, mp2 double med, one data one /1.0D0/ include "../icombine.com" begin # If there are insufficient pixels go on to the combining if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } # Save the residuals and sigma scaling corrections if needed. call smark (sp) call salloc (resid, nimages+1, TY_REAL) if (doscale1) call salloc (w, nimages, TY_REAL) # Compute median and sigma and iteratively clip. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, n[i]) if (nkeep < 0) maxkeep = max (0, n1 + nkeep) else maxkeep = min (n1, nkeep) nl = 1 nh = n1 repeat { n2 = n1 n3 = nl + n1 / 2 if (n1 == 0) med = blank else if (mod (n1, 2) == 0) med = (Memd[d[n3-1]+k] + Memd[d[n3]+k]) / 2. else med = Memd[d[n3]+k] if (n1 >= max (MINCLIP, maxkeep+1)) { if (doscale1) { # Compute the sigma with scaling correction. s = 0. do j = nl, nh { l = Memi[m[j]+k] r = sqrt (max (one, (med + zeros[l]) / scales[l])) s = s + ((Memd[d[j]+k] - med) / r) ** 2 Memr[w+j-1] = r } s = sqrt (s / (n1 - 1)) # Reject pixels and save the residuals. if (s > 0.) { for (; nl <= nh; nl = nl + 1) { r = (med - Memd[d[nl]+k]) / (s * Memr[w+nl-1]) if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { r = (Memd[d[nh]+k] - med) / (s * Memr[w+nh-1]) if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } } else { # Compute the sigma without scaling correction. s = 0. do j = nl, nh s = s + (Memd[d[j]+k] - med) ** 2 s = sqrt (s / (n1 - 1)) # Reject pixels and save the residuals. if (s > 0.) { for (; nl <= nh; nl = nl + 1) { r = (med - Memd[d[nl]+k]) / s if (r <= lsigma) break Memr[resid+nl] = r n1 = n1 - 1 } for (; nh >= nl; nh = nh - 1) { r = (Memd[d[nh]+k] - med) / s if (r <= hsigma) break Memr[resid+nh] = r n1 = n1 - 1 } } } } } until (n1 == n2 || n1 < max (MINCLIP, maxkeep+1)) # If too many pixels are rejected add some back. # All pixels with equal residuals are added back. while (n1 < maxkeep) { if (nl == 1) nh = nh + 1 else if (nh == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Memd[d[l]+k] = Memd[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Memd[d[l]+k] = Memd[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icsigma.x000066400000000000000000000222121332166314300242130ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "../icombine.h" # IC_SIGMA -- Compute the sigma image line. # The estimated sigma includes a correction for the finite population. # Weights are used if desired. procedure ic_sigmas (d, m, n, wts, npts, average, sigma) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of points real wts[ARB] # Weights int npts # Number of output points per line real average[npts] # Average real sigma[npts] # Sigma line (returned) int i, j, k, n1 real wt, sigcor, sumwt real a, sum include "../icombine.com" begin if (dflag == D_ALL) { n1 = n[1] if (dowts) { if (n1 > 1) sigcor = real (n1) / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Mems[d[1]+k] - a) ** 2 * wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Mems[d[j]+k] - a) ** 2 * wt } sigma[i] = sqrt (sum * sigcor) } } else { if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] sum = (Mems[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Mems[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } } } else if (dflag == D_NONE) { do i = 1, npts sigma[i] = blank } else { if (dowts) { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = real (n1) / real (n1 -1) else sigcor = 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Mems[d[1]+k] - a) ** 2 * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Mems[d[j]+k] - a) ** 2 * wt sumwt = sumwt + wt } if (sumwt > 0) sigma[i] = sqrt (sum / sumwt * sigcor) else { sum = (Mems[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Mems[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum / n1 * sigcor) } } else sigma[i] = blank } } else { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. a = average[i] sum = (Mems[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Mems[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } else sigma[i] = blank } } } end # IC_SIGMA -- Compute the sigma image line. # The estimated sigma includes a correction for the finite population. # Weights are used if desired. procedure ic_sigmai (d, m, n, wts, npts, average, sigma) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of points real wts[ARB] # Weights int npts # Number of output points per line real average[npts] # Average real sigma[npts] # Sigma line (returned) int i, j, k, n1 real wt, sigcor, sumwt real a, sum include "../icombine.com" begin if (dflag == D_ALL) { n1 = n[1] if (dowts) { if (n1 > 1) sigcor = real (n1) / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Memi[d[1]+k] - a) ** 2 * wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Memi[d[j]+k] - a) ** 2 * wt } sigma[i] = sqrt (sum * sigcor) } } else { if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] sum = (Memi[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memi[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } } } else if (dflag == D_NONE) { do i = 1, npts sigma[i] = blank } else { if (dowts) { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = real (n1) / real (n1 -1) else sigcor = 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Memi[d[1]+k] - a) ** 2 * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Memi[d[j]+k] - a) ** 2 * wt sumwt = sumwt + wt } if (sumwt > 0) sigma[i] = sqrt (sum / sumwt * sigcor) else { sum = (Memi[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memi[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum / n1 * sigcor) } } else sigma[i] = blank } } else { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. a = average[i] sum = (Memi[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memi[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } else sigma[i] = blank } } } end # IC_SIGMA -- Compute the sigma image line. # The estimated sigma includes a correction for the finite population. # Weights are used if desired. procedure ic_sigmar (d, m, n, wts, npts, average, sigma) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of points real wts[ARB] # Weights int npts # Number of output points per line real average[npts] # Average real sigma[npts] # Sigma line (returned) int i, j, k, n1 real wt, sigcor, sumwt real a, sum include "../icombine.com" begin if (dflag == D_ALL) { n1 = n[1] if (dowts) { if (n1 > 1) sigcor = real (n1) / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Memr[d[1]+k] - a) ** 2 * wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Memr[d[j]+k] - a) ** 2 * wt } sigma[i] = sqrt (sum * sigcor) } } else { if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] sum = (Memr[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memr[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } } } else if (dflag == D_NONE) { do i = 1, npts sigma[i] = blank } else { if (dowts) { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = real (n1) / real (n1 -1) else sigcor = 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Memr[d[1]+k] - a) ** 2 * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Memr[d[j]+k] - a) ** 2 * wt sumwt = sumwt + wt } if (sumwt > 0) sigma[i] = sqrt (sum / sumwt * sigcor) else { sum = (Memr[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memr[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum / n1 * sigcor) } } else sigma[i] = blank } } else { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. a = average[i] sum = (Memr[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memr[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } else sigma[i] = blank } } } end # IC_SIGMA -- Compute the sigma image line. # The estimated sigma includes a correction for the finite population. # Weights are used if desired. procedure ic_sigmad (d, m, n, wts, npts, average, sigma) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of points real wts[ARB] # Weights int npts # Number of output points per line double average[npts] # Average double sigma[npts] # Sigma line (returned) int i, j, k, n1 real wt, sigcor, sumwt double a, sum include "../icombine.com" begin if (dflag == D_ALL) { n1 = n[1] if (dowts) { if (n1 > 1) sigcor = real (n1) / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Memd[d[1]+k] - a) ** 2 * wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Memd[d[j]+k] - a) ** 2 * wt } sigma[i] = sqrt (sum * sigcor) } } else { if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] sum = (Memd[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memd[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } } } else if (dflag == D_NONE) { do i = 1, npts sigma[i] = blank } else { if (dowts) { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = real (n1) / real (n1 -1) else sigcor = 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Memd[d[1]+k] - a) ** 2 * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Memd[d[j]+k] - a) ** 2 * wt sumwt = sumwt + wt } if (sumwt > 0) sigma[i] = sqrt (sum / sumwt * sigcor) else { sum = (Memd[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memd[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum / n1 * sigcor) } } else sigma[i] = blank } } else { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. a = average[i] sum = (Memd[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Memd[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } else sigma[i] = blank } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icsort.x000066400000000000000000000560511332166314300241120ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. define LOGPTR 32 # log2(maxpts) (4e9) # IC_SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. procedure ic_sorts (a, b, nvecs, npts) pointer a[ARB] # pointer to input vectors short b[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors short pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] define swap {temp=$1;$1=$2;$2=temp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix b[i] = Mems[a[i]+l] # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) # bac b[2] = pivot else { # bca b[2] = temp3 b[3] = pivot } } else { # cba b[1] = temp3 b[3] = pivot } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) # acb b[2] = temp3 else { # cab b[1] = temp3 b[2] = pivot } } else next } goto copy_ } # General case do i = 1, npix b[i] = Mems[a[i]+l] lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) # out of order pair swap (b[i], b[j]) # interchange elements } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix Mems[a[i]+l] = b[i] } end # IC_2SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. A second integer set of # vectors is sorted. procedure ic_2sorts (a, b, c, d, nvecs, npts) pointer a[ARB] # pointer to input vectors short b[ARB] # work array pointer c[ARB] # pointer to associated integer vectors int d[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors short pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp define swap {temp=$1;$1=$2;$2=temp} define iswap {itemp=$1;$1=$2;$2=itemp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix { b[i] = Mems[a[i]+l] d[i] = Memi[c[i]+l] } # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot iswap (d[1], d[2]) } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) { # bac b[2] = pivot iswap (d[1], d[2]) } else { # bca b[2] = temp3 b[3] = pivot itemp = d[2] d[2] = d[3] d[3] = d[1] d[1] = itemp } } else { # cba b[1] = temp3 b[3] = pivot iswap (d[1], d[3]) } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) { # acb b[2] = temp3 iswap (d[2], d[3]) } else { # cab b[1] = temp3 b[2] = pivot itemp = d[2] d[2] = d[1] d[1] = d[3] d[3] = itemp } } else next } goto copy_ } # General case lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]); swap (d[j], d[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) { # out of order pair swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) } } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix { Mems[a[i]+l] = b[i] Memi[c[i]+l] = d[i] } } end # IC_SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. procedure ic_sorti (a, b, nvecs, npts) pointer a[ARB] # pointer to input vectors int b[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors int pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] define swap {temp=$1;$1=$2;$2=temp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix b[i] = Memi[a[i]+l] # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) # bac b[2] = pivot else { # bca b[2] = temp3 b[3] = pivot } } else { # cba b[1] = temp3 b[3] = pivot } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) # acb b[2] = temp3 else { # cab b[1] = temp3 b[2] = pivot } } else next } goto copy_ } # General case do i = 1, npix b[i] = Memi[a[i]+l] lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) # out of order pair swap (b[i], b[j]) # interchange elements } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix Memi[a[i]+l] = b[i] } end # IC_2SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. A second integer set of # vectors is sorted. procedure ic_2sorti (a, b, c, d, nvecs, npts) pointer a[ARB] # pointer to input vectors int b[ARB] # work array pointer c[ARB] # pointer to associated integer vectors int d[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors int pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp define swap {temp=$1;$1=$2;$2=temp} define iswap {itemp=$1;$1=$2;$2=itemp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix { b[i] = Memi[a[i]+l] d[i] = Memi[c[i]+l] } # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot iswap (d[1], d[2]) } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) { # bac b[2] = pivot iswap (d[1], d[2]) } else { # bca b[2] = temp3 b[3] = pivot itemp = d[2] d[2] = d[3] d[3] = d[1] d[1] = itemp } } else { # cba b[1] = temp3 b[3] = pivot iswap (d[1], d[3]) } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) { # acb b[2] = temp3 iswap (d[2], d[3]) } else { # cab b[1] = temp3 b[2] = pivot itemp = d[2] d[2] = d[1] d[1] = d[3] d[3] = itemp } } else next } goto copy_ } # General case lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]); swap (d[j], d[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) { # out of order pair swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) } } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix { Memi[a[i]+l] = b[i] Memi[c[i]+l] = d[i] } } end # IC_SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. procedure ic_sortr (a, b, nvecs, npts) pointer a[ARB] # pointer to input vectors real b[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors real pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] define swap {temp=$1;$1=$2;$2=temp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix b[i] = Memr[a[i]+l] # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) # bac b[2] = pivot else { # bca b[2] = temp3 b[3] = pivot } } else { # cba b[1] = temp3 b[3] = pivot } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) # acb b[2] = temp3 else { # cab b[1] = temp3 b[2] = pivot } } else next } goto copy_ } # General case do i = 1, npix b[i] = Memr[a[i]+l] lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) # out of order pair swap (b[i], b[j]) # interchange elements } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix Memr[a[i]+l] = b[i] } end # IC_2SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. A second integer set of # vectors is sorted. procedure ic_2sortr (a, b, c, d, nvecs, npts) pointer a[ARB] # pointer to input vectors real b[ARB] # work array pointer c[ARB] # pointer to associated integer vectors int d[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors real pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp define swap {temp=$1;$1=$2;$2=temp} define iswap {itemp=$1;$1=$2;$2=itemp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix { b[i] = Memr[a[i]+l] d[i] = Memi[c[i]+l] } # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot iswap (d[1], d[2]) } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) { # bac b[2] = pivot iswap (d[1], d[2]) } else { # bca b[2] = temp3 b[3] = pivot itemp = d[2] d[2] = d[3] d[3] = d[1] d[1] = itemp } } else { # cba b[1] = temp3 b[3] = pivot iswap (d[1], d[3]) } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) { # acb b[2] = temp3 iswap (d[2], d[3]) } else { # cab b[1] = temp3 b[2] = pivot itemp = d[2] d[2] = d[1] d[1] = d[3] d[3] = itemp } } else next } goto copy_ } # General case lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]); swap (d[j], d[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) { # out of order pair swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) } } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix { Memr[a[i]+l] = b[i] Memi[c[i]+l] = d[i] } } end # IC_SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. procedure ic_sortd (a, b, nvecs, npts) pointer a[ARB] # pointer to input vectors double b[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors double pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] define swap {temp=$1;$1=$2;$2=temp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix b[i] = Memd[a[i]+l] # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) # bac b[2] = pivot else { # bca b[2] = temp3 b[3] = pivot } } else { # cba b[1] = temp3 b[3] = pivot } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) # acb b[2] = temp3 else { # cab b[1] = temp3 b[2] = pivot } } else next } goto copy_ } # General case do i = 1, npix b[i] = Memd[a[i]+l] lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) # out of order pair swap (b[i], b[j]) # interchange elements } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix Memd[a[i]+l] = b[i] } end # IC_2SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. A second integer set of # vectors is sorted. procedure ic_2sortd (a, b, c, d, nvecs, npts) pointer a[ARB] # pointer to input vectors double b[ARB] # work array pointer c[ARB] # pointer to associated integer vectors int d[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors double pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp define swap {temp=$1;$1=$2;$2=temp} define iswap {itemp=$1;$1=$2;$2=itemp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix { b[i] = Memd[a[i]+l] d[i] = Memi[c[i]+l] } # Special cases if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot iswap (d[1], d[2]) } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) { # bac b[2] = pivot iswap (d[1], d[2]) } else { # bca b[2] = temp3 b[3] = pivot itemp = d[2] d[2] = d[3] d[3] = d[1] d[1] = itemp } } else { # cba b[1] = temp3 b[3] = pivot iswap (d[1], d[3]) } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) { # acb b[2] = temp3 iswap (d[2], d[3]) } else { # cab b[1] = temp3 b[2] = pivot itemp = d[2] d[2] = d[1] d[1] = d[3] d[3] = itemp } } else next } goto copy_ } # General case lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]); swap (d[j], d[k]) pivot = b[j] # pivot line while (i < j) { for (i=i+1; b[i] < pivot; i=i+1) ; for (j=j-1; j > i; j=j-1) if (b[j] <= pivot) break if (i < j) { # out of order pair swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) } } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix { Memd[a[i]+l] = b[i] Memi[c[i]+l] = d[i] } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/icstat.x000066400000000000000000000542611332166314300240770ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "../icombine.h" define NMAX 100000 # Maximum number of pixels to sample # IC_STAT -- Compute image statistics within specified section. # The image section is relative to a reference image which may be # different than the input image and may have an offset. Only a # subsample of pixels is used. Masked and thresholded pixels are # ignored. Only the desired statistics are computed to increase # efficiency. procedure ic_stats (im, imref, section, offsets, image, nimages, domode, domedian, domean, mode, median, mean) pointer im # Data image pointer imref # Reference image for image section char section[ARB] # Image section int offsets[nimages,ARB] # Image section offset from data to reference int image # Image index (for mask I/O) int nimages # Number of images in offsets. bool domode, domedian, domean # Statistics to compute real mode, median, mean # Statistics int i, j, ndim, n, nv real a pointer sp, v1, v2, dv, va, vb pointer data, mask, dp, lp, mp, imgnls() real asums() short ic_modes() include "../icombine.com" begin call smark (sp) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (dv, IM_MAXDIM, TY_LONG) call salloc (va, IM_MAXDIM, TY_LONG) call salloc (vb, IM_MAXDIM, TY_LONG) # Determine the image section parameters. This must be in terms of # the data image pixel coordinates though the section may be specified # in terms of the reference image coordinates. Limit the number of # pixels in each dimension to a maximum. ndim = IM_NDIM(im) if (project) ndim = ndim - 1 call amovki (1, Memi[v1], IM_MAXDIM) call amovki (1, Memi[va], IM_MAXDIM) call amovki (1, Memi[dv], IM_MAXDIM) call amovi (IM_LEN(imref,1), Memi[vb], ndim) call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) if (im != imref) do i = 1, ndim { Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] } do j = 1, 10 { n = 1 do i = 0, ndim-1 { Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) Memi[dv+i] = j nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] n = n * nv } if (n < NMAX) break } call amovl (Memi[v1], Memi[va], IM_MAXDIM) Memi[va] = 1 if (project) Memi[va+ndim] = image call amovl (Memi[va], Memi[vb], IM_MAXDIM) # Accumulate the pixel values within the section. Masked pixels and # thresholded pixels are ignored. call salloc (data, n, TY_SHORT) dp = data while (imgnls (im, lp, Memi[vb]) != EOF) { call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) lp = lp + Memi[v1] - 1 if (dflag == D_ALL) { if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { a = Mems[lp] if (a >= lthresh && a <= hthresh) { Mems[dp] = a dp = dp + 1 } lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { Mems[dp] = Mems[lp] dp = dp + 1 lp = lp + Memi[dv] } } } else if (dflag == D_MIX) { mp = mask + Memi[v1] - 1 if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { a = Mems[lp] if (a >= lthresh && a <= hthresh) { Mems[dp] = a dp = dp + 1 } } mp = mp + Memi[dv] lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { Mems[dp] = Mems[lp] dp = dp + 1 } mp = mp + Memi[dv] lp = lp + Memi[dv] } } } for (i=2; i<=ndim; i=i+1) { Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] if (Memi[va+i-1] <= Memi[v2+i-1]) break Memi[va+i-1] = Memi[v1+i-1] } if (i > ndim) break call amovl (Memi[va], Memi[vb], IM_MAXDIM) } # Close mask until it is needed again. call ic_mclose1 (image, nimages) n = dp - data if (n < 1) { call sfree (sp) call error (1, "Image section contains no pixels") } # Compute only statistics needed. if (domode || domedian) { call asrts (Mems[data], Mems[data], n) mode = ic_modes (Mems[data], n) median = Mems[data+n/2-1] } if (domean) mean = asums (Mems[data], n) / n call sfree (sp) end define NMIN 10 # Minimum number of pixels for mode calculation define ZRANGE 0.7 # Fraction of pixels about median to use define ZSTEP 0.01 # Step size for search for mode define ZBIN 0.1 # Bin size for mode. # IC_MODE -- Compute mode of an array. The mode is found by binning # with a bin size based on the data range over a fraction of the # pixels about the median and a bin step which may be smaller than the # bin size. If there are too few points the median is returned. # The input array must be sorted. short procedure ic_modes (a, n) short a[n] # Data array int n # Number of points int i, j, k, nmax real z1, z2, zstep, zbin short mode bool fp_equalr() begin if (n < NMIN) return (a[n/2]) # Compute the mode. The array must be sorted. Consider a # range of values about the median point. Use a bin size which # is ZBIN of the range. Step the bin limits in ZSTEP fraction of # the bin size. i = 1 + n * (1. - ZRANGE) / 2. j = 1 + n * (1. + ZRANGE) / 2. z1 = a[i] z2 = a[j] if (fp_equalr (z1, z2)) { mode = z1 return (mode) } zstep = ZSTEP * (z2 - z1) zbin = ZBIN * (z2 - z1) zstep = max (1., zstep) zbin = max (1., zbin) z1 = z1 - zstep k = i nmax = 0 repeat { z1 = z1 + zstep z2 = z1 + zbin for (; i < j && a[i] < z1; i=i+1) ; for (; k < j && a[k] < z2; k=k+1) ; if (k - i > nmax) { nmax = k - i mode = a[(i+k)/2] } } until (k >= j) return (mode) end # IC_STAT -- Compute image statistics within specified section. # The image section is relative to a reference image which may be # different than the input image and may have an offset. Only a # subsample of pixels is used. Masked and thresholded pixels are # ignored. Only the desired statistics are computed to increase # efficiency. procedure ic_stati (im, imref, section, offsets, image, nimages, domode, domedian, domean, mode, median, mean) pointer im # Data image pointer imref # Reference image for image section char section[ARB] # Image section int offsets[nimages,ARB] # Image section offset from data to reference int image # Image index (for mask I/O) int nimages # Number of images in offsets. bool domode, domedian, domean # Statistics to compute real mode, median, mean # Statistics int i, j, ndim, n, nv real a pointer sp, v1, v2, dv, va, vb pointer data, mask, dp, lp, mp, imgnli() real asumi() int ic_modei() include "../icombine.com" begin call smark (sp) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (dv, IM_MAXDIM, TY_LONG) call salloc (va, IM_MAXDIM, TY_LONG) call salloc (vb, IM_MAXDIM, TY_LONG) # Determine the image section parameters. This must be in terms of # the data image pixel coordinates though the section may be specified # in terms of the reference image coordinates. Limit the number of # pixels in each dimension to a maximum. ndim = IM_NDIM(im) if (project) ndim = ndim - 1 call amovki (1, Memi[v1], IM_MAXDIM) call amovki (1, Memi[va], IM_MAXDIM) call amovki (1, Memi[dv], IM_MAXDIM) call amovi (IM_LEN(imref,1), Memi[vb], ndim) call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) if (im != imref) do i = 1, ndim { Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] } do j = 1, 10 { n = 1 do i = 0, ndim-1 { Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) Memi[dv+i] = j nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] n = n * nv } if (n < NMAX) break } call amovl (Memi[v1], Memi[va], IM_MAXDIM) Memi[va] = 1 if (project) Memi[va+ndim] = image call amovl (Memi[va], Memi[vb], IM_MAXDIM) # Accumulate the pixel values within the section. Masked pixels and # thresholded pixels are ignored. call salloc (data, n, TY_INT) dp = data while (imgnli (im, lp, Memi[vb]) != EOF) { call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) lp = lp + Memi[v1] - 1 if (dflag == D_ALL) { if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { a = Memi[lp] if (a >= lthresh && a <= hthresh) { Memi[dp] = a dp = dp + 1 } lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { Memi[dp] = Memi[lp] dp = dp + 1 lp = lp + Memi[dv] } } } else if (dflag == D_MIX) { mp = mask + Memi[v1] - 1 if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { a = Memi[lp] if (a >= lthresh && a <= hthresh) { Memi[dp] = a dp = dp + 1 } } mp = mp + Memi[dv] lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { Memi[dp] = Memi[lp] dp = dp + 1 } mp = mp + Memi[dv] lp = lp + Memi[dv] } } } for (i=2; i<=ndim; i=i+1) { Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] if (Memi[va+i-1] <= Memi[v2+i-1]) break Memi[va+i-1] = Memi[v1+i-1] } if (i > ndim) break call amovl (Memi[va], Memi[vb], IM_MAXDIM) } # Close mask until it is needed again. call ic_mclose1 (image, nimages) n = dp - data if (n < 1) { call sfree (sp) call error (1, "Image section contains no pixels") } # Compute only statistics needed. if (domode || domedian) { call asrti (Memi[data], Memi[data], n) mode = ic_modei (Memi[data], n) median = Memi[data+n/2-1] } if (domean) mean = asumi (Memi[data], n) / n call sfree (sp) end define NMIN 10 # Minimum number of pixels for mode calculation define ZRANGE 0.7 # Fraction of pixels about median to use define ZSTEP 0.01 # Step size for search for mode define ZBIN 0.1 # Bin size for mode. # IC_MODE -- Compute mode of an array. The mode is found by binning # with a bin size based on the data range over a fraction of the # pixels about the median and a bin step which may be smaller than the # bin size. If there are too few points the median is returned. # The input array must be sorted. int procedure ic_modei (a, n) int a[n] # Data array int n # Number of points int i, j, k, nmax real z1, z2, zstep, zbin int mode bool fp_equalr() begin if (n < NMIN) return (a[n/2]) # Compute the mode. The array must be sorted. Consider a # range of values about the median point. Use a bin size which # is ZBIN of the range. Step the bin limits in ZSTEP fraction of # the bin size. i = 1 + n * (1. - ZRANGE) / 2. j = 1 + n * (1. + ZRANGE) / 2. z1 = a[i] z2 = a[j] if (fp_equalr (z1, z2)) { mode = z1 return (mode) } zstep = ZSTEP * (z2 - z1) zbin = ZBIN * (z2 - z1) zstep = max (1., zstep) zbin = max (1., zbin) z1 = z1 - zstep k = i nmax = 0 repeat { z1 = z1 + zstep z2 = z1 + zbin for (; i < j && a[i] < z1; i=i+1) ; for (; k < j && a[k] < z2; k=k+1) ; if (k - i > nmax) { nmax = k - i mode = a[(i+k)/2] } } until (k >= j) return (mode) end # IC_STAT -- Compute image statistics within specified section. # The image section is relative to a reference image which may be # different than the input image and may have an offset. Only a # subsample of pixels is used. Masked and thresholded pixels are # ignored. Only the desired statistics are computed to increase # efficiency. procedure ic_statr (im, imref, section, offsets, image, nimages, domode, domedian, domean, mode, median, mean) pointer im # Data image pointer imref # Reference image for image section char section[ARB] # Image section int offsets[nimages,ARB] # Image section offset from data to reference int image # Image index (for mask I/O) int nimages # Number of images in offsets. bool domode, domedian, domean # Statistics to compute real mode, median, mean # Statistics int i, j, ndim, n, nv real a pointer sp, v1, v2, dv, va, vb pointer data, mask, dp, lp, mp, imgnlr() real asumr() real ic_moder() include "../icombine.com" begin call smark (sp) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (dv, IM_MAXDIM, TY_LONG) call salloc (va, IM_MAXDIM, TY_LONG) call salloc (vb, IM_MAXDIM, TY_LONG) # Determine the image section parameters. This must be in terms of # the data image pixel coordinates though the section may be specified # in terms of the reference image coordinates. Limit the number of # pixels in each dimension to a maximum. ndim = IM_NDIM(im) if (project) ndim = ndim - 1 call amovki (1, Memi[v1], IM_MAXDIM) call amovki (1, Memi[va], IM_MAXDIM) call amovki (1, Memi[dv], IM_MAXDIM) call amovi (IM_LEN(imref,1), Memi[vb], ndim) call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) if (im != imref) do i = 1, ndim { Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] } do j = 1, 10 { n = 1 do i = 0, ndim-1 { Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) Memi[dv+i] = j nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] n = n * nv } if (n < NMAX) break } call amovl (Memi[v1], Memi[va], IM_MAXDIM) Memi[va] = 1 if (project) Memi[va+ndim] = image call amovl (Memi[va], Memi[vb], IM_MAXDIM) # Accumulate the pixel values within the section. Masked pixels and # thresholded pixels are ignored. call salloc (data, n, TY_REAL) dp = data while (imgnlr (im, lp, Memi[vb]) != EOF) { call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) lp = lp + Memi[v1] - 1 if (dflag == D_ALL) { if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { a = Memr[lp] if (a >= lthresh && a <= hthresh) { Memr[dp] = a dp = dp + 1 } lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { Memr[dp] = Memr[lp] dp = dp + 1 lp = lp + Memi[dv] } } } else if (dflag == D_MIX) { mp = mask + Memi[v1] - 1 if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { a = Memr[lp] if (a >= lthresh && a <= hthresh) { Memr[dp] = a dp = dp + 1 } } mp = mp + Memi[dv] lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { Memr[dp] = Memr[lp] dp = dp + 1 } mp = mp + Memi[dv] lp = lp + Memi[dv] } } } for (i=2; i<=ndim; i=i+1) { Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] if (Memi[va+i-1] <= Memi[v2+i-1]) break Memi[va+i-1] = Memi[v1+i-1] } if (i > ndim) break call amovl (Memi[va], Memi[vb], IM_MAXDIM) } # Close mask until it is needed again. call ic_mclose1 (image, nimages) n = dp - data if (n < 1) { call sfree (sp) call error (1, "Image section contains no pixels") } # Compute only statistics needed. if (domode || domedian) { call asrtr (Memr[data], Memr[data], n) mode = ic_moder (Memr[data], n) median = Memr[data+n/2-1] } if (domean) mean = asumr (Memr[data], n) / n call sfree (sp) end define NMIN 10 # Minimum number of pixels for mode calculation define ZRANGE 0.7 # Fraction of pixels about median to use define ZSTEP 0.01 # Step size for search for mode define ZBIN 0.1 # Bin size for mode. # IC_MODE -- Compute mode of an array. The mode is found by binning # with a bin size based on the data range over a fraction of the # pixels about the median and a bin step which may be smaller than the # bin size. If there are too few points the median is returned. # The input array must be sorted. real procedure ic_moder (a, n) real a[n] # Data array int n # Number of points int i, j, k, nmax real z1, z2, zstep, zbin real mode bool fp_equalr() begin if (n < NMIN) return (a[n/2]) # Compute the mode. The array must be sorted. Consider a # range of values about the median point. Use a bin size which # is ZBIN of the range. Step the bin limits in ZSTEP fraction of # the bin size. i = 1 + n * (1. - ZRANGE) / 2. j = 1 + n * (1. + ZRANGE) / 2. z1 = a[i] z2 = a[j] if (fp_equalr (z1, z2)) { mode = z1 return (mode) } zstep = ZSTEP * (z2 - z1) zbin = ZBIN * (z2 - z1) z1 = z1 - zstep k = i nmax = 0 repeat { z1 = z1 + zstep z2 = z1 + zbin for (; i < j && a[i] < z1; i=i+1) ; for (; k < j && a[k] < z2; k=k+1) ; if (k - i > nmax) { nmax = k - i mode = a[(i+k)/2] } } until (k >= j) return (mode) end # IC_STAT -- Compute image statistics within specified section. # The image section is relative to a reference image which may be # different than the input image and may have an offset. Only a # subsample of pixels is used. Masked and thresholded pixels are # ignored. Only the desired statistics are computed to increase # efficiency. procedure ic_statd (im, imref, section, offsets, image, nimages, domode, domedian, domean, mode, median, mean) pointer im # Data image pointer imref # Reference image for image section char section[ARB] # Image section int offsets[nimages,ARB] # Image section offset from data to reference int image # Image index (for mask I/O) int nimages # Number of images in offsets. bool domode, domedian, domean # Statistics to compute real mode, median, mean # Statistics int i, j, ndim, n, nv real a pointer sp, v1, v2, dv, va, vb pointer data, mask, dp, lp, mp, imgnld() double asumd() double ic_moded() include "../icombine.com" begin call smark (sp) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (dv, IM_MAXDIM, TY_LONG) call salloc (va, IM_MAXDIM, TY_LONG) call salloc (vb, IM_MAXDIM, TY_LONG) # Determine the image section parameters. This must be in terms of # the data image pixel coordinates though the section may be specified # in terms of the reference image coordinates. Limit the number of # pixels in each dimension to a maximum. ndim = IM_NDIM(im) if (project) ndim = ndim - 1 call amovki (1, Memi[v1], IM_MAXDIM) call amovki (1, Memi[va], IM_MAXDIM) call amovki (1, Memi[dv], IM_MAXDIM) call amovi (IM_LEN(imref,1), Memi[vb], ndim) call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) if (im != imref) do i = 1, ndim { Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] } do j = 1, 10 { n = 1 do i = 0, ndim-1 { Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) Memi[dv+i] = j nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] n = n * nv } if (n < NMAX) break } call amovl (Memi[v1], Memi[va], IM_MAXDIM) Memi[va] = 1 if (project) Memi[va+ndim] = image call amovl (Memi[va], Memi[vb], IM_MAXDIM) # Accumulate the pixel values within the section. Masked pixels and # thresholded pixels are ignored. call salloc (data, n, TY_DOUBLE) dp = data while (imgnld (im, lp, Memi[vb]) != EOF) { call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) lp = lp + Memi[v1] - 1 if (dflag == D_ALL) { if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { a = Memd[lp] if (a >= lthresh && a <= hthresh) { Memd[dp] = a dp = dp + 1 } lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { Memd[dp] = Memd[lp] dp = dp + 1 lp = lp + Memi[dv] } } } else if (dflag == D_MIX) { mp = mask + Memi[v1] - 1 if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { a = Memd[lp] if (a >= lthresh && a <= hthresh) { Memd[dp] = a dp = dp + 1 } } mp = mp + Memi[dv] lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { Memd[dp] = Memd[lp] dp = dp + 1 } mp = mp + Memi[dv] lp = lp + Memi[dv] } } } for (i=2; i<=ndim; i=i+1) { Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] if (Memi[va+i-1] <= Memi[v2+i-1]) break Memi[va+i-1] = Memi[v1+i-1] } if (i > ndim) break call amovl (Memi[va], Memi[vb], IM_MAXDIM) } # Close mask until it is needed again. call ic_mclose1 (image, nimages) n = dp - data if (n < 1) { call sfree (sp) call error (1, "Image section contains no pixels") } # Compute only statistics needed. if (domode || domedian) { call asrtd (Memd[data], Memd[data], n) mode = ic_moded (Memd[data], n) median = Memd[data+n/2-1] } if (domean) mean = asumd (Memd[data], n) / n call sfree (sp) end define NMIN 10 # Minimum number of pixels for mode calculation define ZRANGE 0.7 # Fraction of pixels about median to use define ZSTEP 0.01 # Step size for search for mode define ZBIN 0.1 # Bin size for mode. # IC_MODE -- Compute mode of an array. The mode is found by binning # with a bin size based on the data range over a fraction of the # pixels about the median and a bin step which may be smaller than the # bin size. If there are too few points the median is returned. # The input array must be sorted. double procedure ic_moded (a, n) double a[n] # Data array int n # Number of points int i, j, k, nmax real z1, z2, zstep, zbin double mode bool fp_equalr() begin if (n < NMIN) return (a[n/2]) # Compute the mode. The array must be sorted. Consider a # range of values about the median point. Use a bin size which # is ZBIN of the range. Step the bin limits in ZSTEP fraction of # the bin size. i = 1 + n * (1. - ZRANGE) / 2. j = 1 + n * (1. + ZRANGE) / 2. z1 = a[i] z2 = a[j] if (fp_equalr (z1, z2)) { mode = z1 return (mode) } zstep = ZSTEP * (z2 - z1) zbin = ZBIN * (z2 - z1) z1 = z1 - zstep k = i nmax = 0 repeat { z1 = z1 + zstep z2 = z1 + zbin for (; i < j && a[i] < z1; i=i+1) ; for (; k < j && a[k] < z2; k=k+1) ; if (k - i > nmax) { nmax = k - i mode = a[(i+k)/2] } } until (k >= j) return (mode) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/mkpkg000066400000000000000000000016411332166314300234450ustar00rootroot00000000000000# Make IMCOMBINE. $checkout libcombine.a mscbin$ $update libcombine.a $checkin libcombine.a mscbin$ $exit libcombine.a: icaclip.x ../icombine.com ../icombine.h icaverage.x ../icombine.com ../icombine.h iccclip.x ../icombine.com ../icombine.h icgdata.x ../icombine.com ../icombine.h icgrow.x ../icombine.com ../icombine.h icmedian.x ../icombine.com ../icombine.h icmm.x ../icombine.com ../icombine.h icnmodel.x ../icombine.com ../icombine.h icomb.x ../icombine.com ../icombine.h \ icpclip.x ../icombine.com ../icombine.h icquad.x ../icombine.com ../icombine.h icsclip.x ../icombine.com ../icombine.h icsigma.x ../icombine.com ../icombine.h icsort.x icstat.x ../icombine.com ../icombine.h xtimmap.x xtimmap.com ; mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/xtimmap.com000066400000000000000000000002751332166314300245720ustar00rootroot00000000000000int option int nopen int nopenpix int nalloc int last_flag int min_open int max_openim pointer ims common /xtimmapcom/ option, ims, nopen, nopenpix, nalloc, last_flag, min_open, max_openim mscred-5.05-2018.07.09/src/ccdred/src/combine/src/generic/xtimmap.x000066400000000000000000000676741332166314300243030ustar00rootroot00000000000000include include include include include # The following is for compiling under V2.11. define IM_BUFFRAC IM_BUFSIZE include define VERBOSE false # These routines maintain an arbitrary number of indexed "open" images which # must be READ_ONLY. The calling program may use the returned pointer for # header accesses but must call xt_opix before I/O. Subsequent calls to # xt_opix may invalidate the pointer. The xt_imunmap call will free memory. define MAX_OPENIM (LAST_FD-16) # Maximum images kept open define MAX_OPENPIX 45 # Maximum pixel files kept open define XT_SZIMNAME 299 # Size of IMNAME string define XT_LEN 179 # Structure length define XT_IMNAME Memc[P2C($1)] # Image name define XT_ARG Memi[$1+150] # IMMAP header argument define XT_IM Memi[$1+151] # IMIO pointer define XT_HDR Memi[$1+152] # Copy of IMIO pointer define XT_CLOSEFD Memi[$1+153] # Close FD? define XT_FLAG Memi[$1+154] # Flag define XT_BUFSIZE Memi[$1+155] # Buffer size define XT_BUF Memi[$1+156] # Data buffer define XT_BTYPE Memi[$1+157] # Data buffer type define XT_VS Memi[$1+157+$2] # Start vector (10) define XT_VE Memi[$1+167+$2] # End vector (10) # Options define XT_MAPUNMAP 1 # Map and unmap images. # XT_IMMAP -- Map an image and save it as an indexed open image. # The returned pointer may be used for header access but not I/O. # The indexed image is closed by xt_imunmap. pointer procedure xt_immap (imname, acmode, hdr_arg, index, retry) char imname[ARB] #I Image name int acmode #I Access mode int hdr_arg #I Header argument int index #I Save index int retry #I Retry counter pointer im #O Image pointer (returned) int i, envgeti() pointer xt, xt_opix() errchk xt_opix int first_time data first_time /YES/ include "xtimmap.com" begin if (acmode != READ_ONLY) call error (1, "XT_IMMAP: Only READ_ONLY allowed") # Set maximum number of open images based on retry. if (retry > 0) max_openim = min (1024, MAX_OPENIM) / retry else max_openim = MAX_OPENIM # Initialize once per process. if (first_time == YES) { iferr (option = envgeti ("imcombine_option")) option = 1 min_open = 1 nopen = 0 nopenpix = 0 nalloc = max_openim call calloc (ims, nalloc, TY_POINTER) first_time = NO } # Free image if needed. call xt_imunmap (NULL, index) # Allocate structure. if (index > nalloc) { i = nalloc nalloc = index + max_openim call realloc (ims, nalloc, TY_STRUCT) call amovki (NULL, Memi[ims+i], nalloc-i) } call calloc (xt, XT_LEN, TY_STRUCT) Memi[ims+index-1] = xt # Initialize. call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) XT_ARG(xt) = hdr_arg XT_IM(xt) = NULL XT_HDR(xt) = NULL # Open image. last_flag = 0 im = xt_opix (NULL, index, 0) # Make copy of IMIO pointer for header keyword access. call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) return (XT_HDR(xt)) end # XT_OPIX -- Open the image for I/O. # If the image has not been mapped return the default pointer. pointer procedure xt_opix (imdef, index, flag) int index #I index pointer imdef #I Default pointer int flag #I Flag int i, open(), imstati() pointer im, xt, xt1, immap() errchk open, immap, imunmap include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imdef) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_opix imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Return pointer for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (im) } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || flag == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next if (VERBOSE) { call eprintf ("%d: imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_opix immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im if (!IS_INDEFI(XT_BUFSIZE(xt))) call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) else XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (im) end # XT_CPIX -- Close image. procedure xt_cpix (index) int index #I index pointer xt errchk imunmap include "xtimmap.com" begin xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) return if (XT_IM(xt) != NULL) { if (VERBOSE) { call eprintf ("%d: xt_cpix imunmap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } call imunmap (XT_IM(xt)) nopen = nopen - 1 if (XT_CLOSEFD(xt) == NO) nopenpix = nopenpix - 1 } call mfree (XT_BUF(xt), XT_BTYPE(xt)) end # XT_IMSETI -- Set IMIO value. procedure xt_imseti (index, param, value) int index #I index int param #I IMSET parameter int value #I Value pointer xt bool streq() include "xtimmap.com" begin xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) { if (streq (param, "option")) option = value } else { if (streq (param, "bufsize")) { XT_BUFSIZE(xt) = value if (XT_IM(xt) != NULL) { call imseti (XT_IM(xt), IM_BUFFRAC, 0) call imseti (XT_IM(xt), IM_BUFSIZE, value) } } } end # XT_IMUNMAP -- Unmap indexed open image. # The header pointer is set to NULL to indicate the image has been closed. procedure xt_imunmap (im, index) int im #U IMIO header pointer int index #I index pointer xt errchk imunmap include "xtimmap.com" begin # Check for an indexed image. If it is not unmap the pointer # as a regular IMIO pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) { if (im != NULL) call imunmap (im) return } # Close indexed image. if (XT_IM(xt) != NULL) { if (VERBOSE) { call eprintf ("%d: xt_imunmap imunmap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } iferr (call imunmap (XT_IM(xt))) { XT_IM(xt) = NULL call erract (EA_WARN) } nopen = nopen - 1 if (XT_CLOSEFD(xt) == NO) nopenpix = nopenpix - 1 if (index == min_open) min_open = 1 } # Free any buffered memory. call mfree (XT_BUF(xt), XT_BTYPE(xt)) # Free header pointer. Note that if the supplied pointer is not # header pointer then it is not set to NULL. if (XT_HDR(xt) == im) im = NULL call mfree (XT_HDR(xt), TY_STRUCT) # Free save structure. call mfree (Memi[ims+index-1], TY_STRUCT) Memi[ims+index-1] = NULL end # XT_MINHDR -- Minimize header assuming keywords will not be accessed. procedure xt_minhdr (index) int index #I index pointer xt errchk realloc include "xtimmap.com" begin # Check for an indexed image. If it is not unmap the pointer # as a regular IMIO pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) return # Minimize header pointer. if (VERBOSE) { call eprintf ("%d: xt_minhdr %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } call realloc (XT_HDR(xt), IMU+1, TY_STRUCT) if (XT_IM(xt) != NULL) call realloc (XT_IM(xt), IMU+1, TY_STRUCT) end # XT_REINDEX -- Reindex open images. # This is used when some images are closed by xt_imunmap. It is up to # the calling program to reindex the header pointers and to subsequently # use the new index values. procedure xt_reindex () int old, new include "xtimmap.com" begin new = 0 do old = 0, nalloc-1 { if (Memi[ims+old] == NULL) next Memi[ims+new] = Memi[ims+old] new = new + 1 } do old = new, nalloc-1 Memi[ims+old] = NULL end # XT_IMGNL -- Return the next line for the indexed image. # Possibly unmap another image if too many files are open. # Buffer data when an image is unmmaped to minimize the mapping of images. # If the requested index has not been mapped use the default pointer. int procedure xt_imgnls (imdef, index, buf, v, flag) pointer imdef #I Default pointer int index #I index pointer buf #O Data buffer long v[ARB] #I Line vector int flag #I Flag (=output line) int i, j, nc, nl, open(), imgnls(), sizeof(), imloop() pointer im, xt, xt1, ptr, immap(), imggss() errchk open, immap, imgnls, imggss, imunmap long unit_v[IM_MAXDIM] data unit_v /IM_MAXDIM * 1/ include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imgnls (imdef, buf, v)) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Use IMIO for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (imgnls (im, buf, v)) } # If the image is not currently mapped use the stored header. im = XT_HDR(xt) # Check for EOF. i = IM_NDIM(im) if (v[i] > IM_LEN(im,i)) return (EOF) # Check for buffered data. if (XT_BUF(xt) != NULL) { if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { if (XT_BTYPE(xt) != TY_SHORT) call error (1, "Cannot mix data types") nc = IM_LEN(im,1) buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) XT_FLAG(xt) = flag if (i == 1) v[1] = nc + 1 else j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) return (nc) } } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || v[2] == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next # Buffer some number of lines. nl = XT_BUFSIZE(xt1) / sizeof (TY_SHORT) / IM_LEN(im,1) if (nl > 1) { nc = IM_LEN(im,1) call amovl (v, XT_VS(xt1,1), IM_MAXDIM) call amovl (v, XT_VE(xt1,1), IM_MAXDIM) XT_VS(xt1,1) = 1 XT_VE(xt1,1) = nc XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 XT_BTYPE(xt1) = TY_SHORT call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) ptr = imggss (im, XT_VS(xt1,1), XT_VE(xt1,1), IM_NDIM(im)) call amovs (Mems[ptr], Mems[XT_BUF(xt1)], nl*nc) } if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next if (XT_IM(xt1) == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_imgnl immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) call mfree (XT_BUF(xt), XT_BTYPE(xt)) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (imgnls (im, buf, v)) end # XT_IMGNL -- Return the next line for the indexed image. # Possibly unmap another image if too many files are open. # Buffer data when an image is unmmaped to minimize the mapping of images. # If the requested index has not been mapped use the default pointer. int procedure xt_imgnli (imdef, index, buf, v, flag) pointer imdef #I Default pointer int index #I index pointer buf #O Data buffer long v[ARB] #I Line vector int flag #I Flag (=output line) int i, j, nc, nl, open(), imgnli(), sizeof(), imloop() pointer im, xt, xt1, ptr, immap(), imggsi() errchk open, immap, imgnli, imggsi, imunmap long unit_v[IM_MAXDIM] data unit_v /IM_MAXDIM * 1/ include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imgnli (imdef, buf, v)) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Use IMIO for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (imgnli (im, buf, v)) } # If the image is not currently mapped use the stored header. im = XT_HDR(xt) # Check for EOF. i = IM_NDIM(im) if (v[i] > IM_LEN(im,i)) return (EOF) # Check for buffered data. if (XT_BUF(xt) != NULL) { if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { if (XT_BTYPE(xt) != TY_INT) call error (1, "Cannot mix data types") nc = IM_LEN(im,1) buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) XT_FLAG(xt) = flag if (i == 1) v[1] = nc + 1 else j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) return (nc) } } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || v[2] == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next # Buffer some number of lines. nl = XT_BUFSIZE(xt1) / sizeof (TY_INT) / IM_LEN(im,1) if (nl > 1) { nc = IM_LEN(im,1) call amovl (v, XT_VS(xt1,1), IM_MAXDIM) call amovl (v, XT_VE(xt1,1), IM_MAXDIM) XT_VS(xt1,1) = 1 XT_VE(xt1,1) = nc XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 XT_BTYPE(xt1) = TY_INT call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) ptr = imggsi (im, XT_VS(xt1,1), XT_VE(xt1,1), IM_NDIM(im)) call amovi (Memi[ptr], Memi[XT_BUF(xt1)], nl*nc) } if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next if (XT_IM(xt1) == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_imgnl immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) call mfree (XT_BUF(xt), XT_BTYPE(xt)) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (imgnli (im, buf, v)) end # XT_IMGNL -- Return the next line for the indexed image. # Possibly unmap another image if too many files are open. # Buffer data when an image is unmmaped to minimize the mapping of images. # If the requested index has not been mapped use the default pointer. int procedure xt_imgnlr (imdef, index, buf, v, flag) pointer imdef #I Default pointer int index #I index pointer buf #O Data buffer long v[ARB] #I Line vector int flag #I Flag (=output line) int i, j, nc, nl, open(), imgnlr(), sizeof(), imloop() pointer im, xt, xt1, ptr, immap(), imggsr() errchk open, immap, imgnlr, imggsr, imunmap long unit_v[IM_MAXDIM] data unit_v /IM_MAXDIM * 1/ include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imgnlr (imdef, buf, v)) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Use IMIO for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (imgnlr (im, buf, v)) } # If the image is not currently mapped use the stored header. im = XT_HDR(xt) # Check for EOF. i = IM_NDIM(im) if (v[i] > IM_LEN(im,i)) return (EOF) # Check for buffered data. if (XT_BUF(xt) != NULL) { if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { if (XT_BTYPE(xt) != TY_REAL) call error (1, "Cannot mix data types") nc = IM_LEN(im,1) buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) XT_FLAG(xt) = flag if (i == 1) v[1] = nc + 1 else j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) return (nc) } } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || v[2] == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next # Buffer some number of lines. nl = XT_BUFSIZE(xt1) / sizeof (TY_REAL) / IM_LEN(im,1) if (nl > 1) { nc = IM_LEN(im,1) call amovl (v, XT_VS(xt1,1), IM_MAXDIM) call amovl (v, XT_VE(xt1,1), IM_MAXDIM) XT_VS(xt1,1) = 1 XT_VE(xt1,1) = nc XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 XT_BTYPE(xt1) = TY_REAL call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) ptr = imggsr (im, XT_VS(xt1,1), XT_VE(xt1,1), IM_NDIM(im)) call amovr (Memr[ptr], Memr[XT_BUF(xt1)], nl*nc) } if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next if (XT_IM(xt1) == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_imgnl immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) call mfree (XT_BUF(xt), XT_BTYPE(xt)) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (imgnlr (im, buf, v)) end # XT_IMGNL -- Return the next line for the indexed image. # Possibly unmap another image if too many files are open. # Buffer data when an image is unmmaped to minimize the mapping of images. # If the requested index has not been mapped use the default pointer. int procedure xt_imgnld (imdef, index, buf, v, flag) pointer imdef #I Default pointer int index #I index pointer buf #O Data buffer long v[ARB] #I Line vector int flag #I Flag (=output line) int i, j, nc, nl, open(), imgnld(), sizeof(), imloop() pointer im, xt, xt1, ptr, immap(), imggsd() errchk open, immap, imgnld, imggsd, imunmap long unit_v[IM_MAXDIM] data unit_v /IM_MAXDIM * 1/ include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imgnld (imdef, buf, v)) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Use IMIO for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (imgnld (im, buf, v)) } # If the image is not currently mapped use the stored header. im = XT_HDR(xt) # Check for EOF. i = IM_NDIM(im) if (v[i] > IM_LEN(im,i)) return (EOF) # Check for buffered data. if (XT_BUF(xt) != NULL) { if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { if (XT_BTYPE(xt) != TY_DOUBLE) call error (1, "Cannot mix data types") nc = IM_LEN(im,1) buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) XT_FLAG(xt) = flag if (i == 1) v[1] = nc + 1 else j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) return (nc) } } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || v[2] == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next # Buffer some number of lines. nl = XT_BUFSIZE(xt1) / sizeof (TY_DOUBLE) / IM_LEN(im,1) if (nl > 1) { nc = IM_LEN(im,1) call amovl (v, XT_VS(xt1,1), IM_MAXDIM) call amovl (v, XT_VE(xt1,1), IM_MAXDIM) XT_VS(xt1,1) = 1 XT_VE(xt1,1) = nc XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 XT_BTYPE(xt1) = TY_DOUBLE call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) ptr = imggsd (im, XT_VS(xt1,1), XT_VE(xt1,1), IM_NDIM(im)) call amovd (Memd[ptr], Memd[XT_BUF(xt1)], nl*nc) } if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next if (XT_IM(xt1) == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_imgnl immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) call mfree (XT_BUF(xt), XT_BTYPE(xt)) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (imgnld (im, buf, v)) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icaclip.gx000066400000000000000000000301061332166314300227370ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" define MINCLIP 3 # Minimum number of images for this algorithm $for (sird) # IC_AAVSIGCLIP -- Reject pixels using an average sigma about the average # The average sigma is normalized by the expected poisson sigma. procedure ic_aavsigclip$t (d, m, n, scales, zeros, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line $if (datatype == sil) real average[npts] # Average $else PIXEL average[npts] # Average $endif int i, j, k, l, jj, n1, n2, nin, nk, maxkeep $if (datatype == sil) real d1, low, high, sum, a, s, s1, r, one data one /1.0/ $else PIXEL d1, low, high, sum, a, s, s1, r, one data one /1$f/ $endif pointer sp, sums, resid, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are insufficient pixels go on to the combining. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (sums, npts, TY_REAL) call salloc (resid, nimages+1, TY_REAL) # Since the unweighted average is computed here possibly skip combining if (dowts || combine != AVERAGE) docombine = true else docombine = false # Compute the unweighted average with the high and low rejected and # the poisson scaled average sigma. There must be at least three # pixels at each point to define the average and contributions to # the mean sigma. Corrections for differences in the image # scale factors are selected by the doscale1 flag. nin = max (0, n[1]) s = 0. n2 = 0 do i = 1, npts { k = i - 1 n1 = max (0, 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 = max (0, 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 (max (0, 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, sig, r, s, s1, one data one /1.0/ $else PIXEL med, low, high, sig, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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) sig = sqrt (s / (n2 - 1)) else { call sfree (sp) return } # Compute individual sigmas and iteratively clip. do i = 1, npts { k = i - 1 n1 = max (0, 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) && sig > 0.) { if (doscale1) { for (; nl <= nh; nl = nl + 1) { l = Memi[m[nl]+k] s1 = sig * 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 = sig * 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 = sig * sqrt (max (one, med)) for (; nl <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 # Recompute median if (n1 < n2) { if (n1 > 0) { n3 = nl + n1 / 2 if (mod (n1, 2) == 0) { low = Mem$t[d[n3-1]+k] high = Mem$t[d[n3]+k] med = (low + high) / 2. } else med = Mem$t[d[n3]+k] } else med = blank } } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mem$t[d[l]+k] = Mem$t[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Mem$t[d[l]+k] = Mem$t[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icaverage.gx000066400000000000000000000051301332166314300232600ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" include "../icmask.h" $for (sird) # IC_AVERAGE -- Compute the average (or summed) image line. # Options include a weighted average/sum. procedure ic_average$t (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? $if (datatype == sil) real average[npts] # Average (returned) $else PIXEL average[npts] # Average (returned) $endif int i, j, k, n1 real sumwt, wt $if (datatype == sil) real sum $else PIXEL sum $endif include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Mem$t[d[1]+k] * wt do j = 2, n[i] { wt = wts[Memi[m[j]+k]] sum = sum + Mem$t[d[j]+k] * wt } average[i] = sum } } else { do i = 1, npts { k = i - 1 sum = Mem$t[d[1]+k] do j = 2, n[i] sum = sum + Mem$t[d[j]+k] if (doaverage == YES) average[i] = sum / n[i] else average[i] = sum } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 wt = wts[Memi[m[1]+k]] sum = Mem$t[d[1]+k] * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + Mem$t[d[j]+k] * wt sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sum / sumwt else { sum = Mem$t[d[1]+k] do j = 2, n1 sum = sum + Mem$t[d[j]+k] average[i] = sum / n1 } } else average[i] = sum } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 sum = Mem$t[d[1]+k] do j = 2, n1 sum = sum + Mem$t[d[j]+k] if (doaverage == YES) average[i] = sum / n1 else average[i] = sum } else if (doblank == YES) average[i] = blank } } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/iccclip.gx000066400000000000000000000235701332166314300227500ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" define MINCLIP 2 # Mininum number of images for algorithm $for (sird) # IC_ACCDCLIP -- Reject pixels using CCD noise parameters about the average procedure ic_accdclip$t (d, m, n, scales, zeros, nm, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros real nm[3,nimages] # Noise model parameters int nimages # Number of images int npts # Number of output points per line $if (datatype == sil) real average[npts] # Average $else PIXEL average[npts] # Average $endif int i, j, k, l, jj, n1, n2, nin, nk, maxkeep $if (datatype == sil) real d1, low, high, sum, a, s, r, zero data zero /0.0/ $else PIXEL d1, low, high, sum, a, s, r, zero data zero /0$f/ $endif pointer sp, resid, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are no pixels go on to the combining. Since the unweighted # average is computed here possibly skip the combining later. # There must be at least max (1, nkeep) pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } else if (dowts || combine != AVERAGE) docombine = true else docombine = false call smark (sp) call salloc (resid, nimages+1, TY_REAL) # There must be at least two pixels for rejection. The initial # average is the low/high rejected average except in the case of # just two pixels. The rejections are iterated and the average # is recomputed. Corrections for scaling may be performed. # Depending on other flags the image IDs may also need to be adjusted. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mem$t[d[l]+k] = Mem$t[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Mem$t[d[l]+k] = Mem$t[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icemask.x000066400000000000000000000050371332166314300226050ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include # IC_EMASK -- Create exposure mask. procedure ic_emask (pm, v, id, nimages, n, wts, npts) pointer pm #I Pixel mask long v[ARB] #I Output vector pointer id[nimages] #I Image id pointers int nimages #I Number of images int n[npts] #I Number of good pixels real wts[npts] #I Weights int npts #I Number of output pixels per line int i, j, k, impnli() real exp pointer buf errchk impnli pointer exps # Exposure times pointer ev # IMIO coordinate vector real ezero # Integer to real zero real escale # Integer to real scale int einit # Initialization flag common /emask/ exps, ev, ezero, escale, einit begin # Write scaling factors to the header. if (einit == NO) { if (ezero != 0. || escale != 1.) { call imaddr (pm, "MASKZERO", ezero) call imaddr (pm, "MASKSCAL", escale) } einit = YES } call amovl (v, Meml[ev], IM_MAXDIM) i = impnli (pm, buf, Meml[ev]) call aclri (Memi[buf], npts) do i = 1, npts { exp = 0. do j = 1, n[i] { k = Memi[id[j]+i-1] if (wts[k] > 0.) exp = exp + Memr[exps+k-1] } Memi[buf] = nint((exp-ezero)/escale) buf = buf + 1 } end # IC_EINIT -- Initialize exposure mask. procedure ic_einit (in, nimages, key, default, maxval) int in[nimages] #I Image pointers int nimages #I Number of images char key[ARB] #I Exposure time keyword real default #I Default exposure time int maxval #I Maximum mask value int i real exp, emin, emax, efrac, imgetr() pointer exps # Exposure times pointer ev # IMIO coordinate vector real ezero # Integer to real zero real escale # Integer to real scale int einit # Initialization flag common /emask/ exps, ev, ezero, escale, einit begin call malloc (ev, IM_MAXDIM, TY_LONG) call malloc (exps, nimages, TY_REAL) emax = 0. emin = MAX_REAL efrac = 0 do i = 1, nimages { iferr (exp = imgetr (in[i], key)) exp = default exp = max (0., exp) emax = emax + exp if (exp > 0.) emin = min (exp, emin) efrac = max (abs(exp-nint(exp)), efrac) Memr[exps+i-1] = exp } # Set scaling. ezero = 0. escale = 1. if (emin < 1.) { escale = emin emin = emin / escale emax = emax / escale } else if (emin == MAX_REAL) emin = 0. if (efrac > 0.001 && emax-emin < 1000.) { escale = escale / 1000. emin = emin * 1000. emax = emax * 1000. } while (emax > maxval) { escale = escale * 10. emin = emin / 10. emax = emax / 10. } einit = NO end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icgdata.gx000066400000000000000000000205671332166314300227410ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" $for (sird) # IC_GDATA -- Get line of image and mask data and apply threshold and scaling. # Entirely empty lines are excluded. The data are compacted within the # input data buffers. If it is required, the connection to the original # image index is kept in the returned m data pointers. procedure ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, v1, v2) pointer in[nimages] # Input images pointer out[ARB] # Output images pointer dbuf[nimages] # Data buffers pointer d[nimages] # Data pointers pointer id[nimages] # ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Empty mask flags int offsets[nimages,ARB] # Image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors int nimages # Number of input images int npts # NUmber of output points per line long v1[ARB], v2[ARB] # Line vectors PIXEL temp int i, j, k, l, n1, n2, npix, nin, nout, ndim, nused, mtype, xt_imgnl$t() real a, b pointer buf, dp, ip, mp errchk xt_cpix, xt_imgnl$t PIXEL max_pixel $if (datatype == s) data max_pixel/MAX_SHORT/ $else $if (datatype == i) data max_pixel/MAX_INT/ $else $if (datatype == r) data max_pixel/MAX_REAL/ $else data max_pixel/MAX_DOUBLE/ $endif $endif $endif include "../icombine.com" begin # Get masks and return if there is no data call ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) if (dflag == D_NONE) { call aclri (n, npts) return } # Close images which are not needed. nout = IM_LEN(out[1],1) ndim = IM_NDIM(out[1]) if (!project && ndim < 3) { do i = 1, nimages { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) call xt_cpix (i) if (ndim > 1) { j = v1[2] - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } } } # Get data and fill data buffers. Correct for offsets if needed. do i = 1, nimages { if (lflag[i] == D_NONE) next if (dbuf[i] == NULL) { call amovl (v1, v2, IM_MAXDIM) if (project) v2[ndim+1] = i j = xt_imgnl$t (in[i], i, d[i], v2, v1[2]) } else { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) { lflag[i] = D_NONE next } k = 1 + j - offsets[i,1] v2[1] = k do l = 2, ndim { v2[l] = v1[l] - offsets[i,l] if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { lflag[i] = D_NONE break } } if (lflag[i] == D_NONE) next if (project) v2[ndim+1] = i l = xt_imgnl$t (in[i], i, buf, v2, v1[2]) call amov$t (Mem$t[buf+k-1], Mem$t[dbuf[i]+j], npix) d[i] = dbuf[i] } } # Set values to max_pixel if needed. if (mtype == M_NOVAL) { do i = 1, nimages { dp = d[i]; mp = m[i] if (lflag[i] == D_NONE || dp == NULL) next else if (lflag[i] == D_MIX) { do j = 1, npts { if (Memi[mp] == 1) Mem$t[dp] = max_pixel dp = dp + 1 mp = mp + 1 } } } } # Apply threshold if needed if (dothresh) { do i = 1, nimages { if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { a = Mem$t[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 lflag[i] = D_MIX dflag = D_MIX } dp = dp + 1 } # Check for completely empty lines if (lflag[i] == D_MIX) { lflag[i] = D_NONE mp = m[i] do j = 1, npts { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) { a = Mem$t[dp] if (a < lthresh || a > hthresh) { if (mtype == M_NOVAL) Memi[m[i]+j-1] = 2 else Memi[m[i]+j-1] = 1 dflag = D_MIX } } dp = dp + 1 mp = mp + 1 } # Check for completely empty lines lflag[i] = D_NONE mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { lflag[i] = D_MIX break } mp = mp + 1 } } } } # Apply scaling (avoiding masked pixels which might overflow?) if (doscale) { if (dflag == D_ALL) { do i = 1, nimages { dp = d[i] a = scales[i] b = -zeros[i] do j = 1, npts { Mem$t[dp] = Mem$t[dp] / a + b dp = dp + 1 } } } else if (dflag == D_MIX) { do i = 1, nimages { a = scales[i] b = -zeros[i] if (lflag[i] == D_ALL) { dp = d[i] do j = 1, npts { Mem$t[dp] = Mem$t[dp] / a + b dp = dp + 1 } } else if (lflag[i] == D_MIX) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] != 1) 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 } } do i = nused+1, nimages d[i] = NULL if (nused == 0) dflag = D_NONE } # Compact data to remove bad pixels # Keep track of the image indices if needed # If growing mark the end of the included image indices with zero if (dflag == D_ALL) { call amovki (nused, n, npts) if (keepids) do i = 1, nimages call amovki (i, Memi[id[i]], npts) } else if (dflag == D_NONE) call aclri (n, npts) else { call aclri (n, npts) if (keepids) { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 ip = id[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { Memi[ip] = l if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Mem$t[d[k]+j-1] Mem$t[d[k]+j-1] = Mem$t[dp] Mem$t[dp] = temp Memi[ip] = Memi[id[k]+j-1] Memi[id[k]+j-1] = l Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 ip = ip + 1 mp = mp + 1 } } if (grow >= 1.) { do j = 1, npts { do i = n[j]+1, nused Memi[id[i]+j-1] = 0 } } } else { do i = 1, nused { l = lflag[i] nin = IM_LEN(in[l],1) j = max (0, offsets[l,1]) k = min (nout, nin + offsets[l,1]) npix = k - j n1 = 1 + j n2 = n1 + npix - 1 dp = d[i] + n1 - 1 mp = m[i] + n1 - 1 do j = n1, n2 { if (Memi[mp] == 0) { n[j] = n[j] + 1 k = n[j] if (k < i) { temp = Mem$t[d[k]+j-1] Mem$t[d[k]+j-1] = Mem$t[dp] Mem$t[dp] = temp Memi[mp] = Memi[m[k]+j-1] Memi[m[k]+j-1] = 0 } } dp = dp + 1 mp = mp + 1 } } } } # Sort the pixels and IDs if needed if (mclip) { call malloc (dp, nused, TY_PIXEL) if (keepids) { call malloc (ip, nused, 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) } # If no good pixels set the number of usable values as -n and # shift them to lower values. if (mtype == M_NOVAL) { if (keepids) { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 ip = id[i] + j - 1 if (Mem$t[dp] < max_pixel) { 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] = Memi[ip] } } } } } else { do j = 1, npts { if (n[j] > 0) next n[j] = 0 do i = 1, nused { dp = d[i] + j - 1 if (Mem$t[dp] < max_pixel) { n[j] = n[j] - 1 k = -n[j] if (k < i) Mem$t[d[k]+j-1] = Mem$t[dp] } } } } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icgrow.gx000066400000000000000000000054151332166314300226320ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" # IC_GROW -- Mark neigbors of rejected pixels. # The rejected pixels (original plus grown) are saved in pixel masks. procedure ic_grow (out, v, m, n, buf, nimages, npts, pms) pointer out # Output image pointer long v[ARB] # Output vector pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[npts,nimages] # Working buffer int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k, l, line, nl, rop, igrow, nset, ncompress, or() real grow2, i2 pointer mp, pm, pm_newmask() errchk pm_newmask() include "../icombine.com" begin if (dflag == D_NONE || grow == 0.) return line = v[2] nl = IM_LEN(out,2) rop = or (PIX_SRC, PIX_DST) igrow = grow grow2 = grow**2 do l = 0, igrow { i2 = grow2 - l * l call aclri (buf, npts*nimages) nset = 0 do j = 1, npts { do k = n[j]+1, nimages { mp = Memi[m[k]+j-1] if (mp == 0) next do i = 0, igrow { if (i**2 > i2) next if (j > i) buf[j-i,mp] = 1 if (j+i <= npts) buf[j+i,mp] = 1 nset = nset + 1 } } } if (nset == 0) return if (pms == NULL) { call malloc (pms, nimages, TY_POINTER) do i = 1, nimages Memi[pms+i-1] = pm_newmask (out, 1) ncompress = 0 } do i = 1, nimages { pm = Memi[pms+i-1] v[2] = line - l if (v[2] > 0) call pmplpi (pm, v, buf[1,i], 1, npts, rop) if (l > 0) { v[2] = line + l if (v[2] <= nl) call pmplpi (pm, v, buf[1,i], 1, npts, rop) } } } v[2] = line if (ncompress > 10) { do i = 1, nimages { pm = Memi[pms+i-1] call pm_compress (pm) } ncompress = 0 } else ncompress = ncompress + 1 end $for (sird) # IC_GROW$T -- Reject pixels. procedure ic_grow$t (v, d, m, n, buf, nimages, npts, pms) long v[ARB] # Output vector pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[ARB] # Number of good pixels int buf[ARB] # Buffer of npts int nimages # Number of images int npts # Number of output points per line pointer pms # Pointer to array of pixel masks int i, j, k pointer pm bool pl_linenotempty() include "../icombine.com" begin do k = 1, nimages { pm = Memi[pms+k-1] if (!pl_linenotempty (pm, v)) next call pmglpi (pm, v, buf, 1, npts, PIX_SRC) do i = 1, npts { if (buf[i] == 0) next for (j = 1; j <= n[i]; j = j + 1) { if (Memi[m[j]+i-1] == k) { if (j < n[i]) { Mem$t[d[j]+i-1] = Mem$t[d[n[i]]+i-1] Memi[m[j]+i-1] = Memi[m[n[i]]+i-1] } n[i] = n[i] - 1 dflag = D_MIX break } } } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icgscale.x000066400000000000000000000043111332166314300227350ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "icombine.h" # IC_GSCALE -- Get scale values as directed by CL parameter. # Only those values which are INDEF are changed. # The values can be one of those in the dictionary, from a file specified # with a @ prefix, or from an image header keyword specified by a ! prefix. int procedure ic_gscale (param, name, dic, in, exptime, values, nimages) char param[ARB] #I CL parameter name char name[SZ_FNAME] #O Parameter value char dic[ARB] #I Dictionary string pointer in[nimages] #I IMIO pointers real exptime[nimages] #I Exposure times real values[nimages] #O Values int nimages #I Number of images int type #O Type of value int fd, i, nowhite(), open(), fscan(), nscan(), strdic() real rval, imgetr() pointer errstr errchk open, imgetr include "icombine.com" begin call clgstr (param, name, SZ_FNAME) if (nowhite (name, name, SZ_FNAME) == 0) type = S_NONE else if (name[1] == '@') { type = S_FILE do i = 1, nimages if (IS_INDEFR(values[i])) break if (i <= nimages) { fd = open (name[2], READ_ONLY, TEXT_FILE) i = 0 while (fscan (fd) != EOF) { call gargr (rval) if (nscan() != 1) next if (i == nimages) { call eprintf ( "Warning: Ignoring additional %s values in %s\n") call pargstr (param) call pargstr (name[2]) break } i = i + 1 if (IS_INDEFR(values[i])) values[i] = rval } call close (fd) if (i < nimages) { call salloc (errstr, SZ_LINE, TY_CHAR) call sprintf (errstr, SZ_FNAME, "Insufficient %s values in %s") call pargstr (param) call pargstr (name[2]) call error (1, errstr) } } } else if (name[1] == '!') { type = S_KEYWORD do i = 1, nimages { if (IS_INDEFR(values[i])) values[i] = imgetr (in[i], name[2]) if (project) { call amovkr (values, values, nimages) break } } } else { type = strdic (name, name, SZ_FNAME, dic) if (type == 0) call error (1, "Unknown scale, zero, or weight type") if (type==S_EXPOSURE) do i = 1, nimages if (IS_INDEFR(values[i])) values[i] = max (0.001, exptime[i]) } return (type) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/ichdr.x000066400000000000000000000035221332166314300222570ustar00rootroot00000000000000include # IC_HDR -- Set output header. procedure ic_hdr (in, out, nimages) pointer in[nimages] #I Input images pointer out[ARB] #I Output images int nimages #I Number of images int i, j, imgnfn(), nowhite(), strldxs() pointer sp, inkey, key, str, list, imofnlu() bool streq() begin call smark (sp) call salloc (inkey, SZ_FNAME, TY_CHAR) call salloc (key, SZ_FNAME, TY_CHAR) call salloc (str, SZ_FNAME, TY_CHAR) call clgstr ("imcmb", Memc[inkey], SZ_FNAME) i = nowhite (Memc[inkey], Memc[inkey], SZ_FNAME) if (i > 0 && streq (Memc[inkey], "$I")) { # Set new PROCID. call xt_procid (out) # Set input PROCIDs. if (nimages < 100) { list = imofnlu (out, "PROCID[0-9][0-9]") while (imgnfn (list, Memc[key], SZ_LINE) != EOF) call imdelf (out, Memc[key]) call imcfnl (list) do i = 1, nimages { call sprintf (Memc[key], 8, "PROCID%02d") call pargi (i) iferr (call imgstr (in[i], "PROCID", Memc[str], SZ_LINE)) { iferr (call imgstr (in[i], "OBSID", Memc[str], SZ_LINE)) Memc[str] = EOS } if (Memc[str] != EOS) call imastr (out, Memc[key], Memc[str]) } } } if (i > 0 && nimages < 1000) { list = imofnlu (out, "IMCMB[0-9][0-9][0-9]") while (imgnfn (list, Memc[key], SZ_LINE) != EOF) call imdelf (out, Memc[key]) call imcfnl (list) do i = 1, nimages { if (streq (Memc[inkey], "$I")) { call imstats (in[i], IM_IMAGENAME, Memc[str], SZ_LINE) j = strldxs ("/$", Memc[str]) if (j > 0) call strcpy (Memc[str+j], Memc[str], SZ_LINE) } else { iferr (call imgstr (in[i], Memc[inkey], Memc[str], SZ_LINE)) Memc[str] = EOS } if (Memc[str] == EOS) next call sprintf (Memc[key], SZ_LINE, "IMCMB%03d") call pargi (i) call imastr (out, Memc[key], Memc[str]) } } call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icimstack.x000066400000000000000000000125721332166314300231420ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include # IC_IMSTACK -- Stack images into a single image of higher dimension. procedure ic_imstack (list, output, mask) int list #I List of images char output[ARB] #I Name of output image char mask[ARB] #I Name of output mask int i, j, npix long line_in[IM_MAXDIM], line_out[IM_MAXDIM], line_outbpm[IM_MAXDIM] pointer sp, input, bpmname, key, in, out, inbpm, outbpm, buf_in, buf_out, ptr int imtgetim(), imtlen(), errget() int imgnls(), imgnli(), imgnll(), imgnlr(), imgnld(), imgnlx() int impnls(), impnli(), impnll(), impnlr(), impnld(), impnlx() pointer immap(), pm_newmask() errchk immap errchk imgnls, imgnli, imgnll, imgnlr, imgnld, imgnlx errchk impnls, impnli, impnll, impnlr, impnld, impnlx begin call smark (sp) call salloc (input, SZ_FNAME, TY_CHAR) call salloc (bpmname, SZ_FNAME, TY_CHAR) call salloc (key, SZ_FNAME, TY_CHAR) iferr { # Add each input image to the output image. out = NULL; outbpm = NULL i = 0 while (imtgetim (list, Memc[input], SZ_FNAME) != EOF) { i = i + 1 in = NULL; inbpm = NULL ptr = immap (Memc[input], READ_ONLY, 0) in = ptr # For the first input image map the output image as a copy # and increment the dimension. Set the output line counter. if (i == 1) { ptr = immap (output, NEW_COPY, in) out = ptr IM_NDIM(out) = IM_NDIM(out) + 1 IM_LEN(out, IM_NDIM(out)) = imtlen (list) npix = IM_LEN(out, 1) call amovkl (long(1), line_out, IM_MAXDIM) if (mask[1] != EOS) { ptr = immap (mask, NEW_COPY, in) outbpm = ptr IM_NDIM(outbpm) = IM_NDIM(outbpm) + 1 IM_LEN(outbpm, IM_NDIM(outbpm)) = imtlen (list) call amovkl (long(1), line_outbpm, IM_MAXDIM) } } # Check next input image for consistency with the output image. if (IM_NDIM(in) != IM_NDIM(out) - 1) call error (0, "Input images not consistent") do j = 1, IM_NDIM(in) { if (IM_LEN(in, j) != IM_LEN(out, j)) call error (0, "Input images not consistent") } call sprintf (Memc[key], SZ_FNAME, "stck%04d") call pargi (i) call imastr (out, Memc[key], Memc[input]) # Copy the input lines from the image to the next lines of # the output image. Switch on the output data type to optimize # IMIO. call amovkl (long(1), line_in, IM_MAXDIM) switch (IM_PIXTYPE (out)) { case TY_SHORT: while (imgnls (in, buf_in, line_in) != EOF) { if (impnls (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovs (Mems[buf_in], Mems[buf_out], npix) } case TY_INT: while (imgnli (in, buf_in, line_in) != EOF) { if (impnli (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovi (Memi[buf_in], Memi[buf_out], npix) } case TY_USHORT, TY_LONG: while (imgnll (in, buf_in, line_in) != EOF) { if (impnll (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovl (Meml[buf_in], Meml[buf_out], npix) } case TY_REAL: while (imgnlr (in, buf_in, line_in) != EOF) { if (impnlr (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovr (Memr[buf_in], Memr[buf_out], npix) } case TY_DOUBLE: while (imgnld (in, buf_in, line_in) != EOF) { if (impnld (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovd (Memd[buf_in], Memd[buf_out], npix) } case TY_COMPLEX: while (imgnlx (in, buf_in, line_in) != EOF) { if (impnlx (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovx (Memx[buf_in], Memx[buf_out], npix) } default: while (imgnlr (in, buf_in, line_in) != EOF) { if (impnlr (out, buf_out, line_out) == EOF) call error (0, "Error writing output image") call amovr (Memr[buf_in], Memr[buf_out], npix) } } # Copy mask. if (mask[1] != EOS) { iferr (call imgstr (in, "bpm", Memc[bpmname], SZ_FNAME)) { Memc[bpmname] = EOS ptr = pm_newmask (in, 27) } else ptr = immap (Memc[bpmname], READ_ONLY, 0) inbpm = ptr if (IM_NDIM(inbpm) != IM_NDIM(outbpm) - 1) call error (0, "Input images not consistent") do j = 1, IM_NDIM(inbpm) { if (IM_LEN(inbpm, j) != IM_LEN(outbpm, j)) call error (0, "Masks not consistent") } call amovkl (long(1), line_in, IM_MAXDIM) while (imgnli (inbpm, buf_in, line_in) != EOF) { if (impnli (outbpm, buf_out, line_outbpm) == EOF) call error (0, "Error writing output mask") call amovi (Memi[buf_in], Memi[buf_out], npix) } call sprintf (Memc[key], SZ_FNAME, "bpm%04d") call pargi (i) call imastr (out, Memc[key], Memc[bpmname]) call imunmap (inbpm) } call imunmap (in) } } then { i = errget (Memc[key], SZ_FNAME) call erract (EA_WARN) if (outbpm != NULL) { call imunmap (outbpm) iferr (call imdelete (mask)) ; } if (out != NULL) { call imunmap (out) iferr (call imdelete (output)) ; } if (inbpm != NULL) call imunmap (inbpm) if (in != NULL) call imunmap (in) call sfree (sp) call error (i, "Can't make temporary stack images") } # Finish up. if (outbpm != NULL) { call imunmap (outbpm) call imastr (out, "bpm", mask) } call imunmap (out) call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/iclog.x000066400000000000000000000263351332166314300222720ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include "icombine.h" include "icmask.h" # IC_LOG -- Output log information is a log file has been specfied. procedure ic_log (in, out, ncombine, exptime, sname, zname, wname, mode, median, mean, scales, zeros, wts, offsets, nimages, dozero, nout) pointer in[nimages] # Input images pointer out[ARB] # Output images int ncombine[nimages] # Number of previous combined images real exptime[nimages] # Exposure times char sname[ARB] # Scale name char zname[ARB] # Zero name char wname[ARB] # Weight name real mode[nimages] # Modes real median[nimages] # Medians real mean[nimages] # Means real scales[nimages] # Scale factors real zeros[nimages] # Zero or sky levels real wts[nimages] # Weights int offsets[nimages,ARB] # Image offsets int nimages # Number of images bool dozero # Zero flag int nout # Number of images combined in output int i, j, stack, ctor() real rval, imgetr() long clktime() bool prncombine, prexptime, prmode, prmedian, prmean, prmask bool prrdn, prgain, prsn pointer sp, fname, bpname, key errchk imgetr include "icombine.com" begin if (logfd == NULL) return call smark (sp) call salloc (fname, SZ_LINE, TY_CHAR) call salloc (bpname, SZ_LINE, TY_CHAR) stack = NO if (project) { ifnoerr (call imgstr (in[1], "stck0001", Memc[fname], SZ_LINE)) stack = YES } if (stack == YES) call salloc (key, SZ_FNAME, TY_CHAR) # Time stamp the log and print parameter information. call cnvdate (clktime(0), Memc[fname], SZ_LINE) call fprintf (logfd, "\n%s: IMCOMBINE\n") call pargstr (Memc[fname]) switch (combine) { case AVERAGE: call fprintf (logfd, " combine = average, ") case MEDIAN: call fprintf (logfd, " combine = median, ") case SUM: call fprintf (logfd, " combine = sum, ") } call fprintf (logfd, "scale = %s, zero = %s, weight = %s\n") call pargstr (sname) call pargstr (zname) call pargstr (wname) if (combine == NMODEL && reject!=CCDCLIP && reject!=CRREJECT) { call fprintf (logfd, " rdnoise = %s, gain = %s, snoise = %s\n") call pargstr (Memc[rdnoise]) call pargstr (Memc[gain]) call pargstr (Memc[snoise]) } switch (reject) { case MINMAX: call fprintf (logfd, " reject = minmax, nlow = %d, nhigh = %d\n") call pargi (nint (flow * nimages)) call pargi (nint (fhigh * nimages)) case CCDCLIP: call fprintf (logfd, " reject = ccdclip, mclip = %b, nkeep = %d\n") call pargb (mclip) call pargi (nkeep) call fprintf (logfd, " rdnoise = %s, gain = %s, snoise = %s, sigma = %g, hsigma = %g\n") call pargstr (Memc[rdnoise]) call pargstr (Memc[gain]) call pargstr (Memc[snoise]) call pargr (lsigma) call pargr (hsigma) case CRREJECT: call fprintf (logfd, " reject = crreject, mclip = %b, nkeep = %d\n") call pargb (mclip) call pargi (nkeep) call fprintf (logfd, " rdnoise = %s, gain = %s, snoise = %s, hsigma = %g\n") call pargstr (Memc[rdnoise]) call pargstr (Memc[gain]) call pargstr (Memc[snoise]) call pargr (hsigma) case PCLIP: call fprintf (logfd, " reject = pclip, nkeep = %d\n") call pargi (nkeep) call fprintf (logfd, " pclip = %g, lsigma = %g, hsigma = %g\n") call pargr (pclip) call pargr (lsigma) call pargr (hsigma) case SIGCLIP: call fprintf (logfd, " reject = sigclip, mclip = %b, nkeep = %d\n") call pargb (mclip) call pargi (nkeep) call fprintf (logfd, " lsigma = %g, hsigma = %g\n") call pargr (lsigma) call pargr (hsigma) case AVSIGCLIP: call fprintf (logfd, " reject = avsigclip, mclip = %b, nkeep = %d\n") call pargb (mclip) call pargi (nkeep) call fprintf (logfd, " lsigma = %g, hsigma = %g\n") call pargr (lsigma) call pargr (hsigma) } if (reject != NONE && grow >= 1.) { call fprintf (logfd, " grow = %g\n") call pargr (grow) } if (dothresh) { if (lthresh > -MAX_REAL && hthresh < MAX_REAL) { call fprintf (logfd, " lthreshold = %g, hthreshold = %g\n") call pargr (lthresh) call pargr (hthresh) } else if (lthresh > -MAX_REAL) { call fprintf (logfd, " lthreshold = %g\n") call pargr (lthresh) } else { call fprintf (logfd, " hthreshold = %g\n") call pargr (hthresh) } } call fprintf (logfd, " blank = %g\n") call pargr (blank) if (Memc[statsec] != EOS) { call fprintf (logfd, " statsec = %s\n") call pargstr (Memc[fname]) } if (ICM_TYPE(icm) != M_NONE) { switch (ICM_TYPE(icm)) { case M_BOOLEAN, M_GOODVAL: call fprintf (logfd, " masktype = goodval, maskval = %d\n") call pargi (ICM_VALUE(icm)) case M_BADVAL: call fprintf (logfd, " masktype = badval, maskval = %d\n") call pargi (ICM_VALUE(icm)) case M_NOVAL: call fprintf (logfd, " masktype = noval, 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)) case M_LTVAL: call fprintf (logfd, " masktype = goodval, maskval < %d\n") call pargi (ICM_VALUE(icm)) case M_GTVAL: call fprintf (logfd, " masktype = goodval, maskval > %d\n") call pargi (ICM_VALUE(icm)) } } # Print information pertaining to individual images as a set of # columns with the image name being the first column. Determine # what information is relevant and print the appropriate header. prncombine = false prexptime = false prmode = false prmedian = false prmean = false prmask = false prrdn = false prgain = false prsn = false do i = 1, nimages { if (ncombine[i] != ncombine[1]) prncombine = true if (exptime[i] != exptime[1]) prexptime = true if (mode[i] != mode[1]) prmode = true if (median[i] != median[1]) prmedian = true if (mean[i] != mean[1]) prmean = true if (ICM_TYPE(icm) != M_NONE) { if (project) bpname = Memi[ICM_NAMES(icm)] else bpname = Memi[ICM_NAMES(icm)+i-1] if (Memc[bpname] != EOS) prmask = true } if (combine == NMODEL || 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) { if (stack == YES) { call sprintf (Memc[key], SZ_FNAME, "bpm%04d") call pargi (i) ifnoerr (call imgstr (in[i], Memc[key], Memc[fname], SZ_LINE)) { call fprintf (logfd, " %s") call pargstr (Memc[fname]) } else { call fprintf (logfd, " %s") call pargstr (Memc[bpname]) } } else if (ICM_TYPE(icm) != M_NONE) { if (project) bpname = Memi[ICM_NAMES(icm)] else bpname = Memi[ICM_NAMES(icm)+i-1] if (Memc[bpname] != EOS) { call fprintf (logfd, " %s") call pargstr (Memc[bpname]) } } } call fprintf (logfd, "\n") } # Log information about the output images. call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_LINE) call fprintf (logfd, "\n Output image = %s, ncombine = %d") call pargstr (Memc[fname]) call pargi (nout) call fprintf (logfd, "\n") if (out[2] != NULL) { call imstats (out[2], IM_IMAGENAME, Memc[fname], SZ_LINE) call fprintf (logfd, " Bad pixel mask = %s\n") call pargstr (Memc[fname]) } if (out[4] != NULL) { call imstats (out[4], IM_IMAGENAME, Memc[fname], SZ_LINE) call fprintf (logfd, " Rejection mask = %s\n") call pargstr (Memc[fname]) } if (out[5] != NULL) { call imstats (out[5], IM_IMAGENAME, Memc[fname], SZ_LINE) call fprintf (logfd, " Number rejected mask = %s\n") call pargstr (Memc[fname]) } if (out[6] != NULL) { call imstats (out[6], IM_IMAGENAME, Memc[fname], SZ_LINE) call fprintf (logfd, " Exposure mask = %s\n") call pargstr (Memc[fname]) } if (out[3] != NULL) { call imstats (out[3], IM_IMAGENAME, Memc[fname], SZ_LINE) call fprintf (logfd, " Sigma image = %s\n") call pargstr (Memc[fname]) } call flush (logfd) call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icmask.com000066400000000000000000000003541332166314300227440ustar00rootroot00000000000000# 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icmask.h000066400000000000000000000007331332166314300224160ustar00rootroot00000000000000# ICMASK -- Data structure for IMCOMBINE mask interface. define ICM_LEN 6 # Structure length define ICM_TYPE Memi[$1] # Mask type define ICM_VALUE Memi[$1+1] # Mask value define ICM_IOMODE Memi[$1+2] # I/O mode define ICM_BUFS Memi[$1+3] # Pointer to data line buffers define ICM_PMS Memi[$1+4] # Pointer to array of PMIO pointers define ICM_NAMES Memi[$1+5] # Pointer to array of mask names define ICM_OPEN 0 # Keep masks open define ICM_CLOSED 1 # Keep masks closed mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icmask.x000066400000000000000000000422471332166314300224440ustar00rootroot00000000000000include include include include "icombine.h" include "icmask.h" # IC_MASK -- ICOMBINE mask interface # # IC_MOPEN -- Initialize mask interface # IC_MCLOSE -- Close the mask interface # IC_MGET -- Get lines of mask pixels for all the images # IC_MGET1 -- Get a line of mask pixels for the specified image # IC_MCLOSE1-- Close a mask for the specified image index # IC_MOPEN -- Initialize mask interface. procedure ic_mopen (in, out, nimages, offsets, iomode) pointer in[nimages] #I Input images pointer out[ARB] #I Output images int nimages #I Number of images int offsets[nimages,ARB] #I Offsets to output image int iomode #I I/O mode int mtype # Mask type int mvalue # Mask value pointer bufs # Pointer to data line buffers pointer pms # Pointer to array of PMIO pointers pointer names # Pointer to array of string pointers int i, j, k, nin, nout, npix, npms, nscan(), strdic(), ctor() real rval pointer sp, str, key, fname, title, image, pm, pm_open() bool invert, pm_empty() errchk calloc, pm_open, ic_pmload include "icombine.com" begin icm = NULL if (IM_NDIM(out[1]) == 0) return call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) call salloc (key, SZ_FNAME, TY_CHAR) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (title, SZ_FNAME, TY_CHAR) call salloc (image, SZ_FNAME, TY_CHAR) # Determine the mask parameters and allocate memory. # The mask buffers are initialize to all excluded so that # output points outside the input data are always excluded # and don't need to be set on a line-by-line basis. mtype = M_NONE call clgstr ("masktype", Memc[str], SZ_LINE) call sscan (Memc[str]) call gargwrd (Memc[title], SZ_FNAME) call gargwrd (Memc[key], SZ_FNAME) i = nscan() if (i > 0) { if (Memc[title] == '!') { if (i == 1) mtype = M_GOODVAL else mtype = strdic (Memc[key], Memc[key], SZ_FNAME, MASKTYPES) call strcpy (Memc[title+1], Memc[key], SZ_FNAME) } else { mtype = strdic (Memc[title], Memc[title], SZ_FNAME, MASKTYPES) call strcpy ("BPM", Memc[key], SZ_FNAME) } if (mtype == 0) { call sprintf (Memc[title], SZ_FNAME, "Invalid or ambiguous masktype (%s)") call pargstr (Memc[str]) call error (1, Memc[title]) } } npix = IM_LEN(out[1],1) call calloc (pms, nimages, TY_POINTER) call calloc (bufs, nimages, TY_POINTER) call calloc (names, 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. # Eventually we want to allow general expressions. For now we only # allow a special '<' or '>' operator. call clgstr ("maskvalue", Memc[title], SZ_FNAME) i = 1 if (Memc[title] == '<') { mtype = M_LTVAL i = i + 1 } else if (Memc[title] == '>') { mtype = M_GTVAL i = i + 1 } if (ctor (Memc[title], i, rval) == 0) call error (1, "Bad mask value") mvalue = rval if (mvalue < 0) call error (1, "Bad mask value") else if (mvalue == 0 && mtype == M_NOVAL) call error (1, "maskvalue cannot be 0 for masktype of 'novalue'") if (mtype == 0) mtype = M_NONE else if (mtype == M_BADBITS && mvalue == 0) mtype = M_NONE else if (mvalue == 0 && (mtype == M_GOODVAL || mtype == M_GOODBITS)) mtype = M_BOOLEAN else if ((mtype == M_BADVAL && mvalue == 0) || (mtype == M_GOODVAL && mvalue != 0) || (mtype == M_GOODBITS && mvalue == 0)) invert = true else invert = false # If mask images are to be used, get the mask name from the image # header and open it saving the descriptor in the pms array. # Empty masks (all good) are treated as if there was no mask image. nout = IM_LEN(out[1],1) npms = 0 do i = 1, nimages { if (mtype != M_NONE) { call malloc (Memi[names+i-1], SZ_FNAME, TY_CHAR) fname = Memi[names+i-1] ifnoerr (call imgstr (in[i],Memc[key],Memc[fname],SZ_FNAME)) { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j if (npix < 1) Memc[fname] = EOS else { pm = pm_open (NULL) call ic_pmload (in[i], pm, Memc[fname], SZ_FNAME) call pm_seti (pm, P_REFIM, in[i]) if (pm_empty (pm) && !invert) Memc[fname] = EOS else { if (project) npms = nimages else npms = npms + 1 } call pm_close (pm) } if (project) break } else Memc[fname] = EOS } } # If no mask images are found and the mask parameters imply that # good values are 0 then use the special case of no masks. if (npms == 0) { if (!invert) mtype = M_NONE } # Set up mask structure. call calloc (icm, ICM_LEN, TY_STRUCT) ICM_TYPE(icm) = mtype ICM_VALUE(icm) = mvalue ICM_IOMODE(icm) = iomode ICM_BUFS(icm) = bufs ICM_PMS(icm) = pms ICM_NAMES(icm) = names call sfree (sp) end # IC_PMLOAD -- Find and load a mask. # This is more complicated because we want to allow a mask name specified # without a path to be found either in the current directory or in the # directory of the image. procedure ic_pmload (im, pm, fname, maxchar) pointer im #I Image pointer to be associated with mask pointer pm #O Mask pointer to be returned char fname[ARB] #U Mask name int maxchar #I Max size of mask name bool match pointer sp, str, imname, yt_pmload() int i, fnldir(), stridxs(), envfind() begin call smark (sp) call salloc (str, SZ_PATHNAME, TY_CHAR) # First check if the specified file can be loaded. match = (envfind ("pmatch", Memc[str], SZ_PATHNAME) > 0) if (match) { call pm_close (pm) iferr (pm = yt_pmload (fname,im,"logical",Memc[str],SZ_PATHNAME)) pm = NULL if (pm != NULL) return } else { ifnoerr (call pm_loadf (pm, fname, Memc[str], SZ_PATHNAME)) return ifnoerr (call pm_loadim (pm, fname, Memc[str], SZ_PATHNAME)) return } # Check if the file has a path in which case we return an error. # Must deal with possible [] which is a VMS directory delimiter. call strcpy (fname, Memc[str], SZ_PATHNAME) i = stridxs ("[", Memc[str]) if (i > 0) Memc[str+i-1] = EOS if (fnldir (Memc[str], Memc[str], SZ_PATHNAME) > 0) { call sprintf (Memc[str], SZ_PATHNAME, "Bad pixel mask not found (%s)") call pargstr (fname) call error (1, Memc[str]) } # Check if the image has a path. If not return an error. call salloc (imname, SZ_PATHNAME, TY_CHAR) call imstats (im, IM_IMAGENAME, Memc[imname], SZ_PATHNAME) if (fnldir (Memc[imname], Memc[str], SZ_PATHNAME) == 0) { call sprintf (Memc[str], SZ_PATHNAME, "Bad pixel mask not found (%s)") call pargstr (fname) call error (1, Memc[str]) } # Try using the image path for the mask file. call strcat (fname, Memc[str], SZ_PATHNAME) if (match) { iferr (pm = yt_pmload (Memc[imname], im, "logical", Memc[str], SZ_PATHNAME)) pm = NULL if (pm != NULL) { call strcpy (Memc[str], fname, maxchar) return } } else { ifnoerr (call pm_loadf (pm, Memc[str], Memc[imname], SZ_PATHNAME)) { call strcpy (Memc[str], fname, maxchar) return } } # No mask found. call sprintf (Memc[str], SZ_PATHNAME, "Bad pixel mask not found (%s)") call pargstr (fname) call error (1, Memc[str]) # This will not be reached and we let the calling program free # the stack. We include smark/sfree for lint detectors. call sfree (sp) end # IC_MCLOSE -- Close the mask interface. procedure ic_mclose (nimages) int nimages # Number of images int i include "icombine.com" begin if (icm == NULL) return do i = 1, nimages { call mfree (Memi[ICM_NAMES(icm)+i-1], TY_CHAR) call mfree (Memi[ICM_BUFS(icm)+i-1], TY_INT) } do i = 1, nimages { if (Memi[ICM_PMS(icm)+i-1] != NULL) call pm_close (Memi[ICM_PMS(icm)+i-1]) if (project) break } call mfree (ICM_NAMES(icm), TY_POINTER) call mfree (ICM_BUFS(icm), TY_POINTER) call mfree (ICM_PMS(icm), TY_POINTER) call mfree (icm, TY_STRUCT) end # IC_MGET -- Get lines of mask pixels in the output coordinate system. # This converts the mask format to an array where zero is good and nonzero # is bad. This has special cases for optimization. procedure ic_mget (in, out, offsets, v1, v2, m, lflag, nimages, mtype) 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 int iomode # I/O mode pointer bufs # Pointer to data line buffers pointer pms # Pointer to array of PMIO pointers char title[1] int i, j, k, l, ndim, nin, nout, npix, envfind() pointer buf, pm, names, fname, pm_open(), yt_pmload() bool match, pm_linenotempty() errchk pm_glpi, pm_open, pm_loadf, pm_loadim, yt_pmload 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 mtype = M_NONE if (icm == NULL) return if (ICM_TYPE(icm) == M_NONE && aligned && !dothresh) return mtype = ICM_TYPE(icm) mvalue = ICM_VALUE(icm) iomode = ICM_IOMODE(icm) bufs = ICM_BUFS(icm) pms = ICM_PMS(icm) names = ICM_NAMES(icm) match = (envfind ("pmmatch", title, 1) > 0) # Set the mask pointers and line flags and apply offsets if needed. ndim = IM_NDIM(out[1]) nout = IM_LEN(out[1],1) do i = 1, nimages { nin = IM_LEN(in[i],1) j = max (0, offsets[i,1]) k = min (nout, nin + offsets[i,1]) npix = k - j m[i] = Memi[bufs+i-1] buf = Memi[bufs+i-1] + j if (project) { pm = Memi[pms] fname = Memi[names] } else { pm = Memi[pms+i-1] fname = Memi[names+i-1] } if (npix < 1) lflag[i] = D_NONE else if (npix == nout) lflag[i] = D_ALL else lflag[i] = D_MIX if (lflag[i] != D_NONE) { v2[1] = 1 + j - offsets[i,1] do l = 2, ndim { v2[l] = v1[l] - offsets[i,l] if (v2[l] < 1 || v2[l] > IM_LEN(in[i],l)) { lflag[i] = D_NONE break } } } if (project) v2[ndim+1] = i if (lflag[i] == D_NONE) { if (pm != NULL && !project) { call pm_close (pm) Memi[pms+i-1] = NULL } call amovki (1, Memi[m[i]], nout) next } else if (lflag[i] == D_MIX) { if (j > 0) call amovki (1, Memi[m[i]], j) if (nout-k > 0) call amovki (1, Memi[m[i]+k], nout-k) } if (fname == NULL) { call aclri (Memi[buf], npix) next } else if (Memc[fname] == EOS) { call aclri (Memi[buf], npix) next } # Do mask I/O and convert to appropriate values in order of # expected usage. if (pm == NULL) { if (match) { pm = yt_pmload (Memc[fname], in[i], "logical", Memc[fname], SZ_FNAME) } else { pm = pm_open (NULL) iferr (call pm_loadf (pm, Memc[fname], title, 1)) call pm_loadim (pm, Memc[fname], title, 1) call pm_seti (pm, P_REFIM, in[i]) } if (project) Memi[pms] = pm else Memi[pms+i-1] = pm } if (pm_linenotempty (pm, v2)) { call pm_glpi (pm, v2, Memi[buf], 32, npix, 0) if (mtype == M_BOOLEAN) ; else if (mtype == M_BADBITS) call aandki (Memi[buf], mvalue, Memi[buf], npix) else if (mtype == M_BADVAL) call abeqki (Memi[buf], mvalue, Memi[buf], npix) else if (mtype == M_NOVAL) { do j = 0, npix-1 { if (Memi[buf+j] == 0) next if (Memi[buf+j] == mvalue) Memi[buf+j] = 1 else Memi[buf+j] = 2 } } 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) else if (mtype == M_LTVAL) call abgeki (Memi[buf], mvalue, Memi[buf], npix) else if (mtype == M_GTVAL) call ableki (Memi[buf], mvalue, Memi[buf], npix) lflag[i] = D_NONE do j = 1, npix if (Memi[buf+j-1] != 1) { 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_NOVAL && mvalue != 0) || (mtype == M_GOODVAL && mvalue == 0)) { call aclri (Memi[buf], npix) } else if (mtype == M_LTVAL && mvalue > 0) { call aclri (Memi[buf], npix) } else { call amovki (1, Memi[buf], npix) lflag[i] = D_NONE } } if (iomode == ICM_CLOSED) call ic_mclose1 (i, nimages) } # Set overall data flag dflag = lflag[1] do i = 2, nimages { if (lflag[i] != dflag) { dflag = D_MIX break } } end # IC_MGET1 -- Get line of mask pixels from a specified image. # This is used by the IC_STAT procedure. This procedure converts the # stored mask format to an array where zero is good and nonzero is bad. # The data vector and returned mask array are in the input image pixel system. procedure ic_mget1 (in, image, nimages, offset, v, m) pointer in # Input image pointer int image # Image index int nimages # Number of images int offset # Column offset long v[IM_MAXDIM] # Data vector desired pointer m # Pointer to mask int mtype # Mask type int mvalue # Mask value pointer bufs # Pointer to data line buffers pointer pms # Pointer to array of PMIO pointers char title[1] int i, npix, envfind() pointer buf, pm, names, fname, pm_open(), yt_pmload() bool pm_linenotempty() errchk pm_glpi, pm_open, pm_loadf, pm_loadim, yt_pmload include "icombine.com" begin dflag = D_ALL if (icm == NULL) return if (ICM_TYPE(icm) == M_NONE) return mtype = ICM_TYPE(icm) mvalue = ICM_VALUE(icm) bufs = ICM_BUFS(icm) pms = ICM_PMS(icm) names = ICM_NAMES(icm) npix = IM_LEN(in,1) m = Memi[bufs+image-1] + offset if (project) { pm = Memi[pms] fname = Memi[names] } else { pm = Memi[pms+image-1] fname = Memi[names+image-1] } if (fname == NULL) return if (Memc[fname] == EOS) return if (pm == NULL) { if (envfind ("pmmatch", title, 1) > 0) { pm = yt_pmload (Memc[fname], in, "logical", Memc[fname], SZ_FNAME) } else { pm = pm_open (NULL) iferr (call pm_loadf (pm, Memc[fname], title, 1)) call pm_loadim (pm, Memc[fname], title, 1) call pm_seti (pm, P_REFIM, in) } if (project) Memi[pms] = pm else Memi[pms+image-1] = pm } # Do mask I/O and convert to appropriate values in order of # expected usage. buf = m if (pm_linenotempty (pm, v)) { call pm_glpi (pm, v, Memi[buf], 32, npix, 0) if (mtype == M_BOOLEAN) ; else if (mtype == M_BADBITS) call aandki (Memi[buf], mvalue, Memi[buf], npix) else if (mtype == M_BADVAL) call abeqki (Memi[buf], mvalue, Memi[buf], npix) else if (mtype == M_NOVAL) { do i = 0, npix-1 { if (Memi[buf+i] == 0) next if (Memi[buf+i] == mvalue) Memi[buf+i] = 1 else Memi[buf+i] = 2 } } 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) else if (mtype == M_LTVAL) call abgeki (Memi[buf], mvalue, Memi[buf], npix) else if (mtype == M_GTVAL) call ableki (Memi[buf], mvalue, Memi[buf], npix) dflag = D_NONE do i = 1, npix if (Memi[buf+i-1] != 1) { dflag = D_MIX break } } else { if (mtype == M_BOOLEAN || mtype == M_BADBITS) { ; } else if ((mtype == M_BADVAL && mvalue != 0) || (mtype == M_NOVAL && mvalue != 0) || (mtype == M_GOODVAL && mvalue == 0)) { ; } else if (mtype == M_LTVAL && mvalue > 0) { ; } else dflag = D_NONE } end # IC_MCLOSE1 -- Close mask by index. procedure ic_mclose1 (image, nimages) int image # Image index int nimages # Number of images pointer pms, names, pm, fname include "icombine.com" begin if (icm == NULL) return pms = ICM_PMS(icm) names = ICM_NAMES(icm) if (project) { pm = Memi[pms] fname = Memi[names] } else { pm = Memi[pms+image-1] fname = Memi[names+image-1] } if (fname == NULL || pm == NULL) return if (Memc[fname] == EOS || pm == NULL) return call pm_close (pm) if (project) Memi[pms] = NULL else Memi[pms+image-1] = NULL end # YT_PMLOAD -- This is like yt_mappm except it returns the mask pointer. pointer procedure yt_pmload (pmname, refim, match, mname, sz_mname) char pmname[ARB] #I Pixel mask name pointer refim #I Reference image pointer char match[ARB] #I Match by physical coordinates? char mname[ARB] #O Expanded mask name int sz_mname #O Size of expanded mask name pointer pm #R Pixel mask pointer int imstati() pointer im, yt_mappm() errchk yt_mappm begin im = yt_mappm (pmname, refim, match, mname, sz_mname) if (im != NULL) { pm = imstati (im, IM_PMDES) call imseti (im, IM_PMDES, NULL) call imunmap (im) } else pm = NULL return (pm) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icmedian.gx000066400000000000000000000126231332166314300231100ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" $for (sird) # IC_MEDIAN -- Median of lines procedure ic_median$t (d, n, npts, doblank, median) pointer d[ARB] # Input data line pointers int n[npts] # Number of good pixels int npts # Number of output points per line int doblank # Set blank values? $if (datatype == sil) real median[npts] # Median $else PIXEL median[npts] # Median $endif int i, j, k, j1, j2, n1, lo, up, lo1, up1 bool even $if (datatype == silx) real val1, val2, val3 $else PIXEL val1, val2, val3 $endif PIXEL temp, wtemp $if (datatype == x) real abs_temp $endif include "../icombine.com" begin # If no data return after possibly setting blank values. if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts median[i]= blank } return } # If the data were previously sorted then directly compute the median. if (mclip) { if (dflag == D_ALL) { n1 = n[1] j1 = n1 / 2 + 1 j2 = n1 / 2 even = (mod(n1,2)==0 && (medtype==MEDAVG || 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] } return } else { # Check for negative n values. If found then there are # pixels with no good values but with values we want to # use as a substitute median. In this case ignore that # the good pixels have been sorted. do i = 1, npts { if (n[i] < 0) break } if (n[i] >= 0) { do i = 1, npts { k = i - 1 n1 = n[i] if (n1 > 0) { j1 = n1 / 2 + 1 if (mod(n1,2)==0 && (medtype==MEDAVG || n1>2)) { j2 = n1 / 2 val1 = Mem$t[d[j1]+k] val2 = Mem$t[d[j2]+k] median[i] = (val1 + val2) / 2. } else median[i] = Mem$t[d[j1]+k] } else if (doblank == YES) median[i] = blank } return } } } # Compute the median. do i = 1, npts { k = i - 1 n1 = abs(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 && (medtype==MEDAVG || n1 > 2)) { 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] if (medtype == MEDAVG) median[i] = (val1 + val2) / 2 else median[i] = min (val1, val2) # If 1 point return the value. } else if (n1 == 1) median[i] = Mem$t[d[1]+k] # If no points return with a possibly blank value. else if (doblank == YES) median[i] = blank } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icmm.gx000066400000000000000000000073021332166314300222620ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" $for (sird) # IC_MM -- Reject a specified number of high and low pixels procedure ic_mm$t (d, m, n, npts) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of good pixels int npts # Number of output points per line int n1, ncombine, npairs, nlow, nhigh, np int i, i1, j, jmax, jmin pointer k, kmax, kmin PIXEL d1, d2, dmin, dmax include "../icombine.com" begin if (dflag == D_NONE) return if (dflag == D_ALL) { n1 = max (0, 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 = max (0, n[i]) if (dflag == D_MIX) { nlow = flow * n1 + 0.001 nhigh = fhigh * n1 + 0.001 ncombine = max (ncombine, n1 - nlow - nhigh) npairs = min (nlow, nhigh) nlow = nlow - npairs nhigh = nhigh - npairs } # Reject the npairs low and high points. do np = 1, npairs { k = d[1] + i1 $if (datatype == x) d1 = abs (Mem$t[k]) $else d1 = Mem$t[k] $endif dmax = d1; dmin = d1; jmax = 1; jmin = 1; kmax = k; kmin = k do j = 2, n1 { d2 = d1 k = d[j] + i1 $if (datatype == x) d1 = abs (Mem$t[k]) $else d1 = Mem$t[k] $endif if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } else if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } j = n1 - 1 if (keepids) { if (jmax < j) { if (jmin != j) { Mem$t[kmax] = d2 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } else { Mem$t[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } if (jmin < j) { if (jmax != n1) { Mem$t[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } else { Mem$t[kmin] = d2 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[j]+i1] Memi[m[j]+i1] = k } } } else { if (jmax < j) { if (jmin != j) Mem$t[kmax] = d2 else Mem$t[kmax] = d1 } if (jmin < j) { if (jmax != n1) Mem$t[kmin] = d1 else Mem$t[kmin] = d2 } } n1 = n1 - 2 } # Reject the excess low points. do np = 1, nlow { k = d[1] + i1 $if (datatype == x) d1 = abs (Mem$t[k]) $else d1 = Mem$t[k] $endif dmin = d1; jmin = 1; kmin = k do j = 2, n1 { k = d[j] + i1 $if (datatype == x) d1 = abs (Mem$t[k]) $else d1 = Mem$t[k] $endif if (d1 < dmin) { dmin = d1; jmin = j; kmin = k } } if (keepids) { if (jmin < n1) { Mem$t[kmin] = d1 k = Memi[m[jmin]+i1] Memi[m[jmin]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmin < n1) Mem$t[kmin] = d1 } n1 = n1 - 1 } # Reject the excess high points. do np = 1, nhigh { k = d[1] + i1 $if (datatype == x) d1 = abs (Mem$t[k]) $else d1 = Mem$t[k] $endif dmax = d1; jmax = 1; kmax = k do j = 2, n1 { k = d[j] + i1 $if (datatype == x) d1 = abs (Mem$t[k]) $else d1 = Mem$t[k] $endif if (d1 > dmax) { dmax = d1; jmax = j; kmax = k } } if (keepids) { if (jmax < n1) { Mem$t[kmax] = d1 k = Memi[m[jmax]+i1] Memi[m[jmax]+i1] = Memi[m[n1]+i1] Memi[m[n1]+i1] = k } } else { if (jmax < n1) Mem$t[kmax] = d1 } n1 = n1 - 1 } n[i] = n1 } if (dflag == D_ALL && npairs + nlow + nhigh > 0) dflag = D_MIX end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icnmodel.gx000066400000000000000000000071101332166314300231240ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" include "../icmask.h" $for (sird) # IC_NMODEL -- Compute the quadrature average (or summed) noise model. # Options include a weighted average/sum. procedure ic_nmodel$t (d, m, n, nm, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real nm[3,nimages] # Noise model parameters real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? $if (datatype == sil) real average[npts] # Average (returned) $else PIXEL average[npts] # Average (returned) $endif int i, j, k, n1 real val, wt, sumwt $if (datatype == sil) real sum, zero data zero /0.0/ $else PIXEL sum, zero data zero /0$f/ $endif include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = max (zero, Mem$t[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 do j = 2, n[i] { val = max (zero, Mem$t[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = max (zero, Mem$t[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n[i] { val = max (zero, Mem$t[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Mem$t[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 wt = wts[Memi[m[1]+k]] sum = val * wt**2 sumwt = wt do j = 2, n1 { val = max (zero, Mem$t[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 wt = wts[Memi[m[j]+k]] sum = sum + val * wt**2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = max (zero, Mem$t[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = Mem$t[d[1]+k]**2 do j = 2, n1 { val = max (zero, Mem$t[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = max (zero, Mem$t[d[1]+k]) val = nm[1,1] + val/nm[2,1] + (val*nm[3,1])**2 sum = val do j = 2, n1 { val = max (zero, Mem$t[d[j]+k]) val = nm[1,j] + val/nm[2,j] + (val*nm[3,j])**2 sum = sum + val } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icomb.gx000066400000000000000000000461751332166314300224410ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include "../icombine.h" # The following is for compiling under V2.11. define IM_BUFFRAC IM_BUFSIZE include # ICOMBINE -- Combine images # # The memory and open file descriptor limits are checked and an attempt # to recover is made either by setting the image pixel files to be # closed after I/O or by notifying the calling program that memory # ran out and the IMIO buffer size should be reduced. After the checks # a procedure for the selected combine option is called. # Because there may be several failure modes when reaching the file # limits we first assume an error is due to the file limit, except for # out of memory, and close some pixel files. If the error then repeats # on accessing the pixels the error is passed back. $for (sird) procedure icombine$t (in, out, scales, zeros, wts, offsets, nimages, bufsize) pointer in[nimages] # Input images pointer out[ARB] # Output images real scales[nimages] # Scales real zeros[nimages] # Zeros real wts[nimages] # Weights int offsets[nimages,ARB] # Input image offsets int nimages # Number of input images int bufsize # IMIO buffer size char str[1] int i, j, k, npts, fd, stropen(), xt_imgnl$t() pointer sp, d, id, n, m, lflag, v, dbuf pointer im, buf, xt_opix(), impl1i() errchk stropen, xt_cpix, xt_opix, xt_imgnl$t, impl1i, ic_combine$t $if (datatype == sil) pointer impl1r() errchk impl1r $else pointer impl1$t() errchk impl1$t $endif include "../icombine.com" begin npts = IM_LEN(out[1],1) # Allocate memory. call smark (sp) call salloc (dbuf, nimages, TY_POINTER) call salloc (d, nimages, TY_POINTER) call salloc (id, nimages, TY_POINTER) call salloc (n, npts, TY_INT) call salloc (m, nimages, TY_POINTER) call salloc (lflag, nimages, TY_INT) call salloc (v, IM_MAXDIM, TY_LONG) call amovki (D_ALL, Memi[lflag], nimages) call amovkl (1, Meml[v], IM_MAXDIM) # If not aligned or growing create data buffers of output length # otherwise use the IMIO buffers. if (!aligned || grow >= 1.) { do i = 1, nimages { call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) call aclr$t (Mem$t[Memi[dbuf+i-1]], npts) } } else { do i = 1, nimages { im = xt_opix (in[i], i, 1) if (im != in[i]) { call salloc (Memi[dbuf+i-1], npts, TY_PIXEL) call aclr$t (Mem$t[Memi[dbuf+i-1]], npts) } } call amovki (NULL, Memi[dbuf], nimages) } if (project) { call imseti (in[1], IM_NBUFS, nimages) call imseti (in[1], IM_BUFFRAC, 0) call imseti (in[1], IM_BUFSIZE, bufsize) do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } } else { # Reserve FD for string operations. fd = stropen (str, 1, NEW_FILE) # Do I/O to the images. do i = 1, 6 { if (out[i] != NULL) { call imseti (out[i], IM_BUFFRAC, 0) call imseti (out[i], IM_BUFSIZE, bufsize) } } $if (datatype == sil) buf = impl1r (out[1]) call aclrr (Memr[buf], npts) if (out[3] != NULL) { buf = impl1r (out[3]) call aclrr (Memr[buf], npts) } $else buf = impl1$t (out[1]) call aclr$t (Mem$t[buf], npts) if (out[3] != NULL) { buf = impl1$t (out[3]) call aclr$t (Mem$t[buf], npts) } $endif if (out[2] != NULL) { buf = impl1i (out[2]) call aclri (Memi[buf], npts) } if (out[4] != NULL) { buf = impl1i (out[4]) call aclri (Memi[buf], npts) } if (out[5] != NULL) { buf = impl1i (out[5]) call aclri (Memi[buf], npts) } if (out[6] != NULL) { buf = impl1i (out[6]) call aclri (Memi[buf], npts) } # Do I/O for first input image line. if (!project) { do i = 1, nimages { call xt_imseti (i, "bufsize", bufsize) j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) call xt_cpix (i) j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) call xt_cpix (i) } do i = 1, nimages { j = max (0, offsets[i,1]) k = min (npts, IM_LEN(in[i],1) + offsets[i,1]) if (k - j < 1) next j = 1 - offsets[i,2] if (j < 1 || j > IM_LEN(in[i],2)) next iferr { Meml[v+1] = j j = xt_imgnl$t (in[i], i, buf, Meml[v], 1) } then { call imseti (im, IM_PIXFD, NULL) call sfree (sp) call strclose (fd) call erract (EA_ERROR) } } } call strclose (fd) } call ic_combine$t (in, out, Memi[dbuf], Memi[d], Memi[id], Memi[n], Memi[m], Memi[lflag], offsets, scales, zeros, wts, nimages, npts) end # IC_COMBINE -- Combine images. procedure ic_combine$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, wts, nimages, npts) pointer in[nimages] # Input images pointer out[ARB] # Output image pointer dbuf[nimages] # Data buffers for nonaligned images pointer d[nimages] # Data pointers pointer id[nimages] # Image index ID pointers int n[npts] # Number of good pixels pointer m[nimages] # Mask pointers int lflag[nimages] # Line flags int offsets[nimages,ARB] # Input image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero offset factors real wts[nimages] # Combining weights int nimages # Number of input images int npts # Number of points per output line int i, ext, ctor(), errcode() real r, imgetr() pointer sp, fname, imname, v1, v2, v3, work pointer outdata, buf, nmod, nm, pms pointer immap(), impnli() $if (datatype == sil) pointer impnlr(), imgnlr() $else pointer impnl$t(), imgnl$t $endif errchk immap, ic_scale, imgetr, ic_grow, ic_grow$t, ic_rmasks, ic_emask errchk ic_gdata$t include "../icombine.com" data ext/0/ begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (v3, IM_MAXDIM, TY_LONG) call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) call ic_scale (in, out, offsets, scales, zeros, wts, nimages) # Set combine parameters switch (combine) { case AVERAGE, SUM, QUAD, NMODEL: if (dowts) keepids = true else keepids = false case MEDIAN: dowts = false keepids = false } docombine = true # Get noise model parameters. if (combine==NMODEL) { call salloc (nmod, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)] = r } else { do i = 1, nimages Memr[nmod+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nmod+3*(i-1)+1] = r * scales[i] Memr[nmod+3*(i-1)] = max ((Memr[nmod+3*(i-1)] / Memr[nmod+3*(i-1)+1]) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nmod+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nmod+3*(i-1)+2] = r } } } # Set rejection algorithm specific parameters switch (reject) { case CCDCLIP, CRREJECT: call salloc (nm, 3*nimages, TY_REAL) i = 1 if (ctor (Memc[rdnoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)] = r } else { do i = 1, nimages Memr[nm+3*(i-1)] = imgetr (in[i], Memc[rdnoise]) } i = 1 if (ctor (Memc[gain], i, r) > 0) { do i = 1, nimages { Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } else { do i = 1, nimages { r = imgetr (in[i], Memc[gain]) Memr[nm+3*(i-1)+1] = r Memr[nm+3*(i-1)] = max ((Memr[nm+3*(i-1)] / r) ** 2, 1e4 / MAX_REAL) } } i = 1 if (ctor (Memc[snoise], i, r) > 0) { do i = 1, nimages Memr[nm+3*(i-1)+2] = r } else { do i = 1, nimages { r = imgetr (in[i], Memc[snoise]) Memr[nm+3*(i-1)+2] = r } } if (!keepids) { if (doscale1) keepids = true else { do i = 2, nimages { if (Memr[nm+3*(i-1)] != Memr[nm] || Memr[nm+3*(i-1)+1] != Memr[nm+1] || Memr[nm+3*(i-1)+2] != Memr[nm+2]) { keepids = true break } } } } if (reject == CRREJECT) lsigma = MAX_REAL case MINMAX: mclip = false case PCLIP: mclip = true case AVSIGCLIP, SIGCLIP: if (doscale1) keepids = true case NONE: mclip = false } if (out[4] != NULL) keepids = true if (out[6] != NULL) { keepids = true call ic_einit (in, nimages, Memc[expkeyword], 1., 2**27-1) } if (grow >= 1.) { keepids = true call salloc (work, npts * nimages, TY_INT) } pms = NULL if (keepids) { do i = 1, nimages call salloc (id[i], npts, TY_INT) } # Reduce header memory use. do i = 1, nimages call xt_minhdr (i) $if (datatype == sil) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) switch (reject) { case CCDCLIP, CRREJECT: if (mclip) call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) else call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm], nimages, npts, Memr[outdata]) case MINMAX: call ic_mm$t (d, id, n, npts) case PCLIP: call ic_pclip$t (d, id, n, nimages, npts, Memr[outdata]) case SIGCLIP: if (mclip) call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) case AVSIGCLIP: if (mclip) call ic_mavsigclip$t (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) else call ic_aavsigclip$t (d, id, n, scales, zeros, nimages, npts, Memr[outdata]) } if (pms == NULL || nkeep > 0) { if (docombine) { switch (combine) { case AVERAGE: call ic_average$t (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case MEDIAN: call ic_median$t (d, n, npts, YES, Memr[outdata]) case SUM: call ic_average$t (d, id, n, wts, nimages, npts, YES, NO, Memr[outdata]) case QUAD: call ic_quad$t (d, id, n, wts, nimages, npts, YES, YES, Memr[outdata]) case NMODEL: call ic_nmodel$t (d, id, n, Memr[nmod], wts, nimages, npts, YES, YES, Memr[outdata]) } } } if (grow >= 1.) call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, pms) if (pms == NULL) { if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigma$t (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) } call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } $else while (impnl$t (out[1], outdata, Meml[v1]) != EOF) { call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) switch (reject) { case CCDCLIP, CRREJECT: if (mclip) call ic_mccdclip$t (d, id, n, scales, zeros, Memr[nm], nimages, npts, Mem$t[outdata]) else call ic_accdclip$t (d, id, n, scales, zeros, Memr[nm], nimages, npts, Mem$t[outdata]) case MINMAX: call ic_mm$t (d, id, n, npts) case PCLIP: call ic_pclip$t (d, id, n, nimages, npts, Mem$t[outdata]) case SIGCLIP: if (mclip) call ic_msigclip$t (d, id, n, scales, zeros, nimages, npts, Mem$t[outdata]) else call ic_asigclip$t (d, id, n, scales, zeros, nimages, npts, Mem$t[outdata]) case AVSIGCLIP: if (mclip) call ic_mavsigclip$t (d, id, n, scales, zeros, nimages, npts, Mem$t[outdata]) else call ic_aavsigclip$t (d, id, n, scales, zeros, nimages, npts, Mem$t[outdata]) } if (pms == NULL || nkeep > 0) { if (docombine) { switch (combine) { case AVERAGE: call ic_average$t (d, id, n, wts, nimages, npts, YES, YES, Mem$t[outdata]) case MEDIAN: call ic_median$t (d, n, npts, YES, Mem$t[outdata]) case SUM: call ic_average$t (d, id, n, wts, nimages, npts, YES, NO, Mem$t[outdata]) case QUAD: call ic_quad$t (d, id, n, wts, nimages, npts, YES, YES, Mem$t[outdata]) case NMODEL: call ic_nmodel$t (d, id, n, Memr[nmod], wts, nimages, npts, YES, YES, Mem$t[outdata]) } } } if (grow >= 1.) call ic_grow (out, Meml[v2], id, n, Memi[work], nimages, npts, pms) if (pms == NULL) { if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnl$t (out[3], buf, Meml[v1]) call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata], Mem$t[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) } call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } $endif if (pms != NULL) { if (nkeep > 0) { call imstats (out[1], IM_IMAGENAME, Memc[fname], SZ_FNAME) call imunmap (out[1]) iferr (buf = immap (Memc[fname], READ_WRITE, 0)) { switch (errcode()) { case SYS_FXFOPNOEXTNV: call imgcluster (Memc[fname], Memc[fname], SZ_FNAME) ext = ext + 1 call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext) iferr (buf = immap (Memc[imname], READ_WRITE, 0)) { buf = NULL ext = 0 } repeat { call sprintf (Memc[imname], SZ_FNAME, "%s[%d]") call pargstr (Memc[fname]) call pargi (ext+1) iferr (outdata = immap (Memc[imname],READ_WRITE,0)) break if (buf != NULL) call imunmap (buf) buf = outdata ext = ext + 1 } default: call erract (EA_ERROR) } } out[1] = buf } call amovkl (long(1), Meml[v1], IM_MAXDIM) call amovkl (long(1), Meml[v2], IM_MAXDIM) call amovkl (long(1), Meml[v3], IM_MAXDIM) $if (datatype == sil) while (impnlr (out[1], outdata, Meml[v1]) != EOF) { call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts, pms) if (nkeep > 0) { do i = 1, npts { if (n[i] < nkeep) { Meml[v1+1] = Meml[v1+1] - 1 if (imgnlr (out[1], buf, Meml[v1]) == EOF) ; call amovr (Memr[buf], Memr[outdata], npts) break } } } switch (combine) { case AVERAGE: call ic_average$t (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case MEDIAN: call ic_median$t (d, n, npts, NO, Memr[outdata]) case SUM: call ic_average$t (d, id, n, wts, nimages, npts, NO, NO, Memr[outdata]) case QUAD: call ic_quad$t (d, id, n, wts, nimages, npts, NO, YES, Memr[outdata]) case NMODEL: call ic_nmodel$t (d, id, n, Memr[nmod], wts, nimages, npts, NO, YES, Memr[outdata]) } if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnlr (out[3], buf, Meml[v1]) call ic_sigma$t (d, id, n, wts, npts, Memr[outdata], Memr[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } $else while (impnl$t (out[1], outdata, Meml[v1]) != EOF) { call ic_gdata$t (in, out, dbuf, d, id, n, m, lflag, offsets, scales, zeros, nimages, npts, Meml[v2], Meml[v3]) call ic_grow$t (Meml[v2], d, id, n, Memi[work], nimages, npts, pms) if (nkeep > 0) { do i = 1, npts { if (n[i] < nkeep) { Meml[v1+1] = Meml[v1+1] - 1 if (imgnl$t (out[1], buf, Meml[v1]) == EOF) ; call amov$t (Mem$t[buf], Mem$t[outdata], npts) break } } } switch (combine) { case AVERAGE: call ic_average$t (d, id, n, wts, nimages, npts, NO, YES, Mem$t[outdata]) case MEDIAN: call ic_median$t (d, n, npts, NO, Mem$t[outdata]) case SUM: call ic_average$t (d, id, n, wts, nimages, npts, NO, NO, Mem$t[outdata]) case QUAD: call ic_quad$t (d, id, n, wts, nimages, npts, NO, YES, Mem$t[outdata]) case NMODEL: call ic_nmodel$t (d, id, n, Memr[nmod], wts, nimages, npts, NO, YES, Mem$t[outdata]) } if (out[2] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[2], buf, Meml[v1]) do i = 1, npts { if (n[i] > 0) Memi[buf] = 0 else if (n[i] == 0) Memi[buf] = 1 else Memi[buf] = 2 buf = buf + 1 } } if (out[3] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnl$t (out[3], buf, Meml[v1]) call ic_sigma$t (d, id, n, wts, npts, Mem$t[outdata], Mem$t[buf]) } if (out[4] != NULL) call ic_rmasks (out[4], Meml[v2], id, nimages, n, npts) if (out[5] != NULL) { call amovl (Meml[v2], Meml[v1], IM_MAXDIM) i = impnli (out[5], buf, Meml[v1]) call amovki (nimages, Memi[buf], npts) call asubi (Memi[buf], n, Memi[buf], npts) } if (out[6] != NULL) call ic_emask (out[6], Meml[v2], id, nimages, n, wts, npts) call amovl (Meml[v1], Meml[v2], IM_MAXDIM) } $endif do i = 1, nimages call pm_close (Memi[pms+i-1]) call mfree (pms, TY_POINTER) } call sfree (sp) end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icombine.com000066400000000000000000000032431332166314300232620ustar00rootroot00000000000000# ICOMBINE Common int combine # Combine algorithm int medtype # Median type int reject # Rejection algorithm bool project # Combine across the highest dimension? real blank # Blank value pointer expkeyword # Exposure time keyword pointer statsec # Statistics section pointer rdnoise # CCD read noise pointer gain # CCD gain pointer snoise # CCD sensitivity noise real lthresh # Low threshold real hthresh # High threshold int nkeep # Minimum to keep real lsigma # Low sigma cutoff real hsigma # High sigma cutoff real pclip # Number or fraction of pixels from median real flow # Fraction of low pixels to reject real fhigh # Fraction of high pixels to reject real grow # Grow radius bool mclip # Use median in sigma clipping? real sigscale # Sigma scaling tolerance int logfd # Log file descriptor # These flags allow special conditions to be optimized. int dflag # Data flag (D_ALL, D_NONE, D_MIX) bool aligned # Are the images aligned? bool doscale # Do the images have to be scaled? bool doscale1 # Do the sigma calculations have to be scaled? bool dothresh # Check pixels outside specified thresholds? bool dowts # Does the final average have to be weighted? bool keepids # Keep track of the image indices? bool docombine # Call the combine procedure? bool sort # Sort data? bool verbose # Verbose? pointer icm # Mask data structure common /imccom/ combine, medtype, reject, blank, expkeyword, statsec, rdnoise, gain, snoise, lsigma, hsigma, lthresh, hthresh, nkeep, pclip, flow, fhigh, grow, logfd, dflag, sigscale, project, mclip, aligned, doscale, doscale1, dothresh, dowts, keepids, docombine, sort, verbose, icm mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icombine.h000066400000000000000000000036101332166314300227310ustar00rootroot00000000000000# ICOMBINE Definitions # Memory management parameters; define MAXMEMORY 500000000 # maximum memory define FUDGE 0.8 # fudge factor # Rejection options: define REJECT "|none|ccdclip|crreject|minmax|pclip|sigclip|avsigclip|" define NONE 1 # No rejection algorithm define CCDCLIP 2 # CCD noise function clipping define CRREJECT 3 # CCD noise function clipping define MINMAX 4 # Minmax rejection define PCLIP 5 # Percentile clip define SIGCLIP 6 # Sigma clip define AVSIGCLIP 7 # Sigma clip with average poisson sigma # Combine options: define COMBINE "|average|median|lmedian|sum|quadrature|nmodel|" define AVERAGE 1 define MEDIAN 2 define LMEDIAN 3 define SUM 4 define QUAD 5 define NMODEL 6 # Median types: define MEDAVG 1 # Central average for even N define MEDLOW 2 # Lower value for even N # 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|novalue|" 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_NOVAL 6 # Value selecting no value (good = 0) define M_LTVAL 7 # Values less than specified are good define M_GTVAL 8 # Values greater than specified are good 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icombine.x000066400000000000000000000336771332166314300227710ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include "icombine.h" # ICOMBINE -- Combine input list or image. # This procedure maps the images, sets the output dimensions and datatype, # opens the logfile, and sets IMIO parameters. It attempts to adjust # buffer sizes and memory requirements for maximum efficiency. procedure icombine (list, output, headers, bmask, rmask, nrmask, emask, sigma, logfile, scales, zeros, wts, stack, delete, listonly) int list #I List of input images char output[ARB] #I Output image char headers[ARB] #I Output header rootname char bmask[ARB] #I Bad pixel mask char rmask[ARB] #I Rejection mask char nrmask[ARB] #I Nreject mask char emask[ARB] #I Exposure mask char sigma[ARB] #I Sigma image (optional) char logfile[ARB] #I Logfile (optional) real scales[ARB] #I Scale factors real zeros[ARB] #I Offset factors real wts[ARB] #I Weights int stack #I Stack input images? int delete #I Delete input images? int listonly #I List images to combine? bool proj char input[SZ_FNAME], errstr[SZ_LINE] int i, j, nimages, intype, bufsize, oldsize, stack1, err, retry int maxsize, maxmemory, memory pointer sp, im, in1, in, out[6], offsets, key, tmp, bpmstack char clgetc() int clgwrd(), imtlen(), imtgetim(), imtrgetim(), getdatatype(), envgeti() int begmem(), errget(), open(), ty_max(), sizeof(), strmatch() pointer immap(), xt_immap(), ic_pmmap() errchk ic_imstack, immap, imunmap, xt_immap, ic_pmmap, ic_setout include "icombine.com" define retry_ 98 define err_ 99 begin if (listonly == YES) { # Write the output list. if (output[1] == EOS) { call imtrew (list) while (imtgetim (list, input, SZ_FNAME)!=EOF) { i = strmatch (input, "[0]") - 3 if (i > 0) call strcpy (input[i+3], input[i], SZ_FNAME) call printf ("%s\n") call pargstr (input) } } else { call sprintf (errstr, SZ_LINE, "%s.list") call pargstr (output) iferr (logfd = open (errstr, APPEND, TEXT_FILE)) call erract (EA_WARN) call imtrew (list) while (imtgetim (list, input, SZ_FNAME)!=EOF) { i = strmatch (input, "[0]") - 3 if (i > 0) call strcpy (input[i+3], input[i], SZ_FNAME) call printf ("%s -> %s\n") call pargstr (input) call pargstr (errstr) call fprintf (logfd, "%s\n") call pargstr (input) } call close (logfd) } return } nimages = imtlen (list) if (nimages == 0) call error (1, "No images to combine") if (project) { if (imtgetim (list, input, SZ_FNAME) == EOF) call error (1, "No image to project") } bufsize = 0 # if (nimages > LAST_FD - 15) # stack1 = YES # else stack1 = stack retry = 0 retry_ iferr { call smark (sp) call salloc (in, 1, TY_POINTER) nimages = 0 in1 = NULL; Memi[in] = NULL; logfd = NULL out[1] = NULL; out[2] = NULL; out[3] = NULL out[4] = NULL; out[5] = NULL; out[6] = NULL # Stack the input images. if (stack1 == YES) { proj = project project = true call salloc (bpmstack, SZ_FNAME, TY_CHAR) i = clgwrd ("masktype", Memc[bpmstack], SZ_FNAME, MASKTYPES) if (i == M_NONE) Memc[bpmstack] = EOS else { call mktemp ("tmp", Memc[bpmstack], SZ_FNAME) call strcat (".pl", Memc[bpmstack], SZ_FNAME) } call mktemp ("tmp", input, SZ_FNAME) call imtrew (list) call ic_imstack (list, input, Memc[bpmstack]) } # Open the input image(s). if (project) { tmp = immap (input, READ_ONLY, 0); out[1] = tmp if (IM_NDIM(out[1]) == 1) call error (1, "Can't project one dimensional images") nimages = IM_LEN(out[1],IM_NDIM(out[1])) call salloc (in, nimages, TY_POINTER) call amovki (out[1], Memi[in], nimages) } else { call salloc (in, imtlen(list), TY_POINTER) call amovki (NULL, Memi[in], imtlen(list)) call imtrew (list) while (imtgetim (list, input, SZ_FNAME)!=EOF) { nimages = nimages + 1 tmp = xt_immap (input, READ_ONLY, 0, nimages, retry) Memi[in+nimages-1] = tmp } # Check sizes and set I/O option. intype = 0 tmp = Memi[in] do i = 2, nimages { do j = 1, IM_NDIM(tmp) { if (IM_LEN(tmp,j) != IM_LEN(Memi[in+i-1],j)) intype = 1 } if (intype == 1) break } if (intype == 1) call xt_imseti (0, "option", intype) } # Check if there are no images. if (nimages == 0) call error (1, "No images to combine") # Convert the pclip parameter to a number of pixels rather than # a fraction. This number stays constant even if pixels are # rejected. The number of low and high pixel rejected, however, # are converted to a fraction of the valid pixels. if (reject == PCLIP) { i = nimages / 2. if (abs (pclip) < 1.) pclip = pclip * i if (pclip < 0.) pclip = min (-1, max (-i, int (pclip))) else pclip = max (1, min (i, int (pclip))) } if (reject == MINMAX) { if (flow >= 1) flow = flow / nimages if (fhigh >= 1) fhigh = fhigh / nimages i = flow * nimages j = fhigh * nimages if (i + j == 0) reject = NONE else if (i + j >= nimages) call error (1, "Bad minmax rejection parameters") } # Map the output image and set dimensions and offsets. if (stack1 == YES) { call imtrew (list) i = imtgetim (list, errstr, SZ_LINE) in1 = immap (errstr, READ_ONLY, 0) tmp = immap (output, NEW_COPY, in1); out[1] = tmp call salloc (key, SZ_FNAME, TY_CHAR) do i = 1, nimages { call sprintf (Memc[key], SZ_FNAME, "stck%04d") call pargi (i) iferr (call imdelf (out[1], Memc[key])) ; if (Memc[bpmstack] != EOS) { call sprintf (Memc[key], SZ_FNAME, "bpm%04d") call pargi (i) iferr (call imdelf (out[1], Memc[key])) ; } } } else { tmp = immap (output, NEW_COPY, Memi[in]); out[1] = tmp if (project) { IM_LEN(out[1],IM_NDIM(out[1])) = 1 IM_NDIM(out[1]) = IM_NDIM(out[1]) - 1 } } call salloc (offsets, nimages*IM_NDIM(out[1]), TY_INT) iferr (call ic_setout (Memi[in], out, Memi[offsets], nimages)) { call erract (EA_WARN) call error (1, "Can't set output geometry") } call ic_hdr (Memi[in], out, nimages) iferr (call imdelf (out, "BPM")) ; # Determine the highest precedence datatype and set output datatype. intype = IM_PIXTYPE(Memi[in]) do i = 2, nimages intype = ty_max (intype, IM_PIXTYPE(Memi[in+i-1])) IM_PIXTYPE(out[1]) = getdatatype (clgetc ("outtype")) if (IM_PIXTYPE(out[1]) == ERR) IM_PIXTYPE(out[1]) = intype # Open rejection masks if (rmask[1] != EOS) { tmp = ic_pmmap (rmask, NEW_COPY, out[1]); out[4] = tmp IM_NDIM(out[4]) = IM_NDIM(out[4]) + 1 IM_LEN(out[4],IM_NDIM(out[4])) = nimages if (!project) { if (key == NULL) call salloc (key, SZ_FNAME, TY_CHAR) do i = 100, nimages { j = imtrgetim (list, i, input, SZ_FNAME) if (i < 999) call sprintf (Memc[key], SZ_FNAME, "imcmb%d") else if (i < 9999) call sprintf (Memc[key], SZ_FNAME, "imcm%d") else call sprintf (Memc[key], SZ_FNAME, "imc%d") call pargi (i) call imastr (out[4], Memc[key], input) } } } else out[4] = NULL # Open bad pixel pixel list file if given. if (bmask[1] != EOS) { tmp = ic_pmmap (bmask, NEW_COPY, out[1]); out[2] = tmp } else out[2] = NULL # Open nreject pixel list file if given. if (nrmask[1] != EOS) { tmp = ic_pmmap (nrmask, NEW_COPY, out[1]); out[5] = tmp } else out[5] = NULL # Open exposure mask if given. if (emask[1] != EOS) { tmp = ic_pmmap (emask, NEW_COPY, out[1]); out[6] = tmp } else out[6] = NULL # Open the sigma image if given. if (sigma[1] != EOS) { tmp = immap (sigma, NEW_COPY, out[1]); out[3] = tmp IM_PIXTYPE(out[3]) = ty_max (TY_REAL, IM_PIXTYPE(out[1])) call sprintf (IM_TITLE(out[3]), SZ_IMTITLE, "Combine sigma images for %s") call pargstr (output) } else out[3] = NULL # Open masks. call ic_mopen (Memi[in], out, nimages, Memi[offsets], min(retry,1)) # 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. iferr (maxmemory = envgeti ("imcombine_maxmemory")) maxmemory = MAXMEMORY memory = begmem (0, oldsize, maxsize) memory = min (memory, maxsize, maxmemory) bufsize = FUDGE * memory / (nimages + 1) / sizeof (intype) } # Combine the images. If an out of memory error occurs close all # images and files, divide the IMIO buffer size in half and try # again. switch (ty_max (intype, IM_PIXTYPE(out[1]))) { case TY_SHORT: call icombines (Memi[in], out, scales, zeros, wts, Memi[offsets], nimages, bufsize) case TY_USHORT, TY_INT, TY_LONG: call icombinei (Memi[in], out, scales, zeros, wts, Memi[offsets], nimages, bufsize) case TY_DOUBLE: call icombined (Memi[in], out, scales, zeros, wts, Memi[offsets], nimages, bufsize) case TY_COMPLEX: call error (1, "Complex images not allowed") default: call icombiner (Memi[in], out, scales, zeros, wts, Memi[offsets], nimages, bufsize) } } then { err = errget (errstr, SZ_LINE) call eprintf ("TRAP: %d %s\n") call pargi (err) call pargstr (errstr) if (err == SYS_IKIOPIX && nimages < 250) err = SYS_MFULL call ic_mclose (nimages) if (!project) { do j = 2, nimages { if (Memi[in+j-1] != NULL) call xt_imunmap (Memi[in+j-1], j) } } if (out[2] != NULL) { iferr (call imunmap (out[2])) ; iferr (call imdelete (bmask)) ; } if (out[3] != NULL) { iferr (call imunmap (out[3])) ; iferr (call imdelete (sigma)) ; } if (out[4] != NULL) { iferr (call imunmap (out[4])) ; iferr (call imdelete (rmask)) ; } if (out[5] != NULL) { iferr (call imunmap (out[5])) ; iferr (call imdelete (nrmask)) ; } if (out[6] != NULL) { iferr (call imunmap (out[6])) ; iferr (call imdelete (emask)) ; } if (out[1] != NULL) { iferr (call imunmap (out[1])) ; iferr (call imdelete (output)) ; } if (Memi[in] != NULL) call xt_imunmap (Memi[in], 1) if (in1 != NULL) call imunmap (in1) if (logfd != NULL) call close (logfd) switch (err) { case SYS_MFULL: if (project) goto err_ if (bufsize < 10000 && retry > 2) { call strcat ("- Maybe min_lenuserarea is too large", errstr, SZ_LINE) goto err_ } bufsize = bufsize / 2 retry = retry + 1 call sfree (sp) goto retry_ case SYS_FTOOMANYFILES, SYS_IKIOPEN, SYS_IKIOPIX, SYS_FOPEN, SYS_FWTNOACC: if (project) goto err_ stack1 = YES call sfree (sp) goto retry_ default: err_ if (stack1 == YES) { iferr (call imdelete (input)) ; if (Memc[bpmstack] != EOS) { iferr (call imdelete (Memc[bpmstack])) ; } } call fixmem (oldsize) while (imtgetim (list, input, SZ_FNAME)!=EOF) ; call sfree (sp) call error (err, errstr) } } # Unmap all the images, close the log file, and restore memory. if (out[2] != NULL) iferr (call imunmap (out[2])) call erract (EA_WARN) if (out[3] != NULL) iferr (call imunmap (out[3])) call erract (EA_WARN) if (out[4] != NULL) { # Close the output first so that there is no confusion with # inheriting the output header. Then update the WCS for the # extra dimension. Note that this may not be correct with # axis reduced WCS. iferr { call imunmap (out[4]) out[4] = immap (rmask, READ_WRITE, 0) i = IM_NDIM(out[4]) call imaddi (out[4], "WCSDIM", i) call sprintf (errstr, SZ_LINE, "LTM%d_%d") call pargi (i) call pargi (i) call imaddr (out[4], errstr, 1.) call sprintf (errstr, SZ_LINE, "CD%d_%d") call pargi (i) call pargi (i) call imaddr (out[4], errstr, 1.) call imunmap (out[4]) } then call erract (EA_WARN) } if (out[5] != NULL) iferr (call imunmap (out[5])) call erract (EA_WARN) if (out[6] != NULL) iferr (call imunmap (out[6])) call erract (EA_WARN) if (out[1] != NULL) { call imunmap (out[1]) if (headers[1] != EOS) { # Write input headers to a multiextension file if desired. # This might be the same as the output image. iferr { do i = 1, nimages { im = Memi[in+i-1] call imstats (im, IM_IMAGENAME, input, SZ_FNAME) if (strmatch (headers, ".fits$") == 0) { call sprintf (errstr, SZ_LINE, "%s.fits[append]") call pargstr (headers) } else { call sprintf (errstr, SZ_LINE, "%s[append]") call pargstr (headers) } tmp = immap (errstr, NEW_COPY, im) IM_NDIM(tmp) = 0 do j = 1, IM_NDIM(im) { call sprintf (errstr, SZ_LINE, "AXLEN%d") call pargi (j) call imaddi (tmp, errstr, IM_LEN(im,j)) } call imastr (tmp, "INIMAGE", input) call imastr (tmp, "OUTIMAGE", output) call imastr (tmp, "EXTNAME", input) call imunmap (tmp) } if (logfd != NULL) { call eprintf (" Headers = %s\n") call pargstr (headers) } } then call erract (EA_WARN) } } if (!project) { do i = 2, nimages { if (Memi[in+i-1] != NULL) call xt_imunmap (Memi[in+i-1], i) } } if (Memi[in] != NULL) call xt_imunmap (Memi[in], 1) if (in1 != NULL) call imunmap (in1) if (stack1 == YES) { call imdelete (input) if (Memc[bpmstack] != EOS) call imdelete (Memc[bpmstack]) project = proj } if (logfd != NULL) call close (logfd) call ic_mclose (nimages) call fixmem (oldsize) call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icpclip.gx000066400000000000000000000116031332166314300227570ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" define MINCLIP 3 # Minimum number for clipping $for (sird) # IC_PCLIP -- Percentile clip # # 1) Find the median # 2) Find the pixel which is the specified order index away # 3) Use the data value difference as a sigma and apply clipping # 4) Since the median is known return it so it does not have to be recomputed procedure ic_pclip$t (d, m, n, nimages, npts, median) pointer d[ARB] # Data pointers pointer m[ARB] # Image id pointers int n[npts] # Number of good pixels int nimages # Number of input images int npts # Number of output points per line $if (datatype == sil) real median[npts] # Median $else PIXEL median[npts] # Median $endif int i, j, k, l, id, n1, n2, n3, n4, n5, nl, nh, nin, maxkeep bool even, fp_equalr() real sigma, r, s, t pointer sp, resid, mp1, mp2 $if (datatype == sil) real med $else PIXEL med $endif include "../icombine.com" begin # There must be at least MINCLIP and more than nkeep pixels. if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } call smark (sp) call salloc (resid, nimages+1, TY_REAL) # Set sign of pclip parameter if (pclip < 0) t = -1. else t = 1. # If there are no rejected pixels compute certain parameters once. if (dflag == D_ALL) { n1 = max (0, 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 = max (0, 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n4 = nh - nl + 1 } # If any pixels are rejected recompute the median. if (nl > 1 || nh < n1) { n5 = nl + n4 / 2 if (mod (n4, 2) == 0) { med = Mem$t[d[n5-1]+j] med = (med + Mem$t[d[n5]+j]) / 2. } else med = Mem$t[d[n5]+j] n[i] = n4 } if (combine == MEDIAN) median[i] = med # Reorder if pixels only if necessary. if (nl > 1 && (combine != MEDIAN || grow >= 1.)) { k = max (nl, n4 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mem$t[d[l]+j] = Mem$t[d[k]+j] if (grow >= 1.) { mp1 = m[l] + j mp2 = m[k] + j id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+j] = Memi[m[k]+j] k = k + 1 } } else { do l = 1, min (n1, nl - 1) { Mem$t[d[l]+j] = Mem$t[d[k]+j] k = k + 1 } } } } # Check if data flag needs to be reset for rejected pixels. if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icpmmap.x000066400000000000000000000013161332166314300226130ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include # IC_PMMAP -- Map pixel mask. pointer procedure ic_pmmap (fname, mode, refim) char fname[ARB] # Mask name int mode # Image mode pointer refim # Reference image pointer pm # IMIO pointer (returned) int i, fnextn() pointer sp, extn, immap() bool streq() begin call smark (sp) call salloc (extn, SZ_FNAME, TY_CHAR) i = fnextn (fname, Memc[extn], SZ_FNAME) if (streq (Memc[extn], "pl")) pm = immap (fname, mode, refim) else { call strcpy (fname, Memc[extn], SZ_FNAME) call strcat (".pl", Memc[extn], SZ_FNAME) pm = immap (Memc[extn], mode, refim) } call sfree (sp) return (pm) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icquad.gx000066400000000000000000000055561332166314300226140ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "../icombine.h" include "../icmask.h" $for (sird) # IC_QUAD -- Compute the quadrature average (or summed) image line. # Options include a weighted average/sum. procedure ic_quad$t (d, m, n, wts, nimages, npts, doblank, doaverage, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image ID pointers int n[npts] # Number of points real wts[nimages] # Weights int nimages # Number of images int npts # Number of output points per line int doblank # Set blank values? int doaverage # Do average? $if (datatype == sil) real average[npts] # Average (returned) $else PIXEL average[npts] # Average (returned) $endif int i, j, k, n1 real val, wt, sumwt $if (datatype == sil) real sum $else PIXEL sum $endif include "../icombine.com" begin # If no data has been excluded do the average/sum without checking # the number of points and using the fact that the weights are # normalized. If all the data has been excluded set the average/sum # to the blank value if requested. if (dflag == D_ALL) { if (dowts && doaverage == YES) { do i = 1, npts { k = i - 1 val = Mem$t[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 do j = 2, n[i] { val = Mem$t[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val * wt) ** 2 } average[i] = sqrt(sum) } } else { do i = 1, npts { k = i - 1 val = Mem$t[d[1]+k] sum = val**2 do j = 2, n[i] { val = Mem$t[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n[i] else average[i] = sqrt(sum) } } } else if (dflag == D_NONE) { if (doblank == YES) { do i = 1, npts average[i] = blank } } else { if (dowts && doaverage == YES) { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Mem$t[d[1]+k] wt = wts[Memi[m[1]+k]] sum = (val * wt) ** 2 sumwt = wt do j = 2, n1 { val = Mem$t[d[j]+k] wt = wts[Memi[m[j]+k]] sum = sum + (val* wt) ** 2 sumwt = sumwt + wt } if (doaverage == YES) { if (sumwt > 0) average[i] = sqrt(sum) / sumwt else { val = Mem$t[d[1]+k] sum = val**2 do j = 2, n1 { val = Mem$t[d[j]+k] sum = sum + val**2 } average[i] = sqrt(sum) / n1 } } else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } else { do i = 1, npts { n1 = abs(n[i]) if (n1 > 0) { k = i - 1 val = Mem$t[d[1]+k] sum = val**2 do j = 2, n1 { val = Mem$t[d[j]+k] sum = sum + val**2 } if (doaverage == YES) average[i] = sqrt(sum) / n1 else average[i] = sqrt(sum) } else if (doblank == YES) average[i] = blank } } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icrmasks.x000066400000000000000000000015101332166314300227750ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include # IC_RMASKS -- Set pixels for rejection mask. procedure ic_rmasks (pm, v, id, nimages, n, npts) pointer pm #I Pixel mask long v[ARB] #I Output vector (input) pointer id[nimages] #I Image id pointers int nimages #I Number of images int n[npts] #I Number of good pixels int npts #I Number of output points per line int i, j, k, ndim, impnls() long v1[IM_MAXDIM] pointer buf begin ndim = IM_NDIM(pm) do k = 1, nimages { call amovl (v, v1, ndim-1) v1[ndim] = k i = impnls (pm, buf, v1) do j = 1, npts { if (n[j] == nimages) Mems[buf+j-1] = 0 else { Mems[buf+j-1] = 1 do i = 1, n[j] { if (Memi[id[i]+j-1] == k) { Mems[buf+j-1] = 0 break } } } } } end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icscale.x000066400000000000000000000235371332166314300226010ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "icombine.h" # IC_SCALE -- Get and set the scaling factors. # # If the scaling parameters have been set earlier then this routine # just normalizes the factors and writes the log output. # When dealing with individual images using image statistics for scaling # factors this routine determines the image statistics rather than being # done earlier since the input images have all been mapped at this stage. procedure ic_scale (in, out, offsets, scales, zeros, wts, nimages) pointer in[nimages] # Input images pointer out[ARB] # Output images int offsets[nimages,ARB] # Image offsets real scales[nimages] # Scale factors real zeros[nimages] # Zero or sky levels real wts[nimages] # Weights int nimages # Number of images int stype, ztype, wtype int i, j, k, l, nout real mode, median, mean, sumwts pointer sp, ncombine, exptime, modes, medians, means pointer section, str, sname, zname, wname, im, imref bool domode, domedian, domean, dozero, dos, doz, dow, snorm, znorm, wflag int imgeti(), strdic(), ic_gscale() real imgetr(), asumr(), asumi() pointer xt_opix() errchk ic_gscale, xt_opix, ic_statr include "icombine.com" begin call smark (sp) call salloc (ncombine, nimages, TY_INT) call salloc (exptime, nimages, TY_REAL) call salloc (modes, nimages, TY_REAL) call salloc (medians, nimages, TY_REAL) call salloc (means, nimages, TY_REAL) call salloc (section, SZ_LINE, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) call salloc (sname, SZ_FNAME, TY_CHAR) call salloc (zname, SZ_FNAME, TY_CHAR) call salloc (wname, SZ_FNAME, TY_CHAR) # Get the number of images previously combined and the exposure times. # The default combine number is 1 and the default exposure is 0. do i = 1, nimages { iferr (Memi[ncombine+i-1] = imgeti (in[i], "ncombine")) Memi[ncombine+i-1] = 1 if (Memc[expkeyword] != EOS) { iferr (Memr[exptime+i-1] = imgetr (in[i], Memc[expkeyword])) Memr[exptime+i-1] = 0. } else Memr[exptime+i-1] = 0. if (project) { call amovki (Memi[ncombine], Memi[ncombine], nimages) call amovkr (Memr[exptime], Memr[exptime], nimages) break } } # Set scaling type and factors. stype = ic_gscale ("scale", Memc[sname], STYPES, in, Memr[exptime], scales, nimages) ztype = ic_gscale ("zero", Memc[zname], ZTYPES, in, Memr[exptime], zeros, nimages) wtype = ic_gscale ("weight", Memc[wname], WTYPES, in, Memr[exptime], wts, nimages) # Get image statistics if needed. dos = ((stype==S_MODE)||(stype==S_MEDIAN)||(stype==S_MEAN)) doz = ((ztype==S_MODE)||(ztype==S_MEDIAN)||(ztype==S_MEAN)) dow = ((wtype==S_MODE)||(wtype==S_MEDIAN)||(wtype==S_MEAN)) if (dos) { dos = false do i = 1, nimages if (IS_INDEFR(scales[i])) { dos = true break } } if (doz) { doz = false do i = 1, nimages if (IS_INDEFR(zeros[i])) { doz = true break } } if (dow) { dow = false do i = 1, nimages if (IS_INDEFR(wts[i])) { dow = true break } } if (dos || doz || dow) { domode = ((stype==S_MODE)||(ztype==S_MODE)||(wtype==S_MODE)) domedian = ((stype==S_MEDIAN)||(ztype==S_MEDIAN)||(wtype==S_MEDIAN)) domean = ((stype==S_MEAN)||(ztype==S_MEAN)||(wtype==S_MEAN)) Memc[section] = EOS Memc[str] = EOS call sscan (Memc[statsec]) call gargwrd (Memc[section], SZ_FNAME) call gargwrd (Memc[str], SZ_LINE) i = strdic (Memc[section], Memc[section], SZ_FNAME, S_SECTION) switch (i) { case S_INPUT: call strcpy (Memc[str], Memc[section], SZ_FNAME) imref = NULL case S_OUTPUT: call strcpy (Memc[str], Memc[section], SZ_FNAME) imref = out[1] case S_OVERLAP: call strcpy ("[", Memc[section], SZ_FNAME) do i = 1, IM_NDIM(out[1]) { k = offsets[1,i] + 1 l = offsets[1,i] + IM_LEN(in[1],i) do j = 2, nimages { k = max (k, offsets[j,i]+1) l = min (l, offsets[j,i]+IM_LEN(in[j],i)) } if (i < IM_NDIM(out[1])) call sprintf (Memc[str], SZ_LINE, "%d:%d,") else call sprintf (Memc[str], SZ_LINE, "%d:%d]") call pargi (k) call pargi (l) call strcat (Memc[str], Memc[section], SZ_FNAME) } imref = out[1] default: imref = NULL } do i = 1, nimages { im = xt_opix (in[i], i, 0) if (imref != out[1]) imref = im if ((dos && IS_INDEFR(scales[i])) || (doz && IS_INDEFR(zeros[i])) || (dow && IS_INDEFR(wts[i]))) { call ic_statr (im, imref, Memc[section], offsets, i, nimages, domode, domedian, domean, mode, median, mean) if (domode) { if (stype == S_MODE && IS_INDEFR(scales[i])) scales[i] = mode if (ztype == S_MODE && IS_INDEFR(zeros[i])) zeros[i] = mode if (wtype == S_MODE && IS_INDEFR(wts[i])) wts[i] = mode } if (domedian) { if (stype == S_MEDIAN && IS_INDEFR(scales[i])) scales[i] = median if (ztype == S_MEDIAN && IS_INDEFR(zeros[i])) zeros[i] = median if (wtype == S_MEDIAN && IS_INDEFR(wts[i])) wts[i] = median } if (domean) { if (stype == S_MEAN && IS_INDEFR(scales[i])) scales[i] = mean if (ztype == S_MEAN && IS_INDEFR(zeros[i])) zeros[i] = mean if (wtype == S_MEAN && IS_INDEFR(wts[i])) wts[i] = mean } } } } # Save the image statistics if computed. call amovkr (INDEFR, Memr[modes], nimages) call amovkr (INDEFR, Memr[medians], nimages) call amovkr (INDEFR, Memr[means], nimages) if (stype == S_MODE) call amovr (scales, Memr[modes], nimages) if (stype == S_MEDIAN) call amovr (scales, Memr[medians], nimages) if (stype == S_MEAN) call amovr (scales, Memr[means], nimages) if (ztype == S_MODE) call amovr (zeros, Memr[modes], nimages) if (ztype == S_MEDIAN) call amovr (zeros, Memr[medians], nimages) if (ztype == S_MEAN) call amovr (zeros, Memr[means], nimages) if (wtype == S_MODE) call amovr (wts, Memr[modes], nimages) if (wtype == S_MEDIAN) call amovr (wts, Memr[medians], nimages) if (wtype == S_MEAN) call amovr (wts, Memr[means], nimages) # If nothing else has set the scaling factors set them to defaults. do i = 1, nimages { if (IS_INDEFR(scales[i])) scales[i] = 1. if (IS_INDEFR(zeros[i])) zeros[i] = 0. if (IS_INDEFR(wts[i])) wts[i] = 1. } do i = 1, nimages if (scales[i] <= 0.) { call eprintf ("WARNING: Negative scale factors") call eprintf (" -- ignoring scaling\n") call amovkr (1., scales, nimages) break } # Convert to factors relative to the first image. snorm = (stype == S_FILE || stype == S_KEYWORD) znorm = (ztype == S_FILE || ztype == S_KEYWORD) wflag = (wtype == S_FILE || wtype == S_KEYWORD) if (snorm) call arcpr (1., scales, scales, nimages) mean = scales[1] call adivkr (scales, mean, scales, nimages) call adivr (zeros, scales, zeros, nimages) if (wtype != S_NONE) { do i = 1, nimages { if (wts[i] < 0.) { call eprintf ("WARNING: Negative weights") call eprintf (" -- using only NCOMBINE weights\n") do j = 1, nimages wts[j] = Memi[ncombine+j-1] break } if (ztype == S_NONE || znorm || wflag) wts[i] = Memi[ncombine+i-1] * wts[i] else { if (zeros[i] <= 0.) { call eprintf ("WARNING: Negative zero offsets") call eprintf (" -- ignoring zero weight adjustments\n") do j = 1, nimages wts[j] = Memi[ncombine+j-1] * wts[j] break } wts[i] = Memi[ncombine+i-1] * wts[i] * zeros[1] / zeros[i] } } } if (znorm) call anegr (zeros, zeros, nimages) else { # Because of finite arithmetic it is possible for the zero offsets # to be nonzero even when they are all equal. Just for the sake of # a nice log set the zero offsets in this case. mean = zeros[1] call asubkr (zeros, mean, zeros, nimages) for (i=2; (i<=nimages)&&(zeros[i]==zeros[1]); i=i+1) ; if (i > nimages) call aclrr (zeros, nimages) } mean = asumr (wts, nimages) if (mean > 0.) call adivkr (wts, mean, wts, nimages) else { call eprintf ("WARNING: Mean weight is zero -- using no weights\n") call amovkr (1., wts, nimages) mean = 1. } # Set flags for scaling, zero offsets, sigma scaling, weights. # Sigma scaling may be suppressed if the scales or zeros are # different by a specified tolerance. doscale = false dozero = false doscale1 = false dowts = false do i = 2, nimages { if (snorm || scales[i] != scales[1]) doscale = true if (znorm || zeros[i] != zeros[1]) dozero = true if (wts[i] != wts[1]) dowts = true } if (doscale && sigscale != 0.) { do i = 1, nimages { if (abs (scales[i] - 1) > sigscale) { doscale1 = true break } } } # Set the output header parameters. nout = asumi (Memi[ncombine], nimages) call imaddi (out[1], "ncombine", nout) mean = 0. sumwts = 0. do i = 1, nimages { ifnoerr (mode = imgetr (in[i], "ccdmean")) { mean = mean + wts[i] * mode / scales[i] sumwts = sumwts + wts[i] } } if (sumwts > 0.) { mean = mean / sumwts ifnoerr (mode = imgetr (out[1], "ccdmean")) { call imaddr (out[1], "ccdmean", mean) iferr (call imdelf (out[1], "ccdmeant")) ; } } if (out[2] != NULL) { call imstats (out[2], IM_IMAGENAME, Memc[str], SZ_FNAME) call imastr (out[1], "BPM", Memc[str]) } # Start the log here since much of the info is only available here. if (verbose) { i = logfd logfd = STDOUT call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname], Memc[zname], Memc[wname], Memr[modes], Memr[medians], Memr[means], scales, zeros, wts, offsets, nimages, dozero, nout) logfd = i } call ic_log (in, out, Memi[ncombine], Memr[exptime], Memc[sname], Memc[zname], Memc[wname], Memr[modes], Memr[medians], Memr[means], scales, zeros, wts, offsets, nimages, dozero, nout) doscale = (doscale || dozero) call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icsclip.gx000066400000000000000000000251331332166314300227650ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "../icombine.h" define MINCLIP 3 # Mininum number of images for algorithm $for (sird) # IC_ASIGCLIP -- Reject pixels using sigma clipping about the average # The initial average rejects the high and low pixels. A correction for # different scalings of the images may be made. Weights are not used. procedure ic_asigclip$t (d, m, n, scales, zeros, nimages, npts, average) pointer d[nimages] # Data pointers pointer m[nimages] # Image id pointers int n[npts] # Number of good pixels real scales[nimages] # Scales real zeros[nimages] # Zeros int nimages # Number of images int npts # Number of output points per line $if (datatype == sil) real average[npts] # Average $else PIXEL average[npts] # Average $endif int i, j, k, l, jj, n1, n2, nin, nk, maxkeep $if (datatype == sil) real d1, low, high, sum, a, s, r, one data one /1.0/ $else PIXEL d1, low, high, sum, a, s, r, one data one /1$f/ $endif pointer sp, resid, w, wp, dp1, dp2, mp1, mp2 include "../icombine.com" begin # If there are insufficient pixels go on to the combining if (nkeep < 0) maxkeep = max (0, nimages + nkeep) else maxkeep = min (nimages, nkeep) if (nimages < max (MINCLIP, maxkeep+1) || dflag == D_NONE) { docombine = true return } # Flag whether returned average needs to be recomputed. if (dowts || combine != AVERAGE) docombine = true else docombine = false # Save the residuals and the sigma scaling corrections if needed. call smark (sp) call salloc (resid, nimages+1, TY_REAL) if (doscale1) call salloc (w, nimages, TY_REAL) # Do sigma clipping. nin = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 (max (0, 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 = max (0, n[1]) do i = 1, npts { k = i - 1 n1 = max (0, 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 <= nh; 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 <= nh; 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 == max (0, n[i])) nl = nl - 1 else { r = Memr[resid+nl-1] s = Memr[resid+nh+1] if (r < s) { nl = nl - 1 r = r + TOL if (s <= r) nh = nh + 1 if (nl > 1) { if (Memr[resid+nl-1] <= r) nl = nl - 1 } } else { nh = nh + 1 s = s + TOL if (r <= s) nl = nl - 1 if (nh < n2) { if (Memr[resid+nh+1] <= s) nh = nh + 1 } } } n1 = nh - nl + 1 } # Only set median and reorder if needed n[i] = n1 if (n1 > 0 && nl > 1 && (combine != MEDIAN || grow >= 1.)) { j = max (nl, n1 + 1) if (keepids) { do l = 1, min (n1, nl-1) { Mem$t[d[l]+k] = Mem$t[d[j]+k] if (grow >= 1.) { mp1 = m[l] + k mp2 = m[j] + k id = Memi[mp1] Memi[mp1] = Memi[mp2] Memi[mp2] = id } else Memi[m[l]+k] = Memi[m[j]+k] j = j + 1 } } else { do l = 1, min (n1, nl - 1) { Mem$t[d[l]+k] = Mem$t[d[j]+k] j = j + 1 } } } if (combine == MEDIAN) median[i] = med } # Check if data flag needs to be reset for rejected pixels if (dflag == D_ALL) { do i = 1, npts { if (max (0, 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icsection.x000066400000000000000000000040211332166314300231410ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include # 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icsetout.x000066400000000000000000000221111332166314300230200ustar00rootroot00000000000000include include include define OFFTYPES "|none|wcs|world|physical|grid|" define FILE 0 define NONE 1 define WCS 2 define WORLD 3 define PHYSICAL 4 define GRID 5 # IC_SETOUT -- Set output image size and offsets of input images. procedure ic_setout (in, out, offsets, nimages) pointer in[nimages] # Input images pointer out[ARB] # Output images int offsets[nimages,ARB] # Offsets int nimages # Number of images int i, j, indim, outdim, mwdim, a, b, amin, bmax, fd, offtype, npix real val bool proj, reloff, flip, streq(), fp_equald() pointer sp, str, fname pointer ltv, lref, wref, cd, ltm, coord, shift, axno, axval, section pointer mw, ct, mw_openim(), mw_sctran(), xt_immap() int open(), fscan(), nscan(), mw_stati(), strlen(), strdic() errchk mw_openim, mw_gwtermd, mw_gltermd, mw_gaxmap errchk mw_sctran, mw_ctrand, open, xt_immap include "icombine.com" define newscan_ 10 begin call smark (sp) call salloc (str, SZ_FNAME, TY_CHAR) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (ltv, IM_MAXDIM, TY_DOUBLE) call salloc (ltm, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) call salloc (lref, IM_MAXDIM, TY_DOUBLE) call salloc (wref, IM_MAXDIM, TY_DOUBLE) call salloc (cd, IM_MAXDIM*IM_MAXDIM, TY_DOUBLE) call salloc (coord, IM_MAXDIM, TY_DOUBLE) call salloc (shift, IM_MAXDIM, TY_REAL) call salloc (axno, IM_MAXDIM, TY_INT) call salloc (axval, IM_MAXDIM, TY_INT) # Check and set the image dimensionality. indim = IM_NDIM(in[1]) outdim = IM_NDIM(out[1]) proj = (indim != outdim) if (!proj) { do i = 1, nimages if (IM_NDIM(in[i]) != outdim) { call sfree (sp) call error (1, "Image dimensions are not the same") } } # Set the reference point to that of the first image. mw = mw_openim (in[1]) call mw_seti (mw, MW_USEAXMAP, NO) mwdim = mw_stati (mw, MW_NPHYSDIM) call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) ct = mw_sctran (mw, "world", "logical", 0) call mw_ctrand (ct, Memd[wref], Memd[lref], mwdim) call mw_ctfree (ct) if (proj) Memd[lref+outdim] = 1 # Parse the user offset string. If "none" then there are no offsets. # If "world" or "wcs" then set the offsets based on the world WCS. # If "physical" then set the offsets based on the physical WCS. # If "grid" then set the offsets based on the input grid parameters. # If a file scan it. call clgstr ("offsets", Memc[fname], SZ_FNAME) call sscan (Memc[fname]) call gargwrd (Memc[fname], SZ_FNAME) if (nscan() == 0) offtype = NONE else { offtype = strdic (Memc[fname], Memc[str], SZ_FNAME, OFFTYPES) if (offtype > 0 && !streq (Memc[fname], Memc[str])) offtype = 0 } if (offtype == 0) offtype = FILE switch (offtype) { case NONE: call aclri (offsets, outdim*nimages) reloff = true case WORLD, WCS: do j = 1, outdim offsets[1,j] = 0 if (proj) { ct = mw_sctran (mw, "world", "logical", 0) do i = 2, nimages { Memd[wref+outdim] = i call mw_ctrand (ct, Memd[wref], Memd[coord], indim) do j = 1, outdim offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) } call mw_ctfree (ct) call mw_close (mw) } else { ct = mw_sctran (mw, "world", "logical", 0) call mw_ctrand (ct, Memd[wref], Memd[lref], indim) do i = 2, nimages { call mw_close (mw) mw = mw_openim (in[i]) ct = mw_sctran (mw, "world", "logical", 0) call mw_ctrand (ct, Memd[wref], Memd[coord], indim) do j = 1, outdim offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) call mw_ctfree (ct) } } reloff = true case PHYSICAL: call salloc (section, SZ_FNAME, TY_CHAR) call mw_gltermd (mw, Memd[ltm], Memd[coord], indim) do i = 2, nimages { call mw_close (mw) mw = mw_openim (in[i]) call mw_gltermd (mw, Memd[cd], Memd[coord], indim) call strcpy ("[", Memc[section], SZ_FNAME) flip = false do j = 0, indim*indim-1, indim+1 { if (Memd[ltm+j] * Memd[cd+j] >= 0.) call strcat ("*,", Memc[section], SZ_FNAME) else { call strcat ("-*,", Memc[section], SZ_FNAME) flip = true } } Memc[section+strlen(Memc[section])-1] = ']' if (flip) { call imstats (in[i], IM_IMAGENAME, Memc[fname], SZ_FNAME) call strcat (Memc[section], Memc[fname], SZ_FNAME) call xt_imunmap (in[i], i) in[i] = xt_immap (Memc[fname], READ_ONLY, TY_CHAR, i, 0) call mw_close (mw) mw = mw_openim (in[i]) call mw_gltermd (mw, Memd[cd], Memd[coord], indim) do j = 0, indim*indim-1 if (!fp_equald (Memd[ltm+j], Memd[cd+j])) call error (1, "Cannot match physical coordinates") } } call mw_close (mw) mw = mw_openim (in[1]) ct = mw_sctran (mw, "logical", "physical", 0) call mw_ctrand (ct, Memd[lref], Memd[ltv], indim) call mw_ctfree (ct) do j = 1, outdim offsets[1,j] = 0 if (proj) { ct = mw_sctran (mw, "physical", "logical", 0) do i = 2, nimages { Memd[ltv+outdim] = i call mw_ctrand (ct, Memd[ltv], Memd[coord], indim) do j = 1, outdim offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) } call mw_ctfree (ct) call mw_close (mw) } else { do i = 2, nimages { call mw_close (mw) mw = mw_openim (in[i]) ct = mw_sctran (mw, "physical", "logical", 0) call mw_ctrand (ct, Memd[ltv], Memd[coord], indim) do j = 1, outdim offsets[i,j] = nint (Memd[lref+j-1] - Memd[coord+j-1]) call mw_ctfree (ct) } } reloff = true case GRID: amin = 1 do j = 1, outdim { call gargi (a) call gargi (b) if (nscan() < 1+2*j) { a = 1 b = 0 } do i = 1, nimages offsets[i,j] = mod ((i-1)/amin, a) * b amin = amin * a } reloff = true case FILE: reloff = true fd = open (Memc[fname], READ_ONLY, TEXT_FILE) do i = 1, nimages { newscan_ if (fscan (fd) == EOF) call error (1, "IMCOMBINE: Offset list too short") call gargwrd (Memc[fname], SZ_FNAME) if (Memc[fname] == '#') { call gargwrd (Memc[fname], SZ_FNAME) call strlwr (Memc[fname]) if (streq (Memc[fname], "absolute")) reloff = false else if (streq (Memc[fname], "relative")) reloff = true goto newscan_ } call reset_scan () do j = 1, outdim { call gargr (val) offsets[i,j] = nint (val) } if (nscan() < outdim) call error (1, "IMCOMBINE: Error in offset list") } call close (fd) } # Set the output image size and the aligned flag aligned = true do j = 1, outdim { a = offsets[1,j] b = IM_LEN(in[1],j) + a amin = a bmax = b do i = 2, nimages { a = offsets[i,j] b = IM_LEN(in[i],j) + a if (a != amin || b != bmax || !reloff) aligned = false amin = min (a, amin) bmax = max (b, bmax) } IM_LEN(out[1],j) = bmax if (reloff || amin < 0) { do i = 1, nimages offsets[i,j] = offsets[i,j] - amin IM_LEN(out[1],j) = IM_LEN(out[1],j) - amin } } # Get the output limits. call clgstr ("outlimits", Memc[fname], SZ_FNAME) call sscan (Memc[fname]) do j = 1, outdim { call gargi (a) call gargi (b) if (nscan() < 2*j) break if (!IS_INDEFI(a)) { do i = 1, nimages { offsets[i,j] = offsets[i,j] - a + 1 if (offsets[i,j] != 0) aligned = false } IM_LEN(out[1],j) = IM_LEN(out[1],j) - a + 1 } if (!IS_INDEFI(a) && !IS_INDEFI(b)) IM_LEN(out[1],j) = min (IM_LEN(out[1],j), b - a + 1) } # Update the WCS. if (proj || !aligned || !reloff) { call mw_close (mw) mw = mw_openim (out[1]) mwdim = mw_stati (mw, MW_NPHYSDIM) call mw_gaxmap (mw, Memi[axno], Memi[axval], mwdim) if (!aligned || !reloff) { call mw_gltermd (mw, Memd[cd], Memd[lref], mwdim) do i = 1, mwdim { j = Memi[axno+i-1] if (j > 0 && j <= indim) Memd[lref+i-1] = Memd[lref+i-1] + offsets[1,j] } if (proj) Memd[lref+mwdim-1] = 0. call mw_sltermd (mw, Memd[cd], Memd[lref], mwdim) } if (proj) { # Apply dimensional reduction. do i = 1, mwdim { j = Memi[axno+i-1] if (j <= outdim) next else if (j > outdim+1) Memi[axno+i-1] = j - 1 else { Memi[axno+i-1] = 0 Memi[axval+i-1] = 0 } } call mw_saxmap (mw, Memi[axno], Memi[axval], mwdim) } # Reset physical coordinates. if (offtype == WCS || offtype == WORLD) { call mw_gltermd (mw, Memd[ltm], Memd[ltv], mwdim) call mw_gwtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) call mwvmuld (Memd[ltm], Memd[lref], Memd[lref], mwdim) call aaddd (Memd[lref], Memd[ltv], Memd[lref], mwdim) call mwinvertd (Memd[ltm], Memd[ltm], mwdim) call mwmmuld (Memd[cd], Memd[ltm], Memd[cd], mwdim) call mw_swtermd (mw, Memd[lref], Memd[wref], Memd[cd], mwdim) call aclrd (Memd[ltv], mwdim) call aclrd (Memd[ltm], mwdim*mwdim) do i = 1, mwdim Memd[ltm+(i-1)*(mwdim+1)] = 1. call mw_sltermd (mw, Memd[ltm], Memd[ltv], mwdim) } call mw_saveim (mw, out) } call mw_close (mw) # Throw an error if the output size is too large. if (offtype != NONE) { npix = IM_LEN(out[1],1) do i = 2, outdim npix = npix * IM_LEN(out[1],i) if (npix > 1000000000) call error (1, "Output has more than 1 Gpixels (check offsets)") } call sfree (sp) end mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icsigma.gx000066400000000000000000000050701332166314300227510ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "../icombine.h" $for (sird) # IC_SIGMA -- Compute the sigma image line. # The estimated sigma includes a correction for the finite population. # Weights are used if desired. procedure ic_sigma$t (d, m, n, wts, npts, average, sigma) pointer d[ARB] # Data pointers pointer m[ARB] # Image ID pointers int n[npts] # Number of points real wts[ARB] # Weights int npts # Number of output points per line $if (datatype == sil) real average[npts] # Average real sigma[npts] # Sigma line (returned) $else PIXEL average[npts] # Average PIXEL sigma[npts] # Sigma line (returned) $endif int i, j, k, n1 real wt, sigcor, sumwt $if (datatype == sil) real a, sum $else PIXEL a, sum $endif include "../icombine.com" begin if (dflag == D_ALL) { n1 = n[1] if (dowts) { if (n1 > 1) sigcor = real (n1) / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Mem$t[d[1]+k] - a) ** 2 * wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt } sigma[i] = sqrt (sum * sigcor) } } else { if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. do i = 1, npts { k = i - 1 a = average[i] sum = (Mem$t[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Mem$t[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } } } else if (dflag == D_NONE) { do i = 1, npts sigma[i] = blank } else { if (dowts) { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = real (n1) / real (n1 -1) else sigcor = 1 a = average[i] wt = wts[Memi[m[1]+k]] sum = (Mem$t[d[1]+k] - a) ** 2 * wt sumwt = wt do j = 2, n1 { wt = wts[Memi[m[j]+k]] sum = sum + (Mem$t[d[j]+k] - a) ** 2 * wt sumwt = sumwt + wt } if (sumwt > 0) sigma[i] = sqrt (sum / sumwt * sigcor) else { sum = (Mem$t[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Mem$t[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum / n1 * sigcor) } } else sigma[i] = blank } } else { do i = 1, npts { n1 = n[i] if (n1 > 0) { k = i - 1 if (n1 > 1) sigcor = 1. / real (n1 - 1) else sigcor = 1. a = average[i] sum = (Mem$t[d[1]+k] - a) ** 2 do j = 2, n1 sum = sum + (Mem$t[d[j]+k] - a) ** 2 sigma[i] = sqrt (sum * sigcor) } else sigma[i] = blank } } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icsort.gx000066400000000000000000000177661332166314300226570ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. define LOGPTR 32 # log2(maxpts) (4e9) $for (sird) # IC_SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. procedure ic_sort$t (a, b, nvecs, npts) pointer a[ARB] # pointer to input vectors PIXEL b[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors PIXEL pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR] define swap {temp=$1;$1=$2;$2=temp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix b[i] = Mem$t[a[i]+l] # Special cases $if (datatype == x) if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (abs (temp) < abs (pivot)) { b[1] = temp b[2] = pivot } else next } else { temp3 = b[3] if (abs (temp) < abs (pivot)) { # bac|bca|cba if (abs (temp) < abs (temp3)) { # bac|bca b[1] = temp if (abs (pivot) < abs (temp3)) # bac b[2] = pivot else { # bca b[2] = temp3 b[3] = pivot } } else { # cba b[1] = temp3 b[3] = pivot } } else if (abs (temp3) < abs (temp)) { # acb|cab b[3] = temp if (abs (pivot) < abs (temp3)) # acb b[2] = temp3 else { # cab b[1] = temp3 b[2] = pivot } } else next } goto copy_ } $else if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) # bac b[2] = pivot else { # bca b[2] = temp3 b[3] = pivot } } else { # cba b[1] = temp3 b[3] = pivot } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) # acb b[2] = temp3 else { # cab b[1] = temp3 b[2] = pivot } } else next } goto copy_ } $endif # General case do i = 1, npix b[i] = Mem$t[a[i]+l] lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]) pivot = b[j] # pivot line while (i < j) { $if (datatype == x) for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) $else for (i=i+1; b[i] < pivot; i=i+1) $endif ; for (j=j-1; j > i; j=j-1) $if (datatype == x) if (abs(b[j]) <= abs(pivot)) $else if (b[j] <= pivot) $endif break if (i < j) # out of order pair swap (b[i], b[j]) # interchange elements } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix Mem$t[a[i]+l] = b[i] } end # IC_2SORT -- Quicksort. This is based on the VOPS asrt except that # the input is an array of pointers to image lines and the sort is done # across the image lines at each point along the lines. The number of # valid pixels at each point is allowed to vary. The cases of 1, 2, and 3 # pixels per point are treated specially. A second integer set of # vectors is sorted. procedure ic_2sort$t (a, b, c, d, nvecs, npts) pointer a[ARB] # pointer to input vectors PIXEL b[ARB] # work array pointer c[ARB] # pointer to associated integer vectors int d[ARB] # work array int nvecs[npts] # number of vectors int npts # number of points in vectors PIXEL pivot, temp, temp3 int i, j, k, l, p, npix, lv[LOGPTR], uv[LOGPTR], itemp define swap {temp=$1;$1=$2;$2=temp} define iswap {itemp=$1;$1=$2;$2=itemp} define copy_ 10 begin do l = 0, npts-1 { npix = nvecs[l+1] if (npix <= 1) next do i = 1, npix { b[i] = Mem$t[a[i]+l] d[i] = Memi[c[i]+l] } # Special cases $if (datatype == x) if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (abs (temp) < abs (pivot)) { b[1] = temp b[2] = pivot iswap (d[1], d[2]) } else next } else { temp3 = b[3] if (abs (temp) < abs (pivot)) { # bac|bca|cba if (abs (temp) < abs (temp3)) { # bac|bca b[1] = temp if (abs (pivot) < abs (temp3)) { # bac b[2] = pivot iswap (d[1], d[2]) } else { # bca b[2] = temp3 b[3] = pivot itemp = d[2] d[2] = d[3] d[3] = d[1] d[1] = itemp } } else { # cba b[1] = temp3 b[3] = pivot iswap (d[1], d[3]) } } else if (abs (temp3) < abs (temp)) { # acb|cab b[3] = temp if (abs (pivot) < abs (temp3)) { # acb b[2] = temp3 iswap (d[2], d[3]) } else { # cab b[1] = temp3 b[2] = pivot itemp = d[2] d[2] = d[1] d[1] = d[3] d[3] = itemp } } else next } goto copy_ } $else if (npix <= 3) { pivot = b[1] temp = b[2] if (npix == 2) { if (temp < pivot) { b[1] = temp b[2] = pivot iswap (d[1], d[2]) } else next } else { temp3 = b[3] if (temp < pivot) { # bac|bca|cba if (temp < temp3) { # bac|bca b[1] = temp if (pivot < temp3) { # bac b[2] = pivot iswap (d[1], d[2]) } else { # bca b[2] = temp3 b[3] = pivot itemp = d[2] d[2] = d[3] d[3] = d[1] d[1] = itemp } } else { # cba b[1] = temp3 b[3] = pivot iswap (d[1], d[3]) } } else if (temp3 < temp) { # acb|cab b[3] = temp if (pivot < temp3) { # acb b[2] = temp3 iswap (d[2], d[3]) } else { # cab b[1] = temp3 b[2] = pivot itemp = d[2] d[2] = d[1] d[1] = d[3] d[3] = itemp } } else next } goto copy_ } $endif # General case lv[1] = 1 uv[1] = npix p = 1 while (p > 0) { if (lv[p] >= uv[p]) # only one elem in this subset p = p - 1 # pop stack else { # Dummy do loop to trigger the Fortran optimizer. do p = p, ARB { i = lv[p] - 1 j = uv[p] # Select as the pivot the element at the center of the # array, to avoid quadratic behavior on an already # sorted array. k = (lv[p] + uv[p]) / 2 swap (b[j], b[k]); swap (d[j], d[k]) pivot = b[j] # pivot line while (i < j) { $if (datatype == x) for (i=i+1; abs(b[i]) < abs(pivot); i=i+1) $else for (i=i+1; b[i] < pivot; i=i+1) $endif ; for (j=j-1; j > i; j=j-1) $if (datatype == x) if (abs(b[j]) <= abs(pivot)) $else if (b[j] <= pivot) $endif break if (i < j) { # out of order pair swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) } } j = uv[p] # move pivot to position i swap (b[i], b[j]) # interchange elements swap (d[i], d[j]) if (i-lv[p] < uv[p] - i) { # stack so shorter done first lv[p+1] = lv[p] uv[p+1] = i - 1 lv[p] = i + 1 } else { lv[p+1] = i + 1 uv[p+1] = uv[p] uv[p] = i - 1 } break } p = p + 1 # push onto stack } } copy_ do i = 1, npix { Mem$t[a[i]+l] = b[i] Memi[c[i]+l] = d[i] } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/icstat.gx000066400000000000000000000135721332166314300226320ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "../icombine.h" define NMAX 100000 # Maximum number of pixels to sample $for (sird) # IC_STAT -- Compute image statistics within specified section. # The image section is relative to a reference image which may be # different than the input image and may have an offset. Only a # subsample of pixels is used. Masked and thresholded pixels are # ignored. Only the desired statistics are computed to increase # efficiency. procedure ic_stat$t (im, imref, section, offsets, image, nimages, domode, domedian, domean, mode, median, mean) pointer im # Data image pointer imref # Reference image for image section char section[ARB] # Image section int offsets[nimages,ARB] # Image section offset from data to reference int image # Image index (for mask I/O) int nimages # Number of images in offsets. bool domode, domedian, domean # Statistics to compute real mode, median, mean # Statistics int i, j, ndim, n, nv real a pointer sp, v1, v2, dv, va, vb pointer data, mask, dp, lp, mp, imgnl$t() $if (datatype == csir) real asum$t() $else $if (datatype == ld) double asum$t() $else PIXEL asum$t() $endif $endif PIXEL ic_mode$t() include "../icombine.com" begin call smark (sp) call salloc (v1, IM_MAXDIM, TY_LONG) call salloc (v2, IM_MAXDIM, TY_LONG) call salloc (dv, IM_MAXDIM, TY_LONG) call salloc (va, IM_MAXDIM, TY_LONG) call salloc (vb, IM_MAXDIM, TY_LONG) # Determine the image section parameters. This must be in terms of # the data image pixel coordinates though the section may be specified # in terms of the reference image coordinates. Limit the number of # pixels in each dimension to a maximum. ndim = IM_NDIM(im) if (project) ndim = ndim - 1 call amovki (1, Memi[v1], IM_MAXDIM) call amovki (1, Memi[va], IM_MAXDIM) call amovki (1, Memi[dv], IM_MAXDIM) call amovi (IM_LEN(imref,1), Memi[vb], ndim) call ic_section (section, Memi[va], Memi[vb], Memi[dv], ndim) if (im != imref) do i = 1, ndim { Memi[va+i-1] = Memi[va+i-1] - offsets[image,i] Memi[vb+i-1] = Memi[vb+i-1] - offsets[image,i] } do j = 1, 10 { n = 1 do i = 0, ndim-1 { Memi[v1+i] = max (1, min (Memi[va+i], Memi[vb+i])) Memi[v2+i] = min (IM_LEN(im,i+1), max (Memi[va+i], Memi[vb+i])) Memi[dv+i] = j nv = max (1, (Memi[v2+i] - Memi[v1+i]) / Memi[dv+i] + 1) Memi[v2+i] = Memi[v1+i] + (nv - 1) * Memi[dv+i] n = n * nv } if (n < NMAX) break } call amovl (Memi[v1], Memi[va], IM_MAXDIM) Memi[va] = 1 if (project) Memi[va+ndim] = image call amovl (Memi[va], Memi[vb], IM_MAXDIM) # Accumulate the pixel values within the section. Masked pixels and # thresholded pixels are ignored. call salloc (data, n, TY_PIXEL) dp = data while (imgnl$t (im, lp, Memi[vb]) != EOF) { call ic_mget1 (im, image, nimages, offsets[image,1], Memi[va], mask) lp = lp + Memi[v1] - 1 if (dflag == D_ALL) { if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { a = Mem$t[lp] if (a >= lthresh && a <= hthresh) { Mem$t[dp] = a dp = dp + 1 } lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { Mem$t[dp] = Mem$t[lp] dp = dp + 1 lp = lp + Memi[dv] } } } else if (dflag == D_MIX) { mp = mask + Memi[v1] - 1 if (dothresh) { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { a = Mem$t[lp] if (a >= lthresh && a <= hthresh) { Mem$t[dp] = a dp = dp + 1 } } mp = mp + Memi[dv] lp = lp + Memi[dv] } } else { do i = Memi[v1], Memi[v2], Memi[dv] { if (Memi[mp] == 0) { Mem$t[dp] = Mem$t[lp] dp = dp + 1 } mp = mp + Memi[dv] lp = lp + Memi[dv] } } } for (i=2; i<=ndim; i=i+1) { Memi[va+i-1] = Memi[va+i-1] + Memi[dv+i-1] if (Memi[va+i-1] <= Memi[v2+i-1]) break Memi[va+i-1] = Memi[v1+i-1] } if (i > ndim) break call amovl (Memi[va], Memi[vb], IM_MAXDIM) } # Close mask until it is needed again. call ic_mclose1 (image, nimages) n = dp - data if (n < 1) { call sfree (sp) call error (1, "Image section contains no pixels") } # Compute only statistics needed. if (domode || domedian) { call asrt$t (Mem$t[data], Mem$t[data], n) mode = ic_mode$t (Mem$t[data], n) median = Mem$t[data+n/2-1] } if (domean) mean = asum$t (Mem$t[data], n) / n call sfree (sp) end define NMIN 10 # Minimum number of pixels for mode calculation define ZRANGE 0.7 # Fraction of pixels about median to use define ZSTEP 0.01 # Step size for search for mode define ZBIN 0.1 # Bin size for mode. # IC_MODE -- Compute mode of an array. The mode is found by binning # with a bin size based on the data range over a fraction of the # pixels about the median and a bin step which may be smaller than the # bin size. If there are too few points the median is returned. # The input array must be sorted. PIXEL procedure ic_mode$t (a, n) PIXEL a[n] # Data array int n # Number of points int i, j, k, nmax real z1, z2, zstep, zbin PIXEL mode bool fp_equalr() begin if (n < NMIN) return (a[n/2]) # Compute the mode. The array must be sorted. Consider a # range of values about the median point. Use a bin size which # is ZBIN of the range. Step the bin limits in ZSTEP fraction of # the bin size. i = 1 + n * (1. - ZRANGE) / 2. j = 1 + n * (1. + ZRANGE) / 2. z1 = a[i] z2 = a[j] if (fp_equalr (z1, z2)) { mode = z1 return (mode) } zstep = ZSTEP * (z2 - z1) zbin = ZBIN * (z2 - z1) $if (datatype == sil) zstep = max (1., zstep) zbin = max (1., zbin) $endif z1 = z1 - zstep k = i nmax = 0 repeat { z1 = z1 + zstep z2 = z1 + zbin for (; i < j && a[i] < z1; i=i+1) ; for (; k < j && a[k] < z2; k=k+1) ; if (k - i > nmax) { nmax = k - i mode = a[(i+k)/2] } } until (k >= j) return (mode) end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/mkpkg000066400000000000000000000044711332166314300220350ustar00rootroot00000000000000# Make the IMCOMBINE library. update: $checkout libcombine.a mscbin$ $update libcombine.a $checkin libcombine.a mscbin$ ; 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/icquad.x, icquad.gx) $(GEN) icquad.gx -o generic/icquad.x $endif $ifolder (generic/icnmodel.x, icnmodel.gx) $(GEN) icnmodel.gx -o generic/icnmodel.x $endif $ifolder (generic/iccclip.x, iccclip.gx) $(GEN) iccclip.gx -o generic/iccclip.x $endif $ifolder (generic/icgdata.x, icgdata.gx) $(GEN) icgdata.gx -o generic/icgdata.x $endif $ifolder (generic/icgrow.x, icgrow.gx) $(GEN) icgrow.gx -o generic/icgrow.x $endif $ifolder (generic/icmedian.x, icmedian.gx) $(GEN) icmedian.gx -o generic/icmedian.x $endif $ifolder (generic/icmm.x, icmm.gx) $(GEN) icmm.gx -o generic/icmm.x $endif $ifolder (generic/icomb.x, icomb.gx) $(GEN) icomb.gx -o generic/icomb.x $endif $ifolder (generic/icpclip.x, icpclip.gx) $(GEN) icpclip.gx -o generic/icpclip.x $endif $ifolder (generic/icsclip.x, icsclip.gx) $(GEN) icsclip.gx -o generic/icsclip.x $endif $ifolder (generic/icsigma.x, icsigma.gx) $(GEN) icsigma.gx -o generic/icsigma.x $endif $ifolder (generic/icsort.x, icsort.gx) $(GEN) icsort.gx -o generic/icsort.x $endif $ifolder (generic/icstat.x, icstat.gx) $(GEN) icstat.gx -o generic/icstat.x $endif $ifolder (generic/xtimmap.x, xtimmap.gx) $(GEN) xtimmap.gx -o generic/xtimmap.x $endif ; libcombine.a: $ifeq (USE_GENERIC, yes) $call generic $endif @generic icemask.x icgscale.x icombine.com icombine.h ichdr.x icimstack.x iclog.x icmask.h icombine.com icombine.h \ icmask.x icmask.h icombine.com icombine.h icombine.x icombine.com icombine.h icpmmap.x icrmasks.x icscale.x icombine.com icombine.h icsection.x icsetout.x icombine.com tymax.x xtprocid.x ; mscred-5.05-2018.07.09/src/ccdred/src/combine/src/tymax.x000066400000000000000000000011341332166314300223250ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include # 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 mscred-5.05-2018.07.09/src/ccdred/src/combine/src/xtimmap.gx000066400000000000000000000343051332166314300230170ustar00rootroot00000000000000include include include include include # The following is for compiling under V2.11. define IM_BUFFRAC IM_BUFSIZE include define VERBOSE false # These routines maintain an arbitrary number of indexed "open" images which # must be READ_ONLY. The calling program may use the returned pointer for # header accesses but must call xt_opix before I/O. Subsequent calls to # xt_opix may invalidate the pointer. The xt_imunmap call will free memory. define MAX_OPENIM (LAST_FD-16) # Maximum images kept open define MAX_OPENPIX 45 # Maximum pixel files kept open define XT_SZIMNAME 299 # Size of IMNAME string define XT_LEN 179 # Structure length define XT_IMNAME Memc[P2C($1)] # Image name define XT_ARG Memi[$1+150] # IMMAP header argument define XT_IM Memi[$1+151] # IMIO pointer define XT_HDR Memi[$1+152] # Copy of IMIO pointer define XT_CLOSEFD Memi[$1+153] # Close FD? define XT_FLAG Memi[$1+154] # Flag define XT_BUFSIZE Memi[$1+155] # Buffer size define XT_BUF Memi[$1+156] # Data buffer define XT_BTYPE Memi[$1+157] # Data buffer type define XT_VS Memi[$1+157+$2] # Start vector (10) define XT_VE Memi[$1+167+$2] # End vector (10) # Options define XT_MAPUNMAP 1 # Map and unmap images. # XT_IMMAP -- Map an image and save it as an indexed open image. # The returned pointer may be used for header access but not I/O. # The indexed image is closed by xt_imunmap. pointer procedure xt_immap (imname, acmode, hdr_arg, index, retry) char imname[ARB] #I Image name int acmode #I Access mode int hdr_arg #I Header argument int index #I Save index int retry #I Retry counter pointer im #O Image pointer (returned) int i, envgeti() pointer xt, xt_opix() errchk xt_opix int first_time data first_time /YES/ include "xtimmap.com" begin if (acmode != READ_ONLY) call error (1, "XT_IMMAP: Only READ_ONLY allowed") # Set maximum number of open images based on retry. if (retry > 0) max_openim = min (1024, MAX_OPENIM) / retry else max_openim = MAX_OPENIM # Initialize once per process. if (first_time == YES) { iferr (option = envgeti ("imcombine_option")) option = 1 min_open = 1 nopen = 0 nopenpix = 0 nalloc = max_openim call calloc (ims, nalloc, TY_POINTER) first_time = NO } # Free image if needed. call xt_imunmap (NULL, index) # Allocate structure. if (index > nalloc) { i = nalloc nalloc = index + max_openim call realloc (ims, nalloc, TY_STRUCT) call amovki (NULL, Memi[ims+i], nalloc-i) } call calloc (xt, XT_LEN, TY_STRUCT) Memi[ims+index-1] = xt # Initialize. call strcpy (imname, XT_IMNAME(xt), XT_SZIMNAME) XT_ARG(xt) = hdr_arg XT_IM(xt) = NULL XT_HDR(xt) = NULL # Open image. last_flag = 0 im = xt_opix (NULL, index, 0) # Make copy of IMIO pointer for header keyword access. call malloc (XT_HDR(xt), LEN_IMDES+IM_HDRLEN(im)+1, TY_STRUCT) call amovi (Memi[im], Memi[XT_HDR(xt)], LEN_IMDES) call amovi (IM_MAGIC(im), IM_MAGIC(XT_HDR(xt)), IM_HDRLEN(im)+1) return (XT_HDR(xt)) end # XT_OPIX -- Open the image for I/O. # If the image has not been mapped return the default pointer. pointer procedure xt_opix (imdef, index, flag) int index #I index pointer imdef #I Default pointer int flag #I Flag int i, open(), imstati() pointer im, xt, xt1, immap() errchk open, immap, imunmap include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imdef) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_opix imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Return pointer for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (im) } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || flag == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next if (VERBOSE) { call eprintf ("%d: imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_opix immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im if (!IS_INDEFI(XT_BUFSIZE(xt))) call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) else XT_BUFSIZE(xt) = imstati (im, IM_BUFSIZE) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (im) end # XT_CPIX -- Close image. procedure xt_cpix (index) int index #I index pointer xt errchk imunmap include "xtimmap.com" begin xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) return if (XT_IM(xt) != NULL) { if (VERBOSE) { call eprintf ("%d: xt_cpix imunmap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } call imunmap (XT_IM(xt)) nopen = nopen - 1 if (XT_CLOSEFD(xt) == NO) nopenpix = nopenpix - 1 } call mfree (XT_BUF(xt), XT_BTYPE(xt)) end # XT_IMSETI -- Set IMIO value. procedure xt_imseti (index, param, value) int index #I index int param #I IMSET parameter int value #I Value pointer xt bool streq() include "xtimmap.com" begin xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) { if (streq (param, "option")) option = value } else { if (streq (param, "bufsize")) { XT_BUFSIZE(xt) = value if (XT_IM(xt) != NULL) { call imseti (XT_IM(xt), IM_BUFFRAC, 0) call imseti (XT_IM(xt), IM_BUFSIZE, value) } } } end # XT_IMUNMAP -- Unmap indexed open image. # The header pointer is set to NULL to indicate the image has been closed. procedure xt_imunmap (im, index) int im #U IMIO header pointer int index #I index pointer xt errchk imunmap include "xtimmap.com" begin # Check for an indexed image. If it is not unmap the pointer # as a regular IMIO pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) { if (im != NULL) call imunmap (im) return } # Close indexed image. if (XT_IM(xt) != NULL) { if (VERBOSE) { call eprintf ("%d: xt_imunmap imunmap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } iferr (call imunmap (XT_IM(xt))) { XT_IM(xt) = NULL call erract (EA_WARN) } nopen = nopen - 1 if (XT_CLOSEFD(xt) == NO) nopenpix = nopenpix - 1 if (index == min_open) min_open = 1 } # Free any buffered memory. call mfree (XT_BUF(xt), XT_BTYPE(xt)) # Free header pointer. Note that if the supplied pointer is not # header pointer then it is not set to NULL. if (XT_HDR(xt) == im) im = NULL call mfree (XT_HDR(xt), TY_STRUCT) # Free save structure. call mfree (Memi[ims+index-1], TY_STRUCT) Memi[ims+index-1] = NULL end # XT_MINHDR -- Minimize header assuming keywords will not be accessed. procedure xt_minhdr (index) int index #I index pointer xt errchk realloc include "xtimmap.com" begin # Check for an indexed image. If it is not unmap the pointer # as a regular IMIO pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] if (xt == NULL) return # Minimize header pointer. if (VERBOSE) { call eprintf ("%d: xt_minhdr %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } call realloc (XT_HDR(xt), IMU+1, TY_STRUCT) if (XT_IM(xt) != NULL) call realloc (XT_IM(xt), IMU+1, TY_STRUCT) end # XT_REINDEX -- Reindex open images. # This is used when some images are closed by xt_imunmap. It is up to # the calling program to reindex the header pointers and to subsequently # use the new index values. procedure xt_reindex () int old, new include "xtimmap.com" begin new = 0 do old = 0, nalloc-1 { if (Memi[ims+old] == NULL) next Memi[ims+new] = Memi[ims+old] new = new + 1 } do old = new, nalloc-1 Memi[ims+old] = NULL end $for(sird) # XT_IMGNL -- Return the next line for the indexed image. # Possibly unmap another image if too many files are open. # Buffer data when an image is unmmaped to minimize the mapping of images. # If the requested index has not been mapped use the default pointer. int procedure xt_imgnl$t (imdef, index, buf, v, flag) pointer imdef #I Default pointer int index #I index pointer buf #O Data buffer long v[ARB] #I Line vector int flag #I Flag (=output line) int i, j, nc, nl, open(), imgnl$t(), sizeof(), imloop() pointer im, xt, xt1, ptr, immap(), imggs$t() errchk open, immap, imgnl$t, imggs$t, imunmap long unit_v[IM_MAXDIM] data unit_v /IM_MAXDIM * 1/ include "xtimmap.com" begin # Get index pointer. xt = NULL if (index <= nalloc && index > 0) xt = Memi[ims+index-1] # Use default pointer if index has not been mapped. if (xt == NULL) return (imgnl$t (imdef, buf, v)) # Close images not accessed during previous line. # In normal usage this should only occur once per line over all # indexed images. if (flag != last_flag) { do i = 1, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL || XT_FLAG(xt1) == last_flag) next if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) call mfree (XT_BUF(xt1), XT_BTYPE(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 } # Optimize the file I/O. do i = nalloc, 1, -1 { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next min_open = i if (nopenpix < MAX_OPENPIX) { if (XT_CLOSEFD(xt1) == NO) next XT_CLOSEFD(xt1) = NO call imseti (im, IM_CLOSEFD, NO) nopenpix = nopenpix + 1 } } last_flag = flag } # Use IMIO for already opened images. im = XT_IM(xt) if (im != NULL) { XT_FLAG(xt) = flag return (imgnl$t (im, buf, v)) } # If the image is not currently mapped use the stored header. im = XT_HDR(xt) # Check for EOF. i = IM_NDIM(im) if (v[i] > IM_LEN(im,i)) return (EOF) # Check for buffered data. if (XT_BUF(xt) != NULL) { if (v[2] >= XT_VS(xt,2) && v[2] <= XT_VE(xt,2)) { if (XT_BTYPE(xt) != TY_PIXEL) call error (1, "Cannot mix data types") nc = IM_LEN(im,1) buf = XT_BUF(xt) + (v[2]-XT_VS(xt,2)) * IM_LEN(im,1) XT_FLAG(xt) = flag if (i == 1) v[1] = nc + 1 else j = imloop (v, unit_v, IM_LEN(im,1), unit_v, i) return (nc) } } # Handle more images than the maximum that can be open at one time. if (nopen >= max_openim) { if (option == XT_MAPUNMAP || v[2] == 0) { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next im = XT_IM(xt1) if (im == NULL) next # Buffer some number of lines. nl = XT_BUFSIZE(xt1) / sizeof (TY_PIXEL) / IM_LEN(im,1) if (nl > 1) { nc = IM_LEN(im,1) call amovl (v, XT_VS(xt1,1), IM_MAXDIM) call amovl (v, XT_VE(xt1,1), IM_MAXDIM) XT_VS(xt1,1) = 1 XT_VE(xt1,1) = nc XT_VE(xt1,2) = min (XT_VS(xt1,2)+(nl-1), IM_LEN(im,2)) nl = XT_VE(xt1,2) - XT_VS(xt1,2) + 1 XT_BTYPE(xt1) = TY_PIXEL call malloc (XT_BUF(xt1), nl*nc, XT_BTYPE(xt1)) ptr = imggs$t (im, XT_VS(xt1,1), XT_VE(xt1,1), IM_NDIM(im)) call amov$t (Mem$t[ptr], Mem$t[XT_BUF(xt1)], nl*nc) } if (VERBOSE) { call eprintf ("%d: xt_imgnl imunmap %s\n") call pargi (i) call pargstr (XT_IMNAME(xt1)) } call imunmap (XT_IM(xt1)) nopen = nopen - 1 if (XT_CLOSEFD(xt1) == NO) nopenpix = nopenpix - 1 min_open = i + 1 break } if (index <= min_open) min_open = index else { do i = min_open, nalloc { xt1 = Memi[ims+i-1] if (xt1 == NULL) next if (XT_IM(xt1) == NULL) next min_open = i break } } } else { # Check here because we can't catch error in immap. i = open ("dev$null", READ_ONLY, BINARY_FILE) call close (i) if (i == LAST_FD - 1) call error (SYS_FTOOMANYFILES, "Too many open files") } } # Open image. if (VERBOSE) { call eprintf ("%d: xt_imgnl immap %s\n") call pargi (index) call pargstr (XT_IMNAME(xt)) } im = immap (XT_IMNAME(xt), READ_ONLY, XT_ARG(xt)) XT_IM(xt) = im call imseti (im, IM_BUFSIZE, XT_BUFSIZE(xt)) call mfree (XT_BUF(xt), XT_BTYPE(xt)) nopen = nopen + 1 XT_CLOSEFD(xt) = YES if (nopenpix < MAX_OPENPIX) { XT_CLOSEFD(xt) = NO nopenpix = nopenpix + 1 } if (XT_CLOSEFD(xt) == YES) call imseti (im, IM_CLOSEFD, YES) XT_FLAG(xt) = flag return (imgnl$t (im, buf, v)) end $endfor mscred-5.05-2018.07.09/src/ccdred/src/combine/src/xtprocid.x000066400000000000000000000014711332166314300230230ustar00rootroot00000000000000# XT_PROCID -- Set or ppdate PROCID keyword. procedure xt_procid (im) pointer im #I Image header int i, j, ver, patmake(), gpatmatch(), strlen(), ctoi() pointer sp, pat, str begin call smark (sp) call salloc (pat, SZ_LINE, TY_CHAR) call salloc (str, SZ_FNAME, TY_CHAR) # Get current ID. iferr (call imgstr (im, "PROCID", Memc[str], SZ_LINE)) { iferr (call imgstr (im, "OBSID", Memc[str], SZ_LINE)) { call sfree (sp) return } } # Set new PROCID. ver = 0 i = patmake ("V[0-9]*$", Memc[pat], SZ_LINE) if (gpatmatch (Memc[str], Memc[pat], i, j) == 0) ; if (j > 0) { j = i+1 if (ctoi (Memc[str], j, ver) == 0) ver = 0 i = i - 1 } else i = strlen (Memc[str]) call sprintf (Memc[str+i], SZ_LINE, "V%d") call pargi (ver+1) call imastr (im, "PROCID", Memc[str]) end mscred-5.05-2018.07.09/src/ccdred/src/combine/t_combine.x000066400000000000000000001303451332166314300223420ustar00rootroot00000000000000include include include include include include "../ccdred.h" include "src/icombine.h" # Symbol table definitions from hdrmap.x. 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 define GRPAMP 1 # Group by amplifier define GRPCCD 2 # Group by ccd define ONEIMAGE 99 # Error code for one image to combine # T_COMBINE -- Combine images. procedure t_combine () int i, list, nout, imtopenp() pointer sp, fname, outnames errchk cmbine int grp common /grpcom/ grp begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) # Get the list of images and open the header translation which # is needed to determine the amps, ccds, subsets and ccdtypes. call clgstr ("instrument", Memc[fname], SZ_FNAME) call hdmopen (Memc[fname]) grp = GRPAMP list = imtopenp ("input") call clgstr ("output", Memc[fname], SZ_FNAME) call xt_imroot (Memc[fname], Memc[fname], SZ_FNAME) iferr (call cmbine (list, Memc[fname], YES, outnames, nout)) call erract (EA_WARN) do i = 1, nout call mfree (Memi[outnames+i-1], TY_CHAR) call mfree (outnames, TY_POINTER) call imtclose (list) call hdmclose () call sfree (sp) end # T_COUTPUT -- List of output images. procedure t_coutput () int list, imtopenp() pointer sp, fname int grp common /grpcom/ grp begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) # Get the list of images and open the header translation which # is needed to determine the amps, ccds, subsets and ccdtypes. call clgstr ("instrument", Memc[fname], SZ_FNAME) call hdmopen (Memc[fname]) grp = GRPAMP list = imtopenp ("input") call clgstr ("output", Memc[fname], SZ_FNAME) call xt_stripwhite (Memc[fname]) iferr (call coutput (list, Memc[fname])) call erract (EA_WARN) call imtclose (list) call hdmclose () call sfree (sp) end # T_AMPMERGE -- Merge amplifiers from multiple amp per CCD data. # # It merges extensions with the same ccd. # If all extensions merge to a single image then a single image format is # produced. procedure t_ampmerge () int i, j, fd, nout, nmerge, inlist, outlist, bplist, list1 real c1, c2, c3, c4, l1, l2, l3, l4, ltm[2,2], ltv[2] pointer sp, outnames, fname, input, output, outmask, outputs pointer im, mw, ct bool ccdflag() int imtopenp(), imtopen(), imtgetim(), imtlen(), imgeti() int open(), errcode(), nowhite() real imgetr() pointer immap(), mw_openim(), mw_sctran() errchk open, cmbine, immap, imgetr, maskmerge int grp common /grpcom/ grp define skip_ 10 begin call smark (sp) call salloc (outnames, SZ_FNAME, TY_CHAR) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (input, SZ_FNAME, TY_CHAR) call salloc (output, SZ_FNAME, TY_CHAR) call salloc (outmask, SZ_FNAME, TY_CHAR) # Get the list of images and open the header translation which # is needed to determine the amps, ccds, subsets and ccdtypes. call clgstr ("instrument", Memc[fname], SZ_FNAME) call hdmopen (Memc[fname]) grp = GRPCCD # Do each image separately. inlist = imtopenp ("input") outlist = imtopenp ("output") bplist = imtopenp ("outmasks") if (imtlen (inlist) != imtlen (outlist) && imtlen (outlist) != 1) call error (1, "Input and output lists don't match") if (imtlen (bplist) != 0 && imtlen (bplist) != imtlen (outlist)) call error (1, "Output data and mask lists don't match") call clgstr ("outnames", Memc[outnames], SZ_FNAME) i = nowhite (Memc[outnames], Memc[outnames], SZ_FNAME) fd = NULL while (imtgetim (outlist, Memc[output], SZ_FNAME) != EOF) { call xt_imroot (Memc[output], Memc[output], SZ_FNAME) if (imtgetim (inlist, Memc[input], SZ_FNAME) == EOF) break if (imtlen (outlist) == 1) { call imtrew (inlist) list1 = inlist } else list1 = imtopen (Memc[input]) if (imtgetim (bplist, Memc[outmask], SZ_FNAME) == EOF) Memc[outmask] = EOS outputs = NULL iferr { # Check processing. call sprintf (Memc[fname], SZ_FNAME, "%s[1]") call pargstr (Memc[input]) iferr (im = immap (Memc[fname], READ_ONLY, 0)) im = immap (Memc[input], READ_ONLY, 0) if (ccdflag (im, "ampmerge")) { call imunmap (im) goto skip_ } if (!ccdflag (im, "trim")) { call imunmap (im) call sprintf (Memc[fname], SZ_FNAME, "Data must be overscan corrected and trimmed for merging (%s)") call pargstr (Memc[input]) call error (1, Memc[fname]) } call imunmap (im) # Merge the amplifier images. iferr (call cmbine (list1, Memc[output], NO, outputs, nout)) { if (errcode() == ONEIMAGE) goto skip_ call erract (EA_ERROR) } # Update the headers. do i = 1, nout { do j = 0, ARB { call sprintf (Memc[fname], SZ_FNAME, "%s[%d]") call pargstr (Memc[Memi[outputs+i-1]]) call pargi (j) iferr (im = immap (Memc[fname], READ_WRITE, 0)) { switch (errcode()) { case SYS_FXFRFEOF, SYS_IKIOPEN: break case SYS_IKIEXTN: next default: call erract (EA_ERROR) } } # Write names if desired. if (fd == NULL && Memc[outnames] != EOS) fd = open (Memc[outnames], NEW_FILE, TEXT_FILE) if (j == 0 && fd != NULL) { call fprintf (fd, "%s\n") call pargstr (Memc[Memi[outputs+i-1]]) } iferr (call imdelf (im, "nextend")) ; if (IM_NDIM(im) == 0) { call imunmap (im) next } # Remove NEXTEND, NCOMBINE and put in AMPMERGE flag. iferr (call imdelf (im, "nextend")) ; iferr (nmerge = imgeti (im, "ncombine")) nmerge = 0 iferr (call imdelf (im, "ncombine")) ; call sprintf (Memc[fname], SZ_FNAME, "Merged %d amps") call pargi (nmerge) call timelog (Memc[fname], SZ_FNAME) call imastr (im, "ampmerge", Memc[fname]) # Update CCDSEC. mw = mw_openim (im) ct = mw_sctran (mw, "logical", "physical", 3) call mw_c2tranr (ct, 0.501, 0.501, c1, l1) call mw_c2tranr (ct, real(IM_LEN(im,1)+0.499), real(IM_LEN(im,2)+0.499), c2, l2) call sprintf (Memc[fname], SZ_FNAME, "[%d:%d,%d:%d]") call pargi (nint(c1)) call pargi (nint(c2)) call pargi (nint(l1)) call pargi (nint(l2)) call imastr (im, "ccdsec", Memc[fname]) call mw_ctfree (ct) # Update DETSEC. iferr { ltv[1] = imgetr (im, "dtv1") ltv[2] = imgetr (im, "dtv2") ltm[1,1] = imgetr (im, "dtm1_1") ltm[1,2] = 0. ltm[2,1] = 0. ltm[2,2] = imgetr (im, "dtm2_2") call mw_sltermr (mw, ltm, ltv, 2) ct = mw_sctran (mw, "physical", "logical", 3) call mw_c2tranr (ct, c1, l1, c3, l3) call mw_c2tranr (ct, c2, l2, c4, l4) call sprintf (Memc[fname], SZ_FNAME, "[%d:%d,%d:%d]") call pargi (nint(c3)) call pargi (nint(c4)) call pargi (nint(l3)) call pargi (nint(l4)) call imastr (im, "detsec", Memc[fname]) } then ; # Update AMPSEC. iferr { ltv[1] = imgetr (im, "atv1") ltv[2] = imgetr (im, "atv2") ltm[1,1] = imgetr (im, "atm1_1") ltm[1,2] = 0. ltm[2,1] = 0. ltm[2,2] = imgetr (im, "atm2_2") call mw_sltermr (mw, ltm, ltv, 2) ct = mw_sctran (mw, "physical", "logical", 3) call mw_c2tranr (ct, c1, l1, c3, l3) call mw_c2tranr (ct, c2, l2, c4, l4) call sprintf (Memc[fname], SZ_FNAME, "[%d:%d,%d:%d]") call pargi (nint(c3)) call pargi (nint(c4)) call pargi (nint(l3)) call pargi (nint(l4)) call imastr (im, "ampsec", Memc[fname]) } then ; call mw_close (mw) # Merge masks. if (Memc[outmask] != EOS) { ifnoerr (call imgstr (im, "EXTNAME", Memc[input], SZ_FNAME)) { if (nowhite (Memc[input], Memc[input], SZ_FNAME)==0) ; call sprintf (Memc[fname], SZ_FNAME, "bpmm_%s.pl") call pargstr (Memc[input]) call maskmerge (im, Memc[outmask], Memc[fname]) } else call maskmerge (im, "", Memc[outmask]) } call imunmap (im) } } skip_ i = 0 } then call erract (EA_WARN) if (imtlen (outlist) != 1) call imtclose (list1) if (outputs != NULL) { do i = 1, nout call mfree (Memi[outputs+i-1], TY_CHAR) call mfree (outputs, TY_POINTER) } } if (fd != NULL) call close (fd) call imtclose (inlist) call hdmclose () call sfree (sp) end # MASKMERGE -- Merge masks. procedure maskmerge (in, dir, output) pointer in #I Input merged image pointer char dir[ARB] #I Output directory name char output[ARB] #I Ouput mask name int i, j, n, nc pointer sp, outname, key, fname, fnames, im, ims, out, outbuf bool streq(), pm_empty() int access() pointer pm_open(), immap(), yt_pmmap(), impl2i(), imgl2i() errchk pm_loadim, immap, yt_pmmap, imgstr, imdelete, imrename, fmkdir begin if (output[1] == EOS) return call smark (sp) call salloc (outname, SZ_FNAME, TY_CHAR) call salloc (key, 8, TY_CHAR) call salloc (fname, SZ_FNAME, TY_CHAR) # Set the output name. call sprintf (Memc[outname], SZ_FNAME, "%s%s") call pargstr (dir) call pargstr (output) # Get the masks from the output image and the headers of the parent # images given by the IMCMB keywords. Get only unique and # non-empty masks. n = 0 do i = 0, ARB { if (i == 0) { iferr (call imgstr (in, "BPM", Memc[fname], SZ_FNAME)) next } else { call sprintf (Memc[key], 8, "IMCMB%03d") call pargi (i) iferr (call imgstr (in, Memc[key], Memc[fname], SZ_FNAME)) break im = immap (Memc[fname], READ_ONLY, 0) iferr (call imgstr (im, "BPM", Memc[fname], SZ_FNAME)) { call imunmap (im) next } call imunmap (im) } # Check if the mask has already been seen. do j = 0, n-1 if (streq (Memc[fname], Memc[Memi[fnames+j]])) break if (j < n) next # Check for an empty mask. im = pm_open (NULL) call pm_loadim (im, Memc[fname], Memc[key], 8) if (pm_empty (im)) { call pm_close (im) if (i == 0) { iferr { call imdelete (Memc[fname]) call imdelf (in, "BPM") } then ; } next } else call pm_close (im) # Save the name. if (fnames == NULL) call malloc (fnames, 10, TY_POINTER) else if (mod (n, 10) == 0) call realloc (fnames, n, TY_POINTER) Memi[fnames+n] = fname n = n + 1 call salloc (fname, SZ_FNAME, TY_CHAR) } # If there are no masks just return. if (n == 0) { call sfree (sp) return } # If there is only one mask just set the BPM keyword. if (n == 1) { iferr (call imgstr (in, "BPM", Memc[fname], SZ_FNAME)) Memc[fname] = EOS if (streq (Memc[fname], Memc[Memi[fnames]])) { if (dir[1] != EOS && access (dir, 0, 0) == NO) call fmkdir (dir) call imrename (Memc[fname], Memc[outname]) call imastr (in, "BPM", Memc[outname]) } else call imastr (in, "BPM", Memc[Memi[fnames]]) call mfree (fnames, TY_POINTER) call sfree (sp) return } # Combine the masks. call salloc (ims, n, TY_POINTER) call aclri (Memi[ims], n) iferr { # Map the masks and register them to the input image. do i = 0, n-1 { im = yt_pmmap (Memc[Memi[fnames+i]], in, Memc[fname], SZ_FNAME) Memi[ims+i] = im } # Map the output. if (dir[1] != EOS && access (dir, 0, 0) == NO) call fmkdir (dir) out = immap (Memc[outname], NEW_COPY, in) # Merge the masks using a maximum. nc = IM_LEN(in,1) do j = 1, IM_LEN(in,2) { outbuf = impl2i (out, j) call aclri (Memi[outbuf], nc) do i = 0, n-1 { im = Memi[ims+i] call amaxi (Memi[imgl2i(im,j)], Memi[outbuf], Memi[outbuf], nc) } } call imunmap (out) # Delete any existing BPM and set keyword to new BPM. iferr { call imgstr (in, "BPM", Memc[fname], SZ_FNAME) call imdelete (Memc[fname]) } then ; call imastr (in, "BPM", Memc[outname]) } then { call erract (EA_WARN) if (out != NULL) { call imunmap (out) iferr (call imdelete (Memc[outname])) ; } } # Finish up. do i = 0, n-1 { im = Memi[ims+i] if (im != NULL) call imunmap (im) } call mfree (fnames, TY_POINTER) call sfree (sp) end # CMBINE -- Combine images. # # This is a version of IMCOMBINE which groups data by CCD types, subsets # (such as filter), and amplifier. It also uses header keyword translation. # The main routine takes care of sorting the input (both individual images # and MEF files) by subset and amplifer using the routine cmb_images. It # then creates output root names and calls routines to do the combining of # each group. procedure cmbine (list, outroot, oneimage, outnames, nsubsets) int list # List of images char outroot[SZ_FNAME] # Output root image name int oneimage # Allow only a single image to combine? pointer outnames # Pointer to array of string pointers pointer subsets # Subsets pointer images # Images pointer hroot # Headers root name pointer broot # Bad pixel mask root name pointer rroot # Rejection pixel mask root name pointer nrroot # Number rejected mask root name pointer eroot # Exposure mask root name pointer sigroot # Sigma image name pointer logfile # Log filename pointer scales # Scales pointer zeros # Zeros pointer wts # Weights pointer extns # Image extensions for each subset pointer nimages # Number of images in each subset int nsubsets # Number of subsets int delete # Delete input images? int i, mef, list1 pointer sp, output, headers, bmask, rmask, nrmask, emask, sigma bool clgetb() int clgeti(), clgwrd(), btoi(), errcode(), ic_mklist(), imtgetim() real clgetr() errchk cmb_images, icombine, mefcombine, ic_mklist include "src/icombine.com" begin call smark (sp) call salloc (hroot, SZ_FNAME, TY_CHAR) call salloc (broot, SZ_FNAME, TY_CHAR) call salloc (rroot, SZ_FNAME, TY_CHAR) call salloc (nrroot, SZ_FNAME, TY_CHAR) call salloc (eroot, SZ_FNAME, TY_CHAR) call salloc (sigroot, SZ_FNAME, TY_CHAR) call salloc (logfile, SZ_FNAME, TY_CHAR) call salloc (headers, SZ_FNAME, TY_CHAR) call salloc (bmask, SZ_FNAME, TY_CHAR) call salloc (rmask, SZ_FNAME, TY_CHAR) call salloc (nrmask, SZ_FNAME, TY_CHAR) call salloc (emask, SZ_FNAME, TY_CHAR) call salloc (sigma, SZ_FNAME, TY_CHAR) call salloc (expkeyword, SZ_FNAME, TY_CHAR) call salloc (statsec, 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) # Get the input images. There must be a least one image to continue. call cmb_images (list, images, scales, zeros, wts, extns, subsets, nimages, nsubsets, mef) if (nsubsets == 0) { call cmb_images_free (images, scales, zeros, wts, extns, subsets, nimages, nsubsets) call error (0, "No data to combine") } # Check for more than one image. MEF files are handled later. if (mef == NO && oneimage == NO) { do i = 1, nsubsets { if (Memi[nimages+i-1] > 1) break } if (i > nsubsets) { call cmb_images_free (images, scales, zeros, wts, extns, subsets, nimages, nsubsets) call error (ONEIMAGE, "Only a single image to combine") return } } # Get task parameters. Some additional parameters are obtained later. call clgstr ("headers", Memc[hroot], SZ_FNAME) call clgstr ("bpmasks", Memc[broot], SZ_FNAME) call clgstr ("rejmasks", Memc[rroot], SZ_FNAME) call clgstr ("nrejmasks", Memc[nrroot], SZ_FNAME) call clgstr ("expmasks", Memc[eroot], SZ_FNAME) call clgstr ("sigmas", Memc[sigroot], SZ_FNAME) call clgstr ("logfile", Memc[logfile], SZ_FNAME) call xt_stripwhite (Memc[hroot]) call xt_stripwhite (Memc[broot]) call xt_stripwhite (Memc[rroot]) call xt_stripwhite (Memc[nrroot]) call xt_stripwhite (Memc[eroot]) call xt_stripwhite (Memc[sigroot]) call xt_stripwhite (Memc[logfile]) project = clgetb ("project") combine = clgwrd ("combine", Memc[statsec], SZ_FNAME, COMBINE) reject = clgwrd ("reject", Memc[statsec], SZ_FNAME, REJECT) blank = clgetr ("blank") call strcpy ("exptime", Memc[expkeyword], SZ_FNAME) call clgstr ("statsec", Memc[statsec], SZ_FNAME) call clgstr ("gain", Memc[gain], SZ_FNAME) call clgstr ("rdnoise", Memc[rdnoise], SZ_FNAME) call clgstr ("snoise", Memc[snoise], SZ_FNAME) lthresh = clgetr ("lthreshold") hthresh = clgetr ("hthreshold") lsigma = clgetr ("lsigma") pclip = clgetr ("pclip") flow = clgetr ("nlow") fhigh = clgetr ("nhigh") nkeep = clgeti ("nkeep") hsigma = clgetr ("hsigma") grow = clgetr ("grow") mclip = clgetb ("mclip") sigscale = clgetr ("sigscale") verbose = clgetb ("verbose") delete = btoi (clgetb ("delete")) # Translate keywords. call hdmname (Memc[expkeyword], Memc[expkeyword], SZ_FNAME) call hdmname (Memc[gain], Memc[gain], SZ_FNAME) call hdmname (Memc[rdnoise], Memc[rdnoise], SZ_FNAME) call hdmname (Memc[snoise], Memc[snoise], SZ_FNAME) # Check parameters, map INDEFs, and set threshold flag if (pclip == 0. && reject == PCLIP) call error (1, "Pclip parameter may not be zero") if (IS_INDEFR (blank)) blank = 0. if (IS_INDEFR (lsigma)) lsigma = MAX_REAL if (IS_INDEFR (hsigma)) hsigma = MAX_REAL if (IS_INDEFR (pclip)) pclip = -0.5 if (IS_INDEFR (flow)) flow = 0. if (IS_INDEFR (fhigh)) fhigh = 0. if (IS_INDEFR (grow)) grow = 0. if (IS_INDEF (sigscale)) sigscale = 0. if (IS_INDEF(lthresh) && IS_INDEF(hthresh)) dothresh = false else { dothresh = true if (IS_INDEF(lthresh)) lthresh = -MAX_REAL if (IS_INDEF(hthresh)) hthresh = MAX_REAL } # Combine each input subset. call calloc (outnames, nsubsets, TY_POINTER) do i = 1, nsubsets { # Set the output, names with subset extension. call malloc (Memi[outnames+i-1], SZ_FNAME, TY_CHAR) output = Memi[outnames+i-1] call strcpy (outroot, Memc[output], SZ_FNAME) call sprintf (Memc[output], SZ_FNAME, "%s%s") call pargstr (outroot) call pargstr (Memc[Memi[extns+i-1]]) call strcpy (Memc[hroot], Memc[headers], SZ_FNAME) if (Memc[headers] != EOS) { call sprintf (Memc[headers], SZ_FNAME, "%s%s") call pargstr (Memc[hroot]) call pargstr (Memc[Memi[extns+i-1]]) } call strcpy (Memc[broot], Memc[bmask], SZ_FNAME) if (Memc[bmask] != EOS) { call sprintf (Memc[bmask], SZ_FNAME, "%s%s") call pargstr (Memc[broot]) # 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[rroot], Memc[rmask], SZ_FNAME) if (Memc[rmask] != EOS) { call sprintf (Memc[rmask], SZ_FNAME, "%s%s") call pargstr (Memc[rroot]) # 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[nrroot], Memc[nrmask], SZ_FNAME) if (Memc[nrmask] != EOS) { call sprintf (Memc[nrmask], SZ_FNAME, "%s%s") call pargstr (Memc[nrmask]) # 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[eroot], Memc[emask], SZ_FNAME) if (Memc[emask] != EOS) { call sprintf (Memc[emask], SZ_FNAME, "%s%s") call pargstr (Memc[eroot]) # 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 { if (mef == YES) call mefcombine (Memc[Memi[images+i-1]], Memr[Memi[scales+i-1]], Memr[Memi[zeros+i-1]], Memr[Memi[wts+i-1]], Memi[nimages+i-1], Memc[output], Memc[headers], Memc[bmask], Memc[rmask], Memc[nrmask], Memc[emask], Memc[sigma], Memc[logfile], NO, delete, oneimage) else { list1 = ic_mklist (Memc[Memi[images+i-1]], Memi[nimages+i-1]) call icombine (list1, Memc[output], Memc[headers], Memc[bmask], Memc[rmask], Memc[nrmask], Memc[emask], Memc[sigma], Memc[logfile], Memr[Memi[scales+i-1]], Memr[Memi[zeros+i-1]], Memr[Memi[wts+i-1]], NO, NO, NO) if (!project && delete == YES) { call imtrew (list1) while (imtgetim (list1, Memc[output], SZ_FNAME) != EOF) call ccddelete (Memc[output]) } call imtclose (list1) } } then { if (errcode() == ONEIMAGE) call erract (EA_ERROR) call erract (EA_WARN) } call mfree (Memi[images+i-1], TY_CHAR) call mfree (Memi[scales+i-1], TY_REAL) call mfree (Memi[zeros+i-1], TY_REAL) call mfree (Memi[wts+i-1], TY_REAL) call mfree (Memi[extns+i-1], TY_CHAR) call mfree (Memi[subsets+i-1], TY_CHAR) } # Finish up. call cmb_images_free (images, scales, zeros, wts, extns, subsets, nimages, nsubsets) call sfree (sp) end # CMB_IMAGES_FREE -- Free memory allocated by CMB_IMAGES. procedure cmb_images_free (images, scales, zeros, wts, extns, subsets, nimages, nsubsets) pointer images #U Pointer to image names in subset pointer scales #U Pointer to scales in subset pointer zeros #U Pointer to zeros in subset pointer wts #U Pointer to weights in subset pointer extns #U Pointer to extension name in subset pointer subsets #U Pointer to subset name in subset pointer nimages #U Pointer to number of images in subset int nsubsets #I Number of subsets int i begin do i = 1, nsubsets { call mfree (Memi[images+i-1], TY_CHAR) call mfree (Memi[scales+i-1], TY_REAL) call mfree (Memi[zeros+i-1], TY_REAL) call mfree (Memi[wts+i-1], TY_REAL) call mfree (Memi[extns+i-1], TY_CHAR) call mfree (Memi[subsets+i-1], TY_CHAR) } call mfree (images, TY_POINTER) call mfree (scales, TY_POINTER) call mfree (zeros, TY_POINTER) call mfree (wts, TY_POINTER) call mfree (extns, TY_POINTER) call mfree (subsets, TY_POINTER) call mfree (nimages, TY_INT) end # COUTPUT -- Print list of combine output images. # # This routine prints the output names that COMBINE will use. procedure coutput (inlist, outroot) int inlist # List of input images char outroot[ARB] # Output root image name pointer images # Images pointer hroot # Headers pointer broot # Bad pixels masks pointer rroot # Rejection pixel masks pointer nrroot # Number rejected pixel masks pointer eroot # Exposure masks pointer sigroot # Output root sigma image name pointer list # Output list of names pointer scales # Scales pointer zeros # Zeros pointer wts # Weights pointer extns # Image extensions for each subset pointer subsets # Subsets pointer nimages # Number of images in each subset int nsubsets # Number of subsets int i, mef, fd, open() pointer sp errchk cmb_images, open include "src/icombine.com" begin call smark (sp) call salloc (hroot, SZ_FNAME, TY_CHAR) call salloc (broot, SZ_FNAME, TY_CHAR) call salloc (rroot, SZ_FNAME, TY_CHAR) call salloc (nrroot, SZ_FNAME, TY_CHAR) call salloc (eroot, SZ_FNAME, TY_CHAR) call salloc (sigroot, SZ_FNAME, TY_CHAR) call salloc (list, SZ_FNAME, TY_CHAR) # Get the input images. There must be a least one image to continue. call cmb_images (inlist, images, scales, zeros, wts, extns, subsets, nimages, nsubsets, mef) if (nsubsets == 0) { call cmb_images_free (images, scales, zeros, wts, extns, subsets, nimages, nsubsets) call error (0, "No data to combine") } # Get task parameters. Some additional parameters are obtained later. call clgstr ("headers", Memc[hroot], SZ_FNAME) call clgstr ("bpmasks", Memc[broot], SZ_FNAME) call clgstr ("rejmasks", Memc[rroot], SZ_FNAME) call clgstr ("nrejmasks", Memc[nrroot], SZ_FNAME) call clgstr ("expmasks", Memc[eroot], SZ_FNAME) call clgstr ("sigmas", Memc[sigroot], SZ_FNAME) call clgstr ("list", Memc[list], SZ_FNAME) call xt_stripwhite (Memc[hroot]) call xt_stripwhite (Memc[broot]) call xt_stripwhite (Memc[rroot]) call xt_stripwhite (Memc[nrroot]) call xt_stripwhite (Memc[eroot]) call xt_stripwhite (Memc[sigroot]) # Print output images. fd = open (Memc[list], NEW_FILE, TEXT_FILE) do i = 1, nsubsets { call fprintf (fd, "%s%s") call pargstr (outroot) call pargstr (Memc[Memi[extns+i-1]]) if (Memc[hroot] != EOS) { call fprintf (fd, " %s%s") call pargstr (Memc[hroot]) call pargstr (Memc[Memi[extns+i-1]]) } if (Memc[broot] != EOS) { call fprintf (fd, " %s%s") call pargstr (Memc[broot]) # Use this if we can append pl files. #call pargstr (Memc[Memi[extns+i-1]]) call pargstr (Memc[Memi[subsets+i-1]]) } if (Memc[rroot] != EOS) { call fprintf (fd, " %s%s") call pargstr (Memc[rroot]) # Use this if we can append pl files. #call pargstr (Memc[Memi[extns+i-1]]) call pargstr (Memc[Memi[subsets+i-1]]) } if (Memc[nrroot] != EOS) { call fprintf (fd, " %s%s") call pargstr (Memc[nrroot]) # Use this if we can append pl files. #call pargstr (Memc[Memi[extns+i-1]]) call pargstr (Memc[Memi[subsets+i-1]]) } if (Memc[eroot] != EOS) { call fprintf (fd, " %s%s") call pargstr (Memc[eroot]) # Use this if we can append pl files. #call pargstr (Memc[Memi[extns+i-1]]) call pargstr (Memc[Memi[subsets+i-1]]) } if (Memc[sigroot] != EOS) { call fprintf (fd, " %s%s") call pargstr (Memc[sigroot]) call pargstr (Memc[Memi[extns+i-1]]) } call fprintf (fd, "\n") call mfree (Memi[images+i-1], TY_CHAR) call mfree (Memi[scales+i-1], TY_REAL) call mfree (Memi[zeros+i-1], TY_REAL) call mfree (Memi[wts+i-1], TY_REAL) call mfree (Memi[extns+i-1], TY_CHAR) call mfree (Memi[subsets+i-1], TY_CHAR) } call close (fd) # Finish up. call cmb_images_free (images, scales, zeros, wts, extns, subsets, nimages, nsubsets) call sfree (sp) end # CMB_IMAGES -- Get images, scales, zeros, and weights 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 (list, images, scales, zeros, wts, extns, subsets, nimages, nsubsets, mef) int list # List of input images pointer images # Pointer to lists of subsets (allocated) pointer scales # Pointer to array of scales (allocated) pointer zeros # Pointer to array of zeros (allocated) pointer wts # Pointer to array of weights (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 mef #O MEF data? bool doamps # Divide input into subsets by amplifier? bool dosubsets # Divide input into subsets by subset parameter? int i, j, nims, nimage, ccdtype, fd pointer sp, type, image, extn, subset, str, scale, zero, wt, ptr, im int imtlen(), imtgetim(), errcode(), ccdtypecl(), ccdtypes() int nowhite(), open(), fscan(), nscan() pointer immap() bool clgetb(), streq() errchk immap, open begin # Check that there is at least one image. nsubsets = 0 nims = imtlen (list) if (nims == 0) return # Determine whether to divide images into subsets and append extensions. doamps = clgetb ("amps") dosubsets = clgetb ("subsets") 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) call salloc (scale, nims, TY_REAL) call salloc (zero, nims, TY_REAL) call salloc (wt, nims, TY_REAL) # Since we may eliminate images or reorder them we need to get the # scale, zero and weight values from input files where the values # are in the same order as the input images. call clgstr ("scale", Memc[str], SZ_FNAME) j = nowhite (Memc[str], Memc[str], SZ_FNAME) if (Memc[str] == '@') { fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) j = 0 while (fscan (fd) != EOF) { call gargr (Memr[scale+j]) if (nscan() != 1) next if (j == nims) { call eprintf ( "Warning: Ignoring additional %s values in %s\n") call pargstr ("scale") call pargstr (Memc[str+1]) break } j = j + 1 } call close (fd) if (j < nims) { call sprintf (Memc[type], SZ_FNAME, "Insufficient scale values in %s") call pargstr (Memc[str+1]) call error (1, Memc[type]) } } else call amovkr (INDEFR, Memr[scale], nims) call clgstr ("zero", Memc[str], SZ_FNAME) j = nowhite (Memc[str], Memc[str], SZ_FNAME) if (Memc[str] == '@') { fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) j = 0 while (fscan (fd) != EOF) { call gargr (Memr[zero+j]) if (nscan() != 1) next if (j == nims) { call eprintf ( "Warning: Ignoring additional %s values in %s\n") call pargstr ("zero") call pargstr (Memc[str+1]) break } j = j + 1 } call close (fd) if (j < nims) { call sprintf (Memc[type], SZ_FNAME, "Insufficient zero values in %s") call pargstr (Memc[str+1]) call error (1, Memc[type]) } } else call amovkr (INDEFR, Memr[zero], nims) call clgstr ("weight", Memc[str], SZ_FNAME) j = nowhite (Memc[str], Memc[str], SZ_FNAME) if (Memc[str] == '@') { fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) j = 0 while (fscan (fd) != EOF) { call gargr (Memr[wt+j]) if (nscan() != 1) next if (j == nims) { call eprintf ( "Warning: Ignoring additional %s values in %s\n") call pargstr ("weight") call pargstr (Memc[str+1]) break } j = j + 1 } call close (fd) if (j < nims) { call sprintf (Memc[type], SZ_FNAME, "Insufficient weight values in %s") call pargstr (Memc[str+1]) call error (1, Memc[type]) } } else call amovkr (INDEFR, Memr[wt], nims) # Go through the input list and eliminate images not satisfying the # CCD image type. Separate into subsets if desired. Create image, # scale, zero, weight, and subset lists. Determine if the input # is MEF data. ccdtype = ccdtypecl ("ccdtype", Memc[type], SZ_FNAME) mef = INDEFI j = 0 while (imtgetim (list, Memc[image], SZ_FNAME)!=EOF) { j = j + 1 iferr { if (IS_INDEFI(mef)) { ifnoerr (im = immap (Memc[image], READ_ONLY, 0)) mef = NO else { switch (errcode()) { case SYS_FXFOPNOEXTNV: call sprintf (Memc[str], SZ_FNAME, "%s[1]") call pargstr (Memc[image]) im = immap (Memc[str], READ_ONLY, 0) mef = YES default: call erract (EA_ERROR) } } } else if (mef == NO) im = immap (Memc[image], READ_ONLY, 0) else { call sprintf (Memc[str], SZ_FNAME, "%s[1]") call pargstr (Memc[image]) im = immap (Memc[str], READ_ONLY, 0) } } then { call erract (EA_WARN) next } ccdtype = 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 ic_grp (im, Memc[str], SZ_FNAME) if (mef == NO) 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, nims, TY_POINTER) call malloc (scales, nims, TY_POINTER) call malloc (zeros, nims, TY_POINTER) call malloc (wts, nims, TY_POINTER) call malloc (extns, nims, TY_POINTER) call malloc (subsets, nims, TY_POINTER) call malloc (nimages, nims, TY_INT) } else if (mod (nsubsets, nims) == 0) { call realloc (images, nsubsets+nims, TY_POINTER) call realloc (scales, nsubsets+nims, TY_POINTER) call realloc (zeros, nsubsets+nims, TY_POINTER) call realloc (wts, nsubsets+nims, TY_POINTER) call realloc (extns, nsubsets+nims, TY_POINTER) call realloc (subsets, nsubsets+nims, TY_POINTER) call realloc (nimages, nsubsets+nims, TY_INT) } nsubsets = i nimage = 1 Memi[nimages+i-1] = nimage call malloc (Memi[images+i-1], nimage * SZ_FNAME, TY_CHAR) call malloc (Memi[scales+i-1], nimage, TY_REAL) call malloc (Memi[zeros+i-1], nimage, TY_REAL) call malloc (Memi[wts+i-1], nimage, TY_REAL) call malloc (Memi[extns+i-1], SZ_FNAME, TY_CHAR) call malloc (Memi[subsets+i-1], SZ_FNAME, TY_CHAR) call strcpy (Memc[extn], Memc[Memi[extns+i-1]], SZ_FNAME) call strcpy (Memc[subset], Memc[Memi[subsets+i-1]], SZ_FNAME) } else { nimage = Memi[nimages+i-1] + 1 Memi[nimages+i-1] = nimage call realloc (Memi[images+i-1], nimage * SZ_FNAME, TY_CHAR) call realloc (Memi[scales+i-1], nimage, TY_REAL) call realloc (Memi[zeros+i-1], nimage, TY_REAL) call realloc (Memi[wts+i-1], nimage, TY_REAL) } nimage = Memi[nimages+i-1] ptr = Memi[images+i-1] + (nimage - 1) * SZ_FNAME call strcpy (Memc[image], Memc[ptr], SZ_FNAME-1) Memr[Memi[scales+i-1]+nimage-1] = Memr[scale+j-1] Memr[Memi[zeros+i-1]+nimage-1] = Memr[zero+j-1] Memr[Memi[wts+i-1]+nimage-1] = Memr[wt+j-1] call imunmap (im) } call realloc (images, nsubsets, TY_POINTER) call realloc (scales, nsubsets, TY_POINTER) call realloc (zeros, nsubsets, TY_POINTER) call realloc (wts, nsubsets, TY_POINTER) call realloc (extns, nsubsets, TY_POINTER) call realloc (subsets, nsubsets, TY_POINTER) call realloc (nimages, nsubsets, TY_INT) call sfree (sp) end # MEFCOMBINE -- Combine MEF data. # # This routine receives a list of input MEF files already sorted by # subset (i.e. filter) with appropriate output file names. This routine # must then group the image extensions by amplifier and set up the # scaling factors, which are the same for all extensions from the # same image. At the end of combining all the extensions it averages # any CCDMEAN keywords so that there is a common value for all the extensions. # # If there is only one output extension then an PHU only image is produced. procedure mefcombine (ims, scale, zero, wt, nims, output, headers, broot, rroot, nrroot, eroot, sigma, logfile, stack, delete, oneimage) char ims[SZ_FNAME-1, nims] # Input images real scale[nims] # Scales real zero[nims] # Zeros real wt[nims] # Weights int nims # Number of images in list char output[ARB] # Output image char headers[ARB] # Header files char broot[ARB] # Bad pixel mask char rroot[ARB] # Rejection pixel mask char nrroot[ARB] # Number rejected pixel mask char eroot[ARB] # Exposure mask char sigma[ARB] # Output sigma image char logfile[ARB] # Log filename int stack # Stack input images? int delete # Delete input images? int oneimage # Allow just a single image? int i, j, k, nsubsets, nimage, ghdr, list real ccdmean, sum pointer sp, image, subset, bmask, rmask, nrmask, emask, im, ptr pointer images, iimage, scales, zeros, wts, subsets, nimages real imgetr() bool streq() int errcode(), imaccess(), ic_mklist() pointer immap() errchk immap, imcopy, icombine, mefscales, ic_mklist include "src/icombine.com" begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (subset, SZ_FNAME, TY_CHAR) call salloc (bmask, SZ_FNAME, TY_CHAR) call salloc (rmask, SZ_FNAME, TY_CHAR) call salloc (nrmask, SZ_FNAME, TY_CHAR) call salloc (emask, SZ_FNAME, TY_CHAR) # Expand MEF files and group by amplifier. ghdr = NO nsubsets = 0 do k = 1, nims { do j = 0, ARB { call sprintf (Memc[image], SZ_FNAME, "%s[%d]") call pargstr (ims[1,k]) call pargi (j) iferr (im = immap (Memc[image], READ_ONLY, 0)) { switch (errcode()) { case SYS_FXFRFEOF, SYS_IKIOPEN: break case SYS_IKIEXTN: next default: call erract (EA_ERROR) } } if (IM_NDIM(im) == 0) { if (j == 0) ghdr = YES call imunmap (im) next } call ic_grp (im, Memc[subset], SZ_FNAME) if (Memc[subset] == EOS) { call sprintf (Memc[subset], SZ_FNAME, "%d") call pargi (j) } 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, nims, TY_POINTER) call malloc (iimage, nims, TY_POINTER) call malloc (scales, nims, TY_POINTER) call malloc (zeros, nims, TY_POINTER) call malloc (wts, nims, TY_POINTER) call malloc (subsets, nims, TY_POINTER) call malloc (nimages, nims, TY_INT) } else if (mod (nsubsets, nims) == 0) { call realloc (images, nsubsets+nims, TY_POINTER) call realloc (iimage, nsubsets+nims, TY_POINTER) call realloc (scales, nsubsets+nims, TY_POINTER) call realloc (zeros, nsubsets+nims, TY_POINTER) call realloc (wts, nsubsets+nims, TY_POINTER) call realloc (subsets, nsubsets+nims, TY_POINTER) call realloc (nimages, nsubsets+nims, TY_INT) } nsubsets = i nimage = 1 Memi[nimages+i-1] = nimage call malloc (Memi[images+i-1], nimage * SZ_FNAME, TY_CHAR) call malloc (Memi[iimage+i-1], nimage, TY_INT) call malloc (Memi[scales+i-1], nimage, TY_REAL) call malloc (Memi[zeros+i-1], nimage, TY_REAL) call malloc (Memi[wts+i-1], nimage, TY_REAL) call malloc (Memi[subsets+i-1], SZ_FNAME, TY_CHAR) call strcpy (Memc[subset], Memc[Memi[subsets+i-1]], SZ_FNAME) } else { nimage = Memi[nimages+i-1] + 1 Memi[nimages+i-1] = nimage call realloc (Memi[images+i-1], nimage * SZ_FNAME, TY_CHAR) call realloc (Memi[iimage+i-1], nimage, TY_INT) call realloc (Memi[scales+i-1], nimage, TY_REAL) call realloc (Memi[zeros+i-1], nimage, TY_REAL) call realloc (Memi[wts+i-1], nimage, TY_REAL) } nimage = Memi[nimages+i-1] ptr = Memi[images+i-1] + (nimage - 1) * SZ_FNAME call strcpy (Memc[image], Memc[ptr], SZ_FNAME-1) Memi[Memi[iimage+i-1]+nimage-1] = k Memr[Memi[scales+i-1]+nimage-1] = scale[k] Memr[Memi[zeros+i-1]+nimage-1] = zero[k] Memr[Memi[wts+i-1]+nimage-1] = wt[k] call imunmap (im) } } call realloc (images, nsubsets, TY_POINTER) call realloc (iimage, nsubsets, TY_POINTER) call realloc (scales, nsubsets, TY_POINTER) call realloc (zeros, nsubsets, TY_POINTER) call realloc (wts, nsubsets, TY_POINTER) call realloc (subsets, nsubsets, TY_POINTER) call realloc (nimages, nsubsets, TY_INT) # Check number of images. if (oneimage == NO) { do i = 1, nsubsets { if (Memi[nimages+i-1] > 1) break } if (i > nsubsets) { do i = 1, nsubsets { call mfree (Memi[images+i-1], TY_CHAR) call mfree (Memi[iimage+i-1], TY_INT) call mfree (Memi[scales+i-1], TY_REAL) call mfree (Memi[zeros+i-1], TY_REAL) call mfree (Memi[wts+i-1], TY_REAL) call mfree (Memi[subsets+i-1], TY_CHAR) } call mfree (images, TY_POINTER) call mfree (iimage, TY_POINTER) call mfree (scales, TY_POINTER) call mfree (zeros, TY_POINTER) call mfree (wts, TY_POINTER) call mfree (subsets, TY_POINTER) call mfree (nimages, TY_INT) call error (ONEIMAGE, "Only single images to combine") } } # Compute scaling factors if needed. call mefscales (Memi[images], Memi[iimage], Memi[nimages], nsubsets, scale, zero, wt, nims) do i = 1, nsubsets { do j = 1, Memi[nimages+i-1] { k = Memi[Memi[iimage+i-1]+j-1] Memr[Memi[scales+i-1]+j-1] = scale[k] Memr[Memi[zeros+i-1]+j-1] = zero[k] Memr[Memi[wts+i-1]+j-1] = wt[k] } } # Create the global headers. if (ghdr == YES && nsubsets > 1) { if (imaccess (output, 0) == YES) { call sprintf (Memc[image], SZ_FNAME, "Output `%s' already exists") call pargstr (output) call error (1, Memc[image]) } call sprintf (Memc[image], SZ_FNAME, "%s[0]") call pargstr (ims[1,1]) im = immap (Memc[image], READ_ONLY, 0) call sprintf (Memc[image], SZ_FNAME, "%s[noappend]") call pargstr (output) ptr = immap (Memc[image], NEW_COPY, im) call imunmap (ptr) if (sigma[1] != EOS) { call sprintf (Memc[image], SZ_FNAME, "%s[noappend]") call pargstr (sigma) ptr = immap (Memc[image], NEW_COPY, im) call imunmap (ptr) } call imunmap (im) } # Combine each extension. do i = 1, nsubsets { # Add inherit parameter to output name. if (nsubsets > 1) { call sprintf (Memc[image], SZ_FNAME, "%s[inherit]") call pargstr (output) } else call strcpy (output, Memc[image], SZ_FNAME) # Since we can't append pl files add an extension. call strcpy (broot, Memc[bmask], SZ_FNAME) if (Memc[bmask] != EOS) { call sprintf (Memc[bmask], SZ_FNAME, "%s%s") call pargstr (broot) call pargstr (Memc[Memi[subsets+i-1]]) } # Since we can't append pl files add an extension. call strcpy (rroot, Memc[rmask], SZ_FNAME) if (Memc[rmask] != EOS) { call sprintf (Memc[rmask], SZ_FNAME, "%s%s") call pargstr (rroot) call pargstr (Memc[Memi[subsets+i-1]]) } # Since we can't append pl files add an extension. call strcpy (nrroot, Memc[nrmask], SZ_FNAME) if (Memc[nrmask] != EOS) { call sprintf (Memc[nrmask], SZ_FNAME, "%s%s") call pargstr (rroot) call pargstr (Memc[Memi[subsets+i-1]]) } # Since we can't append pl files add an extension. call strcpy (eroot, Memc[emask], SZ_FNAME) if (Memc[emask] != EOS) { call sprintf (Memc[emask], SZ_FNAME, "%s%s") call pargstr (eroot) call pargstr (Memc[Memi[subsets+i-1]]) } # Combine all images from the (subset) list. list = ic_mklist (Memc[Memi[images+i-1]], Memi[nimages+i-1]) iferr (call icombine (list, Memc[image], headers, Memc[bmask], Memc[rmask], Memc[nrmask], Memc[emask], sigma, logfile, Memr[Memi[scales+i-1]], Memr[Memi[zeros+i-1]], Memr[Memi[wts+i-1]], stack, NO, NO)) { iferr (call imdelete (output)) ; call erract (EA_ERROR) } call imtclose (list) call mfree (Memi[images+i-1], TY_CHAR) call mfree (Memi[iimage+i-1], TY_INT) call mfree (Memi[scales+i-1], TY_REAL) call mfree (Memi[zeros+i-1], TY_REAL) call mfree (Memi[wts+i-1], TY_REAL) call mfree (Memi[subsets+i-1], TY_CHAR) } call mfree (images, TY_POINTER) call mfree (iimage, TY_POINTER) call mfree (scales, TY_POINTER) call mfree (zeros, TY_POINTER) call mfree (wts, TY_POINTER) call mfree (subsets, TY_POINTER) call mfree (nimages, TY_INT) # Reset MEF header. # Set global ccdmean. if (nsubsets > 1) { sum = 0 i = 0. do j = nsubsets, 0, -1 { call sprintf (Memc[image], SZ_FNAME, "%s[%d]") call pargstr (output) call pargi (j) im = immap (Memc[image], READ_WRITE, 0) if (j > 0) { ifnoerr (ccdmean = imgetr (im, "ccdmean")) { sum = sum + ccdmean i = i + 1 call imdelf (im, "ccdmean") } } else if (i > 0) { ccdmean = sum / i call imaddr (im, "ccdmean", ccdmean) } call imunmap (im) } } # Delete input images. if (delete == YES) { do i = 1, nims call ccddelete (ims[1,i]) } call sfree (sp) end procedure ic_grp (im, amp, maxchar) pointer im #I IMIO pointer char amp[ARB] #O Grouping string int maxchar #I Size of grouping string int grp common /grpcom/ grp begin switch (grp) { case GRPAMP: call ccdamp (im, amp, maxchar) case GRPCCD: call ccdname (im, amp, maxchar) default: call ccdamp (im, amp, maxchar) } end # IC_MKLIST -- Convert images names into an image list. int procedure ic_mklist (images, nimages) char images[SZ_FNAME-1,nimages] #I Image names int nimages #I Number of images int list #O Image list int i, fd, stropen(), imtopen() pointer sp, str errchk salloc, stropen, imtopen begin call smark (sp) call salloc (str, nimages*SZ_FNAME, TY_CHAR) fd = stropen (Memc[str], nimages*SZ_FNAME, NEW_FILE) do i = 1, nimages { call fprintf (fd, "%s,") call pargstr (images[1,i]) } call close (fd) list = imtopen (Memc[str]) call sfree (sp) return (list) end mscred-5.05-2018.07.09/src/ccdred/src/combine/x_combine.x000066400000000000000000000002171332166314300223400ustar00rootroot00000000000000task combine = t_combine, coutput = t_coutput, mergeamps = t_ampmerge, fcombine = t_combine, scombine = t_combine, zcombine = t_combine mscred-5.05-2018.07.09/src/ccdred/src/combine/zcombine.par000066400000000000000000000040751332166314300225240ustar00rootroot00000000000000# ZCOMBINE -- Image combine parameters for zeros input,s,a,,,,List of images to combine output,s,a,,,,List of output images headers,s,h,"",,,List of header files (optional) bpmasks,s,h,"",,,List of bad pixel masks (optional) rejmasks,s,h,"",,,List of rejection masks (optional) nrejmasks,s,h,"",,,List of number rejected masks (optional) expmasks,s,h,"",,,List of exposure masks (optional) sigmas,s,h,"",,,List of sigma images (optional) imcmb,s,h,"$I",,,"Keyword for IMCMB keywords " ccdtype,s,h,"zero",,,CCD image type to combine (optional) amps,b,h,yes,,,Combine images by amplifier? subsets,b,h,no,,,Combine images by subset? delete,b,h,no,,,"Delete input images after combining? " combine,s,h,"average","average|median|sum",,Type of combine operation reject,s,h,"minmax","none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip",,Type of rejection project,b,h,no,,,Project highest dimension of input images? outtype,s,h,"real","short|ushort|integer|long|real|double",,Output image pixel datatype outlimits,s,h,"",,,Output limits (x1 x2 y1 y2 ...) offsets,f,h,"none",,,Input image offsets masktype,s,h,"none",,,Mask type maskvalue,s,h,"0",,,Mask value blank,r,h,0.,,,"Value if there are no pixels " scale,s,h,"none",,,Image scaling zero,s,h,"none",,,Image zero point offset weight,s,h,"none",,,Image weights statsec,s,h,"",,,"Image section for computing statistics " lthreshold,r,h,INDEF,,,Lower threshold hthreshold,r,h,INDEF,,,Upper threshold nlow,i,h,0,0,,minmax: Number of low pixels to reject nhigh,i,h,1,0,,minmax: Number of high pixels to reject nkeep,i,h,1,,,Minimum to keep (pos) or maximum to reject (neg) mclip,b,h,yes,,,Use median in sigma clipping algorithms? lsigma,r,h,3.,0.,,Lower sigma clipping factor hsigma,r,h,3.,0.,,Upper sigma clipping factor rdnoise,s,h,"0.",,,ccdclip: CCD readout noise (electrons) gain,s,h,"1.",,,ccdclip: CCD gain (electrons/DN) snoise,s,h,"0.",,,ccdclip: Sensitivity noise (fraction) sigscale,r,h,0.1,0.,,Tolerance for sigma clipping scaling corrections pclip,r,h,-0.5,,,pclip: Percentile clipping parameter grow,r,h,0.,0.,,Radius (pixels) for neighbor rejection mscred-5.05-2018.07.09/src/ccdred/src/cor.gx000066400000000000000000000362151332166314300177220ustar00rootroot00000000000000include 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. 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 real 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] if (cors[FLATCOR] != 0 || cors[SFLATCOR] != 0) op = op + F switch (op) { case 0: # no operation ; 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] / flat[i] case FO: # flat field + overscan do i = 1, n out[i] = (out[i] - overscan) / flat[i] case FZ: # flat field + zero level do i = 1, n out[i] = (out[i] - zero[i]) / flat[i] case FZO: # flat field + zero level + overscan do i = 1, n out[i] = (out[i] - overscan - zero[i]) / flat[i] case FD: # flat field + dark count do i = 1, n out[i] = (out[i] - darkscale * dark[i]) / flat[i] case FDO: # flat field + dark count + overscan do i = 1, n out[i] = (out[i] - overscan - darkscale * dark[i]) / flat[i] case FDZ: # flat field + dark count + zero level do i = 1, n out[i] = (out[i] - zero[i] - darkscale * dark[i]) / 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]) / flat[i] default: call error (1, "Processing combination not supported") } # 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 # COR1FLAT -- Correct flat field data. procedure cor1flat$t (cors, out, flat, sflat, n, flatscale, sflatscale, minval, maxval) int cors[ARB] # Correction flags PIXEL out[n] # Output data PIXEL flat[n] # Flat field correction PIXEL sflat[n] # Flat field correction int n # Number of pixels real flatscale # Flat field scale factor real sflatscale # Flat field scale factor real minval # Minimum value real maxval # Maximum value int i, op real flatval, flatscl begin op = cors[FLATCOR] + cors[SFLATCOR] switch (op) { case F: if (flatscale == 1.) { do i = 1, n { flatval = flat[i] if (flatval < minval || flatval > maxval) out[i] = flatval else out[i] = 1. } } else { do i = 1, n { flatval = flat[i] / flatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } case S: if (sflatscale == 1.) { do i = 1, n { flatval = sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = sflat[i] / sflatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } case SF: flatscl = flatscale * sflatscale if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } 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 real 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] if (cors[FLATCOR] != 0 || cors[SFLATCOR] != 0) op = op + F switch (op) { case 0: # no operation ; 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] / flat[i] } else { flatval = 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]) / flat[i] } else { flatval = flat[i] 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - zeroval) / flat[i] } } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - overscan[i] - zeroval) / flat[i] } } else { flatval = 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]) / flat[i] } else { flatval = 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]) / flat[i] } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - zeroval - darkscale * dark[i]) / flat[i] } } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - overscan[i] - zeroval - darkscale * dark[i]) / flat[i] } } else { flatval = 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 } } default: call error (1, "Processing combination not supported") } # 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 # COR2FLAT -- Correct flat field data. procedure cor2flat$t (line, cors, out, flat, sflat, n, flatim, sflatim, flatscale, sflatscale, minval, maxval) int line # Line to be corrected int cors[ARB] # Correction flags PIXEL out[n] # Output data PIXEL flat[n] # Flat field correction PIXEL sflat[n] # Flat field correction int n # Number of pixels pointer flatim # Flat field pointer pointer sflatim # Sky flat field pointer real flatscale # Flat field scale factor real sflatscale # Flat field scale factor real minval # Minimum value real maxval # Maximum value int i, op real flatval, flatscl begin op = cors[FLATCOR] + cors[SFLATCOR] switch (op) { case F: if (flatim != NULL) { if (flatscale == 1.) { do i = 1, n { flatval = flat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] / flatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = flat[line] / flatscale if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } case S: if (sflatim != NULL) { if (sflatscale == 1.) { do i = 1, n { flatval = sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = sflat[i] / sflatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = sflat[line] / sflatscale if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } case SF: flatscl = flatscale * sflatscale if (flatim != NULL) { if (sflatim != NULL) { if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[line] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[line] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } } else if (sflatim != NULL) { if (flatscl == 1.) { do i = 1, n { flatval = flat[line] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[line] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = flat[line] * sflat[line] / flatscl if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } } end $endfor mscred-5.05-2018.07.09/src/ccdred/src/cosmic/000077500000000000000000000000001332166314300200455ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/ccdred/src/cosmic/crexamine.x000066400000000000000000000267321332166314300222230ustar00rootroot00000000000000include include include include include include 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) call sfree (sp) 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 mscred-5.05-2018.07.09/src/ccdred/src/cosmic/crfind.x000066400000000000000000000206671332166314300215160ustar00rootroot00000000000000include # 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[nl] # 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[n], b[n], c[n], d[n], e[n], f[n], g[n] # 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 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[n], b[n], c[n], d[n], e[n] # 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 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 �������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/cosmic/crlist.h�����������������������������������������������0000664�0000000�0000000�00000001207�13321663143�0021516�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/cosmic/crlist.x�����������������������������������������������0000664�0000000�0000000�00000017401�13321663143�0021541�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include 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; iMemr[line+i]; i=i+10) ; j = i - 9 rmin = (Memr[col+j] - x) ** 2 + (Memr[line+j] - y) ** 2 for (i=j+1; iMemr[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[ncr] #I Ratio Values real wts[ncr] #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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/cosmic/crsurface.x��������������������������������������������0000664�0000000�0000000�00000001750�13321663143�0022216�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 ������������������������mscred-5.05-2018.07.09/src/ccdred/src/cosmic/mkpkg��������������������������������������������������0000664�0000000�0000000�00000000515�13321663143�0021102�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# COSMIC RAY CLEANING $checkout libpkg.a ../.. $update libpkg.a $checkin libpkg.a ../.. $exit libpkg.a: crexamine.x crlist.h \ crfind.x crlist.x crlist.h crsurface.x t_cosmicrays.x crlist.h ; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/cosmic/t_cosmicrays.x�����������������������������������������0000664�0000000�0000000�00000024406�13321663143�0022743�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include include 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 Memr[data+i-1] = Memr[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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/doproc.x������������������������������������������������������0000664�0000000�0000000�00000001045�13321663143�0020247�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/generic/������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0020204�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/generic/ccdred.h����������������������������������������������0000664�0000000�0000000�00000023742�13321663143�0021611�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# 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 1660 # Length of CCD structure define LEN_LOG 199 # Length of log strings define LEN_CCDSTR 99 # Length of strings # Basic control flags define PROC Memi[$1] # Process input image? define CALPROC Memi[$1+1] # Process calibration images? define LISTPROC Memi[$1+2] # List processing to be done? define COR Memi[$1+3] # Call DOPROC? define COROUT Memi[$1+4] # Create output image? define CORBPM Memi[$1+5] # Create output mask? define CORS Memi[$1+6+($2-1)] # Individual correction flags # CCD data coordinates define CCD_C1 Memi[$1+20] # CCD starting column define CCD_C2 Memi[$1+21] # CCD ending column define CCD_CS Memi[$1+22] # CCD step define CCD_L1 Memi[$1+23] # CCD starting line define CCD_L2 Memi[$1+24] # CCD ending line define CCD_LS Memi[$1+25] # CCD step # Input data define IN_IM Memi[$1+30] # Input image pointer define IN_CCDTYPE Memi[$1+31] # Input CCD type define IN_C1 Memi[$1+32] # Input data starting column define IN_C2 Memi[$1+33] # Input data ending column define IN_L1 Memi[$1+34] # Input data starting line define IN_L2 Memi[$1+35] # Input data ending line define IN_CFLIP Memi[$1+36] # Flipped input data section? define IN_LFLIP Memi[$1+37] # Flipped input data section? # Input mask data define BPIN_IM Memi[$1+40] # Input bad pixel mask pointer define BPIN_C1 Memi[$1+41] # Input mask data starting col define BPIN_C2 Memi[$1+42] # Input mask data ending col define BPIN_L1 Memi[$1+43] # Input mask data starting line define BPIN_L2 Memi[$1+44] # Input mask data ending line define BPIN_PM Memi[$1+45] # Input mask pointer define BPIN_FP Memi[$1+46] # Input mask fixpix data # Output data define OUT_IM Memi[$1+50] # Output image pointer define OUT_C1 Memi[$1+51] # Output data starting col define OUT_C2 Memi[$1+52] # Output data ending col define OUT_L1 Memi[$1+53] # Output data starting line define OUT_L2 Memi[$1+54] # Output data ending line # Output mask data define BPOUT_IM Memi[$1+55] # Output mask pointer # Output no interpolation data define NOIOUT_IM Memi[$1+56] # Output image pointer # Saturation and bleed trail data define SATVAL Memr[P2R($1+60)] # Saturation value in ADU define SATVALE Memr[P2R($1+61)] # Saturation value in electrons define SATGROW Memi[$1+62] # Saturated pixel grow radius define BLDVAL Memr[P2R($1+63)] # Bleed value in ADU define BLDVALE Memr[P2R($1+64)] # Bleed value in electrons define BLDTRAIL Memi[$1+65] # Bleed trail minimum length define BLDGROW Memi[$1+66] # Bleed pixel grow radius # Zero level data define ZERO_IM Memi[$1+70] # Zero level image pointer define ZERO_C1 Memi[$1+71] # Zero level data starting col define ZERO_C2 Memi[$1+72] # Zero level data ending col define ZERO_L1 Memi[$1+73] # Zero level data starting line define ZERO_L2 Memi[$1+74] # Zero level data ending line # Dark count data define DARK_IM Memi[$1+80] # Dark count image pointer define DARK_C1 Memi[$1+81] # Dark count data starting col define DARK_C2 Memi[$1+82] # Dark count data ending col define DARK_L1 Memi[$1+83] # Dark count data starting line define DARK_L2 Memi[$1+84] # Dark count data ending line define DARKSCALE Memr[P2R($1+85)] # Dark count scale factor # Flat field data define FLAT_IM Memi[$1+90] # Flat field image pointer define FLAT_C1 Memi[$1+91] # Flat field data starting col define FLAT_C2 Memi[$1+92] # Flat field data ending col define FLAT_L1 Memi[$1+93] # Flat field data starting line define FLAT_L2 Memi[$1+94] # Flat field data ending line define FLATSCALE Memr[P2R($1+95)] # Flat field scale factor define GAINSCALE Memr[P2R($1+96)] # Gain scale factor # Sky flat field data define SFLAT_IM Memi[$1+100] # Sky flat field image pointer define SFLAT_C1 Memi[$1+101] # Sky flat field starting col define SFLAT_C2 Memi[$1+102] # Sky flat field ending col define SFLAT_L1 Memi[$1+103] # Sky flat field starting line define SFLAT_L2 Memi[$1+104] # Sky flat field ending line define SFLATSCALE Memr[P2R($1+105)] # Sky flat field scale factor # Illumination data define ILLUM_IM Memi[$1+110] # Illumination image pointer define ILLUM_C1 Memi[$1+111] # Illumination starting col define ILLUM_C2 Memi[$1+112] # Illumination ending col define ILLUM_L1 Memi[$1+113] # Illumination starting line define ILLUM_L2 Memi[$1+114] # Illumination ending line define ILLUMSCALE Memr[P2R($1+115)] # Illumination factor # Fringe data define FRINGE_IM Memi[$1+120] # Fringe image pointer define FRINGE_C1 Memi[$1+121] # Fringe data starting col define FRINGE_C2 Memi[$1+122] # Fringe data ending col define FRINGE_L1 Memi[$1+123] # Fringe data starting line define FRINGE_L2 Memi[$1+124] # Fringe data ending line define FRINGESCALE Memr[P2R($1+125)] # Fringe scale factor # Trim section define TRIM_C1 Memi[$1+130] # Trim starting col define TRIM_C2 Memi[$1+131] # Trim ending col define TRIM_L1 Memi[$1+132] # Trim starting line define TRIM_L2 Memi[$1+133] # Trim ending line define TRIM_DC1 Memi[$1+134] # Trim from data section define TRIM_DC2 Memi[$1+135] # Trim from data section define TRIM_DL1 Memi[$1+136] # Trim from data section define TRIM_DL2 Memi[$1+137] # Trim from data section # Bias section define BIAS_C1 Memi[$1+140] # Bias starting col define BIAS_C2 Memi[$1+141] # Bias ending col define BIAS_L1 Memi[$1+142] # Bias starting line define BIAS_L2 Memi[$1+143] # Bias ending line define OVERSCAN_TYPE Memi[$1+144] # Pointer to overscan vector define OVERSCAN_VEC Memi[$1+145] # Pointer to overscan vector # Miscellaneous define READAXIS Memi[$1+150] # Readout axis (1=cols, 2=lines) define CALCTYPE Memi[$1+151] # Calculation data type define MINREPLACE Memr[P2R($1+152)] # Minimum replacement value define MEAN Memr[P2R($1+153)] # Mean of output image # Strings define SATLOG Memc[P2C($1+160)] # Saturation log define BLDLOG Memc[P2C($1+260)] # Bleed log define TRIMLOG Memc[P2C($1+360)] # Trim log define FIXLOG Memc[P2C($1+460)] # Fix pixel log define BIASLOG Memc[P2C($1+560)] # Bias log define ZEROLOG Memc[P2C($1+660)] # Zero log define DARKLOG Memc[P2C($1+760)] # Dark count log define FLATLOG Memc[P2C($1+860)] # Flat field log define SFLATLOG Memc[P2C($1+960)] # Sky flat field log define ILLUMLOG Memc[P2C($1+1060)] # Illumination log define FRINGELOG Memc[P2C($1+1160)] # Fringe log define BPOUTLOG Memc[P2C($1+1260)] # Output BP mask log define BPIN_NAME Memc[P2C($1+1360)] # Input bad pixel mask name define BPOUT_NAME Memc[P2C($1+1460)] # Output bad pixel mask name define NOIOUT_NAME Memc[P2C($1+1560)] # Output no interpolation name # The correction array contains the following elements with array indices # given by the macro definitions. define NCORS 13 # Number of corrections define SATURATE 1 # Find saturation and bleed trails define FIXPIX 2 # Fix bad pixels define TRIM 3 # Trim image define OVERSCAN 4 # Apply overscan correction define ZEROCOR 5 # Apply zero level correction define DARKCOR 6 # Apply dark count correction define FLATCOR 7 # Apply flat field correction define SFLATCOR 8 # Apply flat field correction define ILLUMCOR 9 # Apply illumination correction define FRINGECOR 10 # Apply fringe correction define FINDMEAN 11 # Find the mean of the output image define MINREP 12 # Check and replace minimum value define READCOR 13 # Apply 1D read correction # 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 S 020B # sky flat field define I 040B # Illumination define Q 100B # 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 SF 030B # flat field define SFO 031B # flat field + overscan define SFZ 032B # flat field + zero level define SFZO 033B # flat field + zero level + overscan define SFD 034B # flat field + dark count define SFDO 035B # flat field + dark count + overscan define SFDZ 036B # flat field + dark count + zero level define SFDZO 037B # flat field + dark count + zero level + overscan define QI 140B # 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 # The following are error actions for CCDPROC. define ONERROR "|abort|warn|exit|original|" define ONERR_ABORT 1 # Abort on an error define ONERR_WARN 2 # Warn on error and continue define ONERR_EXIT 3 # Warn on error and exit define ONERR_ORIG 4 # Original CCDPROC (warn/error) # The following are CALPROC actions. define CALPROC_YES 1 # Process calibrations define CALPROC_NO 2 # Set calibration to be processed externally define CALPROC_IGNORE 3 # Ignore calibration processing ������������������������������mscred-5.05-2018.07.09/src/ccdred/src/generic/cor.x�������������������������������������������������0000664�0000000�0000000�00000072017�13321663143�0021167�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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. 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 real 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] if (cors[FLATCOR] != 0 || cors[SFLATCOR] != 0) op = op + F switch (op) { case 0: # no operation ; 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] / flat[i] case FO: # flat field + overscan do i = 1, n out[i] = (out[i] - overscan) / flat[i] case FZ: # flat field + zero level do i = 1, n out[i] = (out[i] - zero[i]) / flat[i] case FZO: # flat field + zero level + overscan do i = 1, n out[i] = (out[i] - overscan - zero[i]) / flat[i] case FD: # flat field + dark count do i = 1, n out[i] = (out[i] - darkscale * dark[i]) / flat[i] case FDO: # flat field + dark count + overscan do i = 1, n out[i] = (out[i] - overscan - darkscale * dark[i]) / flat[i] case FDZ: # flat field + dark count + zero level do i = 1, n out[i] = (out[i] - zero[i] - darkscale * dark[i]) / 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]) / flat[i] default: call error (1, "Processing combination not supported") } # 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 # COR1FLAT -- Correct flat field data. procedure cor1flats (cors, out, flat, sflat, n, flatscale, sflatscale, minval, maxval) int cors[ARB] # Correction flags short out[n] # Output data short flat[n] # Flat field correction short sflat[n] # Flat field correction int n # Number of pixels real flatscale # Flat field scale factor real sflatscale # Flat field scale factor real minval # Minimum value real maxval # Maximum value int i, op real flatval, flatscl begin op = cors[FLATCOR] + cors[SFLATCOR] switch (op) { case F: if (flatscale == 1.) { do i = 1, n { flatval = flat[i] if (flatval < minval || flatval > maxval) out[i] = flatval else out[i] = 1. } } else { do i = 1, n { flatval = flat[i] / flatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } case S: if (sflatscale == 1.) { do i = 1, n { flatval = sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = sflat[i] / sflatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } case SF: flatscl = flatscale * sflatscale if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } 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 real 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] if (cors[FLATCOR] != 0 || cors[SFLATCOR] != 0) op = op + F switch (op) { case 0: # no operation ; 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] / flat[i] } else { flatval = 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]) / flat[i] } else { flatval = flat[i] 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - zeroval) / flat[i] } } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - overscan[i] - zeroval) / flat[i] } } else { flatval = 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]) / flat[i] } else { flatval = 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]) / flat[i] } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - zeroval - darkscale * dark[i]) / flat[i] } } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - overscan[i] - zeroval - darkscale * dark[i]) / flat[i] } } else { flatval = 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 } } default: call error (1, "Processing combination not supported") } # 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 # COR2FLAT -- Correct flat field data. procedure cor2flats (line, cors, out, flat, sflat, n, flatim, sflatim, flatscale, sflatscale, minval, maxval) int line # Line to be corrected int cors[ARB] # Correction flags short out[n] # Output data short flat[n] # Flat field correction short sflat[n] # Flat field correction int n # Number of pixels pointer flatim # Flat field pointer pointer sflatim # Sky flat field pointer real flatscale # Flat field scale factor real sflatscale # Flat field scale factor real minval # Minimum value real maxval # Maximum value int i, op real flatval, flatscl begin op = cors[FLATCOR] + cors[SFLATCOR] switch (op) { case F: if (flatim != NULL) { if (flatscale == 1.) { do i = 1, n { flatval = flat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] / flatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = flat[line] / flatscale if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } case S: if (sflatim != NULL) { if (sflatscale == 1.) { do i = 1, n { flatval = sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = sflat[i] / sflatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = sflat[line] / sflatscale if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } case SF: flatscl = flatscale * sflatscale if (flatim != NULL) { if (sflatim != NULL) { if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[line] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[line] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } } else if (sflatim != NULL) { if (flatscl == 1.) { do i = 1, n { flatval = flat[line] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[line] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = flat[line] * sflat[line] / flatscl if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } } 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] if (cors[FLATCOR] != 0 || cors[SFLATCOR] != 0) op = op + F switch (op) { case 0: # no operation ; 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] / flat[i] case FO: # flat field + overscan do i = 1, n out[i] = (out[i] - overscan) / flat[i] case FZ: # flat field + zero level do i = 1, n out[i] = (out[i] - zero[i]) / flat[i] case FZO: # flat field + zero level + overscan do i = 1, n out[i] = (out[i] - overscan - zero[i]) / flat[i] case FD: # flat field + dark count do i = 1, n out[i] = (out[i] - darkscale * dark[i]) / flat[i] case FDO: # flat field + dark count + overscan do i = 1, n out[i] = (out[i] - overscan - darkscale * dark[i]) / flat[i] case FDZ: # flat field + dark count + zero level do i = 1, n out[i] = (out[i] - zero[i] - darkscale * dark[i]) / 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]) / flat[i] default: call error (1, "Processing combination not supported") } # 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 # COR1FLAT -- Correct flat field data. procedure cor1flatr (cors, out, flat, sflat, n, flatscale, sflatscale, minval, maxval) int cors[ARB] # Correction flags real out[n] # Output data real flat[n] # Flat field correction real sflat[n] # Flat field correction int n # Number of pixels real flatscale # Flat field scale factor real sflatscale # Flat field scale factor real minval # Minimum value real maxval # Maximum value int i, op real flatval, flatscl begin op = cors[FLATCOR] + cors[SFLATCOR] switch (op) { case F: if (flatscale == 1.) { do i = 1, n { flatval = flat[i] if (flatval < minval || flatval > maxval) out[i] = flatval else out[i] = 1. } } else { do i = 1, n { flatval = flat[i] / flatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } case S: if (sflatscale == 1.) { do i = 1, n { flatval = sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = sflat[i] / sflatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } case SF: flatscl = flatscale * sflatscale if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } 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] if (cors[FLATCOR] != 0 || cors[SFLATCOR] != 0) op = op + F switch (op) { case 0: # no operation ; 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] / flat[i] } else { flatval = 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]) / flat[i] } else { flatval = flat[i] 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - zeroval) / flat[i] } } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - overscan[i] - zeroval) / flat[i] } } else { flatval = 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]) / flat[i] } else { flatval = 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]) / flat[i] } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - zeroval - darkscale * dark[i]) / flat[i] } } else { flatval = 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]) / flat[i] } else { zeroval = zero[line] do i = 1, n out[i] = (out[i] - overscan[i] - zeroval - darkscale * dark[i]) / flat[i] } } else { flatval = 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 } } default: call error (1, "Processing combination not supported") } # 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 # COR2FLAT -- Correct flat field data. procedure cor2flatr (line, cors, out, flat, sflat, n, flatim, sflatim, flatscale, sflatscale, minval, maxval) int line # Line to be corrected int cors[ARB] # Correction flags real out[n] # Output data real flat[n] # Flat field correction real sflat[n] # Flat field correction int n # Number of pixels pointer flatim # Flat field pointer pointer sflatim # Sky flat field pointer real flatscale # Flat field scale factor real sflatscale # Flat field scale factor real minval # Minimum value real maxval # Maximum value int i, op real flatval, flatscl begin op = cors[FLATCOR] + cors[SFLATCOR] switch (op) { case F: if (flatim != NULL) { if (flatscale == 1.) { do i = 1, n { flatval = flat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] / flatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = flat[line] / flatscale if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } case S: if (sflatim != NULL) { if (sflatscale == 1.) { do i = 1, n { flatval = sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = sflat[i] / sflatscale if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = sflat[line] / sflatscale if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } case SF: flatscl = flatscale * sflatscale if (flatim != NULL) { if (sflatim != NULL) { if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { if (flatscl == 1.) { do i = 1, n { flatval = flat[i] * sflat[line] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[i] * sflat[line] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } } else if (sflatim != NULL) { if (flatscl == 1.) { do i = 1, n { flatval = flat[line] * sflat[i] if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } else { do i = 1, n { flatval = flat[line] * sflat[i] / flatscl if (flatval < minval || flatval > maxval) out[i] = 1. else out[i] = flatval } } } else { flatval = flat[line] * sflat[line] / flatscl if (flatval < minval || flatval > maxval) flatval = 1. do i = 1, n out[i] = flatval } } end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/generic/mkpkg�������������������������������������������������0000664�0000000�0000000�00000000350�13321663143�0021236�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Make CCDRED Package. $checkout libccdred.a mscbin$ $update libccdred.a $checkin libccdred.a mscbin$ $exit libccdred.a: cor.x ../ccdred.h proc.x ../ccdred.h xtfp.x ../xtfixpix.h ; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/generic/proc.x������������������������������������������������0000664�0000000�0000000�00000124644�13321663143�0021353�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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, setsflat, setillum, setfringe .endhelp ---------------------------------------------------------------------- # PROC1 -- Process CCD images with readout axis 1 (lines). procedure proc1s (ccd) pointer ccd # CCD structure bool dosat, dointerp, rep, findmean int l, nc, ncols, coff, loff, nmean, nsum int overscan_type, overscan_c1, noverscan real overscan, darkscale, gainscale, flatscale, sflatscale real illumscale, frgscale, minflat, maxflat double sum, mean short minrep pointer sp, nflatbuf pointer inbuf, outbuf, outbuf1, noibuf, noibuf1 pointer overscan_vec, zerobuf, darkbuf, flatbuf, sflatbuf, illumbuf, fringebuf pointer in, bpin, zeroim, darkim, flatim, flatim2, illumim, fringeim pointer out, bpout, fdnoi pointer outbufr, noibufr double procmeans() real find_overscans() pointer imgl2s(), impl2s(), ccd_gls(), xx_fpss() errchk bld_open begin call smark (sp) # Set input. in = IN_IM(ccd) bpin = BPIN_IM(ccd) # Set output. out = OUT_IM(ccd) bpout = BPOUT_IM(ccd) fdnoi = NOIOUT_IM(ccd) ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 coff = IN_C1(ccd) - OUT_C1(ccd) loff = IN_L1(ccd) - OUT_L1(ccd) if (out == NULL) nc = IM_LEN(in,1) else nc = IM_LEN(out,1) # If there is no output image allocate a buffer. if (out == NULL) call salloc (outbuf, nc, TY_SHORT) noibuf = NULL noibufr = NULL # Set saturated and bleed pixel parameters. If interpolating, # the output I/O is done in BLD_INTERP and we dont't use the # IMIO buffer so we must allocate memory. dosat = false dointerp = false if (CORS(ccd,SATURATE) == YES && (CORS(ccd,FIXPIX) == YES || bpout != NULL || fdnoi != NULL)) { dosat = true if (CORS(ccd,FIXPIX) == YES) dointerp = true if (dointerp && out != NULL) call salloc (outbuf, nc, TY_SHORT) call salloc (outbufr, nc, TY_REAL) if (dointerp && fdnoi != NULL) call salloc (noibuf, nc, TY_SHORT) call salloc (noibufr, nc, TY_REAL) # Initialize the saturation/bleed pixel routines. call bld_open (out, fdnoi, bpout, bpin, dointerp, SATVAL(ccd), 4, SATGROW(ccd), BLDVAL(ccd), 5, BLDGROW(ccd), BLDTRAIL(ccd), IN_C1(ccd), OUT_C1(ccd)) } # Initialize mean value computation. findmean = (CORS(ccd, FINDMEAN) == YES) if (findmean) { sum = 0. nsum = 0. } # Set lower threshold replacement parameters. rep = (CORS(ccd, MINREP) == YES) if (rep) minrep = MINREPLACE(ccd) # Set overscan parameters. 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 } # Set calibration images. # If the calibration image is 1D then just get the data once. 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 = 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),2) == 1) { flatim = NULL flatbuf = ccd_gls (FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), 1) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } else { flatim = FLAT_IM(ccd) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } if (CORS(ccd, SFLATCOR) == 0) { flatim2 = NULL sflatbuf = 1 } else if (IM_LEN(SFLAT_IM(ccd),2) == 1) { flatim2 = NULL sflatbuf = ccd_gls (SFLAT_IM(ccd), SFLAT_C1(ccd), SFLAT_C2(ccd), 1) sflatscale = SFLATSCALE(ccd) minflat = 0.01 maxflat = 100. } else { flatim2 = SFLAT_IM(ccd) sflatscale = SFLATSCALE(ccd) minflat = 0.01 maxflat = 100. } if (CORS(ccd, FLATCOR) != 0 || CORS(ccd, SFLATCOR) != 0) { call salloc (nflatbuf, ncols, TY_REAL) if (flatim == NULL && flatim2 == NULL) call cor1flats (CORS(ccd,1), Memr[nflatbuf], Mems[flatbuf], Mems[sflatbuf], ncols, flatscale, sflatscale, minflat, maxflat) } else nflatbuf = 1 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 output line read line from the input. Data outside the # trim region is simply copied to the output. Procedure XT_FPS # replaces input bad pixels by interpolation. The BLD procedures # find saturated and bleed pixels which are added to the output bad # pixel mask and replaced by interpolation in the output image. # Procedure COR1 does the pixel corrections. A mean of the output # data is computed. # # If not interpolating saturated or bleed pixels this routine does # the output I/O otherwise it is done in BLD_INTERP. # Copy initial untrimmed lines. if (out != NULL) { do l = 1, OUT_L1(ccd)-1 { call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(out,l)], nc) if (fdnoi != NULL) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = 1, OUT_L1(ccd)-1 call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } if (bpout != NULL) { do l = 1, OUT_L1(ccd)-1 call aclrs (Mems[impl2s(bpout,l)], nc) } # Process output lines. do l = OUT_L1(ccd), OUT_L2(ccd) { # Set output line buffer. Use IMIO buffer if an output image # is being created and if not interpolating. if (out != NULL && !dointerp) outbuf = impl2s (out, l) outbuf1 = outbuf + OUT_C1(ccd) - 1 if (fdnoi != NULL && !dointerp) noibuf = impl2s (fdnoi, l) noibuf1 = noibuf + OUT_C1(ccd) - 1 # Get input data, fix bad pixels, and copy to output line buffer. if (BPIN_FP(ccd) != NULL && noibuf != NULL) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[noibuf], nc) inbuf = xx_fpss (BPIN_FP(ccd), in, l+loff, IN_C1(ccd), IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) call amovs (Mems[inbuf+coff], Mems[outbuf], nc) if (BPIN_FP(ccd) == NULL && noibuf != NULL) call amovs (Mems[outbuf], Mems[noibuf], nc) # Set the calibration data. if (overscan_type != 0) { if (overscan_type < OVERSCAN_FIT) overscan = find_overscans (Mems[inbuf+overscan_c1], noverscan, overscan_type) else overscan = Memr[overscan_vec+l-OUT_L1(ccd)] } if (zeroim != NULL) zerobuf = ccd_gls (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), l+ZERO_L1(ccd)-OUT_L1(ccd)) if (darkim != NULL) darkbuf = ccd_gls (darkim, DARK_C1(ccd), DARK_C2(ccd), l+DARK_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL) flatbuf = ccd_gls (flatim, FLAT_C1(ccd), FLAT_C2(ccd), l+FLAT_L1(ccd)-OUT_L1(ccd)) if (flatim2 != NULL) sflatbuf = ccd_gls (flatim2, SFLAT_C1(ccd), SFLAT_C2(ccd), l+SFLAT_L1(ccd)-OUT_L1(ccd)) if (illumim != NULL) illumbuf = ccd_gls (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), l+ILLUM_L1(ccd)-OUT_L1(ccd)) if (fringeim != NULL) fringebuf = ccd_gls (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), l+FRINGE_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL || flatim2 != NULL) call cor1flats (CORS(ccd,1), Memr[nflatbuf], Mems[flatbuf], Mems[sflatbuf], ncols, flatscale, sflatscale, minflat, maxflat) # Find the saturated and bleed pixels before other processing. if (dosat) { call achtsr (Mems[outbuf], Memr[outbufr], nc) call bld_mask (bpout, l, Memr[outbufr], bpin) } else if (bpout != NULL) { if (bpin != NULL) call amovs (Mems[imgl2s(bpin,l+loff)+coff], Mems[impl2s(bpout,l)], nc) else call aclrs (Mems[impl2s(bpout,l)], nc) } # Process the line. call cor1s (CORS(ccd,1), Mems[outbuf1], overscan, Mems[zerobuf], Mems[darkbuf], Memr[nflatbuf], Mems[illumbuf], Mems[fringebuf], ncols, darkscale, flatscale, illumscale, frgscale) if (noibuf != NULL) call cor1s (CORS(ccd,1), Mems[noibuf1], overscan, Mems[zerobuf], Mems[darkbuf], Memr[nflatbuf], Mems[illumbuf], Mems[fringebuf], ncols, darkscale, flatscale, illumscale, frgscale) # Interpolate the saturated and bleed pixels and set the # uninterpolated image and output mask if desired. if (dointerp) { call achtsr (Mems[outbuf], Memr[outbufr], nc) if (noibuf != NULL) call achtsr (Mems[noibuf], Memr[noibufr], nc) call bld_interp (out, fdnoi, l, noibufr, Memr[outbufr]) } # Apply a lower threshold to the output. if (rep) call amaxks (Mems[outbuf1], minrep, Mems[outbuf1], ncols) # Compute the mean. if (findmean) { mean = procmeans (Mems[outbuf1], ncols, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } } # Copy final untrimmed lines. if (out != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) { call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(out,l)], nc) if (fdnoi != NULL) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } if (bpout != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call aclrs (Mems[impl2s(bpout,l)], nc) } # Compute the mean from the sum of the output pixels. if (findmean) { if (nsum > 0) MEAN(ccd) = sum / nsum else MEAN(ccd) = 1. } # Finish up. if (dosat) call bld_close () call sfree (sp) end # PROC2 -- Process CCD images with readout axis 2 (columns). procedure proc2s (ccd) pointer ccd # CCD structure bool dosat, dointerp, rep, findmean int l, nc, ncols, coff, loff, nmean, nsum real darkscale, gainscale, flatscale, sflatscale real illumscale, frgscale, minflat, maxflat double sum, mean short minrep pointer sp, nflatbuf pointer inbuf, outbuf, outbuf1, noibuf, noibuf1 pointer overscan_vec, zerobuf, darkbuf, flatbuf, sflatbuf, illumbuf, fringebuf pointer in, bpin, zeroim, darkim, flatim, flatim2, illumim, fringeim pointer out, bpout, fdnoi pointer outbufr, noibufr double procmeans() pointer imgl2s(), impl2s(), imgs2s(), ccd_gls(), xx_fpss() errchk bld_open begin call smark (sp) # Set input. in = IN_IM(ccd) bpin = BPIN_IM(ccd) # Set output. out = OUT_IM(ccd) bpout = BPOUT_IM(ccd) fdnoi = NOIOUT_IM(ccd) ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 coff = IN_C1(ccd) - OUT_C1(ccd) loff = IN_L1(ccd) - OUT_L1(ccd) if (out == NULL) nc = IM_LEN(in,1) else nc = IM_LEN(out,1) # If there is no output image allocate a buffer. if (out == NULL) call salloc (outbuf, nc, TY_SHORT) noibuf = NULL noibufr = NULL # Set saturated and bleed pixel parameters. If interpolating, # the output I/O is done in BLD_INTERP and we dont't use the # IMIO buffer so we must allocate memory. dosat = false dointerp = false if (CORS(ccd,SATURATE) == YES && (CORS(ccd,FIXPIX) == YES || bpout != NULL || fdnoi != NULL)) { dosat = true if (CORS(ccd,FIXPIX) == YES) dointerp = true if (dointerp && out != NULL) call salloc (outbuf, nc, TY_SHORT) call salloc (outbufr, nc, TY_REAL) if (dointerp && fdnoi != NULL) call salloc (noibuf, nc, TY_SHORT) call salloc (noibufr, nc, TY_REAL) # Initialize the saturation/bleed pixel routines. call bld_open (out, fdnoi, bpout, bpin, dointerp, SATVAL(ccd), 4, SATGROW(ccd), BLDVAL(ccd), 5, BLDGROW(ccd), BLDTRAIL(ccd), IN_C1(ccd), OUT_C1(ccd)) } # Initialize mean value computation. findmean = (CORS(ccd, FINDMEAN) == YES) if (findmean) { sum = 0. nsum = 0. } # Set lower threshold replacement parameters. rep = (CORS(ccd, MINREP) == YES) if (rep) minrep = MINREPLACE(ccd) # Set overscan parameters. overscan_vec = OVERSCAN_VEC(ccd) # Set calibration images. # If the calibration image is 1D then just get the data once. 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)) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } else { flatim = FLAT_IM(ccd) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } if (CORS(ccd, SFLATCOR) == 0) { flatim2 = NULL sflatbuf = 1 } else if (IM_LEN(SFLAT_IM(ccd),1) == 1) { flatim2 = NULL sflatbuf = imgs2s (SFLAT_IM(ccd), 1, 1, SFLAT_L1(ccd), SFLAT_L2(ccd)) sflatscale = SFLATSCALE(ccd) } else { flatim2 = SFLAT_IM(ccd) sflatscale = SFLATSCALE(ccd) } if (CORS(ccd, FLATCOR) != 0 || CORS(ccd, SFLATCOR) != 0) call malloc (nflatbuf, ncols, TY_REAL) else nflatbuf = 1 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 output line read line from the input. Data outside the # trim region is simply copied to the output. Procedure XT_FPS # replaces input bad pixels by interpolation. The BLD procedures # find saturated and bleed pixels which are added to the output bad # pixel mask and replaced by interpolation in the output image. # Procedure COR1 does the pixel corrections. A mean of the output # data is computed. # # If not interpolating saturated or bleed pixels this routine does # the output I/O otherwise it is done in BLD_INTERP. # Copy initial untrimmed lines. if (out != NULL) { do l = 1, OUT_L1(ccd)-1 { call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(out,l)], nc) if (fdnoi != NULL) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = 1, OUT_L1(ccd)-1 call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } if (bpout != NULL) call aclrs (Mems[impl2s(bpout,l)], nc) # Process output lines. do l = OUT_L1(ccd), OUT_L2(ccd) { # Set output line buffer. Use IMIO buffer if an output image # is being created and if not interpolating. if (out != NULL && !dointerp) outbuf = impl2s (out, l) outbuf1 = outbuf + OUT_C1(ccd) - 1 if (fdnoi != NULL && !dointerp) noibuf = impl2s (fdnoi, l) noibuf1 = noibuf + OUT_C1(ccd) - 1 # Get input data, fix bad pixels, and copy to output line buffer. if (BPIN_FP(ccd) != NULL && noibuf != NULL) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[noibuf], nc) inbuf = xx_fpss (BPIN_FP(ccd), in, l+loff, IN_C1(ccd), IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) call amovs (Mems[inbuf+coff], Mems[outbuf], nc) if (BPIN_FP(ccd) == NULL && noibuf != NULL) call amovs (Mems[outbuf], Mems[noibuf], nc) # Set the calibration data. if (zeroim != NULL) zerobuf = ccd_gls (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), l+ZERO_L1(ccd)-OUT_L1(ccd)) if (darkim != NULL) darkbuf = ccd_gls (darkim, DARK_C1(ccd), DARK_C2(ccd), l+DARK_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL) flatbuf = ccd_gls (flatim, FLAT_C1(ccd), FLAT_C2(ccd), l+FLAT_L1(ccd)-OUT_L1(ccd)) if (flatim2 != NULL) sflatbuf = ccd_gls (flatim2, SFLAT_C1(ccd), SFLAT_C2(ccd), l+SFLAT_L1(ccd)-OUT_L1(ccd)) if (illumim != NULL) illumbuf = ccd_gls (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), l+ILLUM_L1(ccd)-OUT_L1(ccd)) if (fringeim != NULL) fringebuf = ccd_gls (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), l+FRINGE_L1(ccd)-OUT_L1(ccd)) call cor2flats (CORS(ccd,1), Memr[nflatbuf], Mems[flatbuf], Mems[sflatbuf], ncols, flatim, flatim2, flatscale, sflatscale, minflat, maxflat) # Find the saturated and bleed pixels before other processing. if (dosat) { call achtsr (Mems[outbuf], Memr[outbufr], nc) call bld_mask (bpout, l, Memr[outbufr], bpin) } else if (bpout != NULL) { if (bpin != NULL) call amovs (Mems[imgl2s(bpin,l+loff)+coff], Mems[impl2s(bpout,l)], nc) else call aclrs (Mems[impl2s(bpout,l)], nc) } # Process the line. call cor2s (l-OUT_L1(ccd)+1, CORS(ccd,1), Mems[outbuf1], Memr[overscan_vec], Mems[zerobuf], Mems[darkbuf], Memr[flatbuf], Mems[illumbuf], Mems[fringebuf], ncols, zeroim, darkscale, illumscale, frgscale) if (noibuf != NULL) call cor2s (l-OUT_L1(ccd)+1, CORS(ccd,1), Mems[noibuf1], Memr[overscan_vec], Mems[zerobuf], Mems[darkbuf], Memr[flatbuf], Mems[illumbuf], Mems[fringebuf], ncols, zeroim, darkscale, illumscale, frgscale) # Interpolate the saturated and bleed pixels and set the # output no interplation image and output mask. if (dointerp) { call achtsr (Mems[outbuf], Memr[outbufr], nc) if (noibuf != NULL) call achtsr (Mems[noibuf], Memr[noibufr], nc) call bld_interp (out, fdnoi, l, noibufr, Memr[outbufr]) } # Apply a lower threshold to the output. if (rep) call amaxks (Mems[outbuf1], minrep, Mems[outbuf1], ncols) # Compute the mean. if (findmean) { mean = procmeans (Mems[outbuf1], ncols, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } } # Copy final untrimmed lines. if (out != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) { call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(out,l)], nc) if (fdnoi != NULL) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call amovs (Mems[imgl2s(in,l+loff)+coff], Mems[impl2s(fdnoi,l)], nc) } if (bpout != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call aclrs (Mems[impl2s(bpout,l)], nc) } # Compute the mean from the sum of the output pixels. if (findmean) { if (nsum > 0) MEAN(ccd) = sum / nsum else MEAN(ccd) = 1. } # Finish up. if (dosat) call bld_close () call sfree (sp) 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 } if (npix > 2) overscan = (overscan - dmin - dmax) / (npix - 2) else overscan = overscan / npix } 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 # PROCMEAN -- Find mean of data. double procedure procmeans (pix, n, ksig, nmean) short pix[n] #I Pixels int n #I Number of pixels real ksig #I Sigma clipping factor int nmean #O Number of pixels in the mean real mean, sigma, lcut, hcut int awvgs() real asums() begin if (ksig <= 0.) { mean = asums (pix, n) / n nmean = n } else { lcut = 0. hcut = 0. nmean = awvgs (pix, n, mean, sigma, lcut, hcut) lcut = mean - abs (ksig) * sigma hcut = mean + abs (ksig) * sigma nmean = awvgs (pix, n, mean, sigma, lcut, hcut) } return (double (mean)) end # PROC1 -- Process CCD images with readout axis 1 (lines). procedure proc1r (ccd) pointer ccd # CCD structure bool dosat, dointerp, rep, findmean int l, nc, ncols, coff, loff, nmean, nsum int overscan_type, overscan_c1, noverscan real overscan, darkscale, gainscale, flatscale, sflatscale real illumscale, frgscale, minflat, maxflat double sum, mean real minrep pointer sp, nflatbuf pointer inbuf, outbuf, outbuf1, noibuf, noibuf1 pointer overscan_vec, zerobuf, darkbuf, flatbuf, sflatbuf, illumbuf, fringebuf pointer in, bpin, zeroim, darkim, flatim, flatim2, illumim, fringeim pointer out, bpout, fdnoi double procmeanr() real find_overscanr() pointer imgl2r(), impl2r(), ccd_glr(), xx_fpsr() pointer impl2s(), imgl2s() errchk bld_open begin call smark (sp) # Set input. in = IN_IM(ccd) bpin = BPIN_IM(ccd) # Set output. out = OUT_IM(ccd) bpout = BPOUT_IM(ccd) fdnoi = NOIOUT_IM(ccd) ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 coff = IN_C1(ccd) - OUT_C1(ccd) loff = IN_L1(ccd) - OUT_L1(ccd) if (out == NULL) nc = IM_LEN(in,1) else nc = IM_LEN(out,1) # If there is no output image allocate a buffer. if (out == NULL) call salloc (outbuf, nc, TY_REAL) noibuf = NULL # Set saturated and bleed pixel parameters. If interpolating, # the output I/O is done in BLD_INTERP and we dont't use the # IMIO buffer so we must allocate memory. dosat = false dointerp = false if (CORS(ccd,SATURATE) == YES && (CORS(ccd,FIXPIX) == YES || bpout != NULL || fdnoi != NULL)) { dosat = true if (CORS(ccd,FIXPIX) == YES) dointerp = true if (dointerp && out != NULL) call salloc (outbuf, nc, TY_REAL) if (dointerp && fdnoi != NULL) call salloc (noibuf, nc, TY_REAL) # Initialize the saturation/bleed pixel routines. call bld_open (out, fdnoi, bpout, bpin, dointerp, SATVAL(ccd), 4, SATGROW(ccd), BLDVAL(ccd), 5, BLDGROW(ccd), BLDTRAIL(ccd), IN_C1(ccd), OUT_C1(ccd)) } # Initialize mean value computation. findmean = (CORS(ccd, FINDMEAN) == YES) if (findmean) { sum = 0. nsum = 0. } # Set lower threshold replacement parameters. rep = (CORS(ccd, MINREP) == YES) if (rep) minrep = MINREPLACE(ccd) # Set overscan parameters. 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 } # Set calibration images. # If the calibration image is 1D then just get the data once. 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 = 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),2) == 1) { flatim = NULL flatbuf = ccd_glr (FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), 1) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } else { flatim = FLAT_IM(ccd) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } if (CORS(ccd, SFLATCOR) == 0) { flatim2 = NULL sflatbuf = 1 } else if (IM_LEN(SFLAT_IM(ccd),2) == 1) { flatim2 = NULL sflatbuf = ccd_glr (SFLAT_IM(ccd), SFLAT_C1(ccd), SFLAT_C2(ccd), 1) sflatscale = SFLATSCALE(ccd) minflat = 0.01 maxflat = 100. } else { flatim2 = SFLAT_IM(ccd) sflatscale = SFLATSCALE(ccd) minflat = 0.01 maxflat = 100. } if (CORS(ccd, FLATCOR) != 0 || CORS(ccd, SFLATCOR) != 0) { call salloc (nflatbuf, ncols, TY_REAL) if (flatim == NULL && flatim2 == NULL) call cor1flatr (CORS(ccd,1), Memr[nflatbuf], Memr[flatbuf], Memr[sflatbuf], ncols, flatscale, sflatscale, minflat, maxflat) } else nflatbuf = 1 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 output line read line from the input. Data outside the # trim region is simply copied to the output. Procedure XT_FPS # replaces input bad pixels by interpolation. The BLD procedures # find saturated and bleed pixels which are added to the output bad # pixel mask and replaced by interpolation in the output image. # Procedure COR1 does the pixel corrections. A mean of the output # data is computed. # # If not interpolating saturated or bleed pixels this routine does # the output I/O otherwise it is done in BLD_INTERP. # Copy initial untrimmed lines. if (out != NULL) { do l = 1, OUT_L1(ccd)-1 { call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(out,l)], nc) if (fdnoi != NULL) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = 1, OUT_L1(ccd)-1 call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } if (bpout != NULL) { do l = 1, OUT_L1(ccd)-1 call aclrs (Mems[impl2s(bpout,l)], nc) } # Process output lines. do l = OUT_L1(ccd), OUT_L2(ccd) { # Set output line buffer. Use IMIO buffer if an output image # is being created and if not interpolating. if (out != NULL && !dointerp) outbuf = impl2r (out, l) outbuf1 = outbuf + OUT_C1(ccd) - 1 if (fdnoi != NULL && !dointerp) noibuf = impl2r (fdnoi, l) noibuf1 = noibuf + OUT_C1(ccd) - 1 # Get input data, fix bad pixels, and copy to output line buffer. if (BPIN_FP(ccd) != NULL && noibuf != NULL) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[noibuf], nc) inbuf = xx_fpsr (BPIN_FP(ccd), in, l+loff, IN_C1(ccd), IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) call amovr (Memr[inbuf+coff], Memr[outbuf], nc) if (BPIN_FP(ccd) == NULL && noibuf != NULL) call amovr (Memr[outbuf], Memr[noibuf], nc) # Set the calibration data. if (overscan_type != 0) { if (overscan_type < OVERSCAN_FIT) overscan = find_overscanr (Memr[inbuf+overscan_c1], noverscan, overscan_type) else overscan = Memr[overscan_vec+l-OUT_L1(ccd)] } if (zeroim != NULL) zerobuf = ccd_glr (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), l+ZERO_L1(ccd)-OUT_L1(ccd)) if (darkim != NULL) darkbuf = ccd_glr (darkim, DARK_C1(ccd), DARK_C2(ccd), l+DARK_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL) flatbuf = ccd_glr (flatim, FLAT_C1(ccd), FLAT_C2(ccd), l+FLAT_L1(ccd)-OUT_L1(ccd)) if (flatim2 != NULL) sflatbuf = ccd_glr (flatim2, SFLAT_C1(ccd), SFLAT_C2(ccd), l+SFLAT_L1(ccd)-OUT_L1(ccd)) if (illumim != NULL) illumbuf = ccd_glr (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), l+ILLUM_L1(ccd)-OUT_L1(ccd)) if (fringeim != NULL) fringebuf = ccd_glr (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), l+FRINGE_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL || flatim2 != NULL) call cor1flatr (CORS(ccd,1), Memr[nflatbuf], Memr[flatbuf], Memr[sflatbuf], ncols, flatscale, sflatscale, minflat, maxflat) # Find the saturated and bleed pixels before other processing. if (dosat) { call bld_mask (bpout, l, Memr[outbuf], bpin) } else if (bpout != NULL) { if (bpin != NULL) call amovs (Mems[imgl2s(bpin,l+loff)+coff], Mems[impl2s(bpout,l)], nc) else call aclrs (Mems[impl2s(bpout,l)], nc) } # Process the line. call cor1r (CORS(ccd,1), Memr[outbuf1], overscan, Memr[zerobuf], Memr[darkbuf], Memr[nflatbuf], Memr[illumbuf], Memr[fringebuf], ncols, darkscale, flatscale, illumscale, frgscale) if (noibuf != NULL) call cor1r (CORS(ccd,1), Memr[noibuf1], overscan, Memr[zerobuf], Memr[darkbuf], Memr[nflatbuf], Memr[illumbuf], Memr[fringebuf], ncols, darkscale, flatscale, illumscale, frgscale) # Interpolate the saturated and bleed pixels and set the # uninterpolated image and output mask if desired. if (dointerp) { call bld_interp (out, fdnoi, l, noibuf, Memr[outbuf]) } # Apply a lower threshold to the output. if (rep) call amaxkr (Memr[outbuf1], minrep, Memr[outbuf1], ncols) # Compute the mean. if (findmean) { mean = procmeanr (Memr[outbuf1], ncols, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } } # Copy final untrimmed lines. if (out != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) { call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(out,l)], nc) if (fdnoi != NULL) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } if (bpout != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call aclrs (Mems[impl2s(bpout,l)], nc) } # Compute the mean from the sum of the output pixels. if (findmean) { if (nsum > 0) MEAN(ccd) = sum / nsum else MEAN(ccd) = 1. } # Finish up. if (dosat) call bld_close () call sfree (sp) end # PROC2 -- Process CCD images with readout axis 2 (columns). procedure proc2r (ccd) pointer ccd # CCD structure bool dosat, dointerp, rep, findmean int l, nc, ncols, coff, loff, nmean, nsum real darkscale, gainscale, flatscale, sflatscale real illumscale, frgscale, minflat, maxflat double sum, mean real minrep pointer sp, nflatbuf pointer inbuf, outbuf, outbuf1, noibuf, noibuf1 pointer overscan_vec, zerobuf, darkbuf, flatbuf, sflatbuf, illumbuf, fringebuf pointer in, bpin, zeroim, darkim, flatim, flatim2, illumim, fringeim pointer out, bpout, fdnoi double procmeanr() pointer imgl2r(), impl2r(), imgs2r(), ccd_glr(), xx_fpsr() pointer impl2s(), imgl2s() errchk bld_open begin call smark (sp) # Set input. in = IN_IM(ccd) bpin = BPIN_IM(ccd) # Set output. out = OUT_IM(ccd) bpout = BPOUT_IM(ccd) fdnoi = NOIOUT_IM(ccd) ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 coff = IN_C1(ccd) - OUT_C1(ccd) loff = IN_L1(ccd) - OUT_L1(ccd) if (out == NULL) nc = IM_LEN(in,1) else nc = IM_LEN(out,1) # If there is no output image allocate a buffer. if (out == NULL) call salloc (outbuf, nc, TY_REAL) noibuf = NULL # Set saturated and bleed pixel parameters. If interpolating, # the output I/O is done in BLD_INTERP and we dont't use the # IMIO buffer so we must allocate memory. dosat = false dointerp = false if (CORS(ccd,SATURATE) == YES && (CORS(ccd,FIXPIX) == YES || bpout != NULL || fdnoi != NULL)) { dosat = true if (CORS(ccd,FIXPIX) == YES) dointerp = true if (dointerp && out != NULL) call salloc (outbuf, nc, TY_REAL) if (dointerp && fdnoi != NULL) call salloc (noibuf, nc, TY_REAL) # Initialize the saturation/bleed pixel routines. call bld_open (out, fdnoi, bpout, bpin, dointerp, SATVAL(ccd), 4, SATGROW(ccd), BLDVAL(ccd), 5, BLDGROW(ccd), BLDTRAIL(ccd), IN_C1(ccd), OUT_C1(ccd)) } # Initialize mean value computation. findmean = (CORS(ccd, FINDMEAN) == YES) if (findmean) { sum = 0. nsum = 0. } # Set lower threshold replacement parameters. rep = (CORS(ccd, MINREP) == YES) if (rep) minrep = MINREPLACE(ccd) # Set overscan parameters. overscan_vec = OVERSCAN_VEC(ccd) # Set calibration images. # If the calibration image is 1D then just get the data once. 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)) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } else { flatim = FLAT_IM(ccd) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } if (CORS(ccd, SFLATCOR) == 0) { flatim2 = NULL sflatbuf = 1 } else if (IM_LEN(SFLAT_IM(ccd),1) == 1) { flatim2 = NULL sflatbuf = imgs2r (SFLAT_IM(ccd), 1, 1, SFLAT_L1(ccd), SFLAT_L2(ccd)) sflatscale = SFLATSCALE(ccd) } else { flatim2 = SFLAT_IM(ccd) sflatscale = SFLATSCALE(ccd) } if (CORS(ccd, FLATCOR) != 0 || CORS(ccd, SFLATCOR) != 0) call malloc (nflatbuf, ncols, TY_REAL) else nflatbuf = 1 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 output line read line from the input. Data outside the # trim region is simply copied to the output. Procedure XT_FPS # replaces input bad pixels by interpolation. The BLD procedures # find saturated and bleed pixels which are added to the output bad # pixel mask and replaced by interpolation in the output image. # Procedure COR1 does the pixel corrections. A mean of the output # data is computed. # # If not interpolating saturated or bleed pixels this routine does # the output I/O otherwise it is done in BLD_INTERP. # Copy initial untrimmed lines. if (out != NULL) { do l = 1, OUT_L1(ccd)-1 { call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(out,l)], nc) if (fdnoi != NULL) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = 1, OUT_L1(ccd)-1 call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } if (bpout != NULL) call aclrs (Mems[impl2s(bpout,l)], nc) # Process output lines. do l = OUT_L1(ccd), OUT_L2(ccd) { # Set output line buffer. Use IMIO buffer if an output image # is being created and if not interpolating. if (out != NULL && !dointerp) outbuf = impl2r (out, l) outbuf1 = outbuf + OUT_C1(ccd) - 1 if (fdnoi != NULL && !dointerp) noibuf = impl2r (fdnoi, l) noibuf1 = noibuf + OUT_C1(ccd) - 1 # Get input data, fix bad pixels, and copy to output line buffer. if (BPIN_FP(ccd) != NULL && noibuf != NULL) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[noibuf], nc) inbuf = xx_fpsr (BPIN_FP(ccd), in, l+loff, IN_C1(ccd), IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) call amovr (Memr[inbuf+coff], Memr[outbuf], nc) if (BPIN_FP(ccd) == NULL && noibuf != NULL) call amovr (Memr[outbuf], Memr[noibuf], nc) # Set the calibration data. if (zeroim != NULL) zerobuf = ccd_glr (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), l+ZERO_L1(ccd)-OUT_L1(ccd)) if (darkim != NULL) darkbuf = ccd_glr (darkim, DARK_C1(ccd), DARK_C2(ccd), l+DARK_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL) flatbuf = ccd_glr (flatim, FLAT_C1(ccd), FLAT_C2(ccd), l+FLAT_L1(ccd)-OUT_L1(ccd)) if (flatim2 != NULL) sflatbuf = ccd_glr (flatim2, SFLAT_C1(ccd), SFLAT_C2(ccd), l+SFLAT_L1(ccd)-OUT_L1(ccd)) if (illumim != NULL) illumbuf = ccd_glr (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), l+ILLUM_L1(ccd)-OUT_L1(ccd)) if (fringeim != NULL) fringebuf = ccd_glr (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), l+FRINGE_L1(ccd)-OUT_L1(ccd)) call cor2flatr (CORS(ccd,1), Memr[nflatbuf], Memr[flatbuf], Memr[sflatbuf], ncols, flatim, flatim2, flatscale, sflatscale, minflat, maxflat) # Find the saturated and bleed pixels before other processing. if (dosat) { call bld_mask (bpout, l, Memr[outbuf], bpin) } else if (bpout != NULL) { if (bpin != NULL) call amovs (Mems[imgl2s(bpin,l+loff)+coff], Mems[impl2s(bpout,l)], nc) else call aclrs (Mems[impl2s(bpout,l)], nc) } # Process the line. call cor2r (l-OUT_L1(ccd)+1, CORS(ccd,1), Memr[outbuf1], Memr[overscan_vec], Memr[zerobuf], Memr[darkbuf], Memr[flatbuf], Memr[illumbuf], Memr[fringebuf], ncols, zeroim, darkscale, illumscale, frgscale) if (noibuf != NULL) call cor2r (l-OUT_L1(ccd)+1, CORS(ccd,1), Memr[noibuf1], Memr[overscan_vec], Memr[zerobuf], Memr[darkbuf], Memr[flatbuf], Memr[illumbuf], Memr[fringebuf], ncols, zeroim, darkscale, illumscale, frgscale) # Interpolate the saturated and bleed pixels and set the # output no interplation image and output mask. if (dointerp) { call bld_interp (out, fdnoi, l, noibuf, Memr[outbuf]) } # Apply a lower threshold to the output. if (rep) call amaxkr (Memr[outbuf1], minrep, Memr[outbuf1], ncols) # Compute the mean. if (findmean) { mean = procmeanr (Memr[outbuf1], ncols, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } } # Copy final untrimmed lines. if (out != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) { call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(out,l)], nc) if (fdnoi != NULL) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call amovr (Memr[imgl2r(in,l+loff)+coff], Memr[impl2r(fdnoi,l)], nc) } if (bpout != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call aclrs (Mems[impl2s(bpout,l)], nc) } # Compute the mean from the sum of the output pixels. if (findmean) { if (nsum > 0) MEAN(ccd) = sum / nsum else MEAN(ccd) = 1. } # Finish up. if (dosat) call bld_close () call sfree (sp) 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 } if (npix > 2) overscan = (overscan - dmin - dmax) / (npix - 2) else overscan = overscan / npix } 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 # PROCMEAN -- Find mean of data. double procedure procmeanr (pix, n, ksig, nmean) real pix[n] #I Pixels int n #I Number of pixels real ksig #I Sigma clipping factor int nmean #O Number of pixels in the mean real mean, sigma, lcut, hcut int awvgr() real asumr() begin if (ksig <= 0.) { mean = asumr (pix, n) / n nmean = n } else { lcut = 0. hcut = 0. nmean = awvgr (pix, n, mean, sigma, lcut, hcut) lcut = mean - abs (ksig) * sigma hcut = mean + abs (ksig) * sigma nmean = awvgr (pix, n, mean, sigma, lcut, hcut) } return (double (mean)) end ��������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/generic/xtfp.x������������������������������������������������0000664�0000000�0000000�00000072760�13321663143�0021372�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include "../xtfixpix.h" # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure xx_fps (fp, im, line, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer imgl2s(), xx_fpss() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2s (im, line)) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (xx_fpss (fp, im, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure xx_fpss (fp, im, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val short indef pointer pm, data, bp bool pm_linenotempty() pointer imgl2s(), xx_fpvals() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2s (im, line)) # Initialize pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_SHORT call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFS call amovks (indef, Mems[FP_V1(fp,1)], ncols) call amovks (indef, Mems[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (imgl2s (im, line)) else return (xx_fpvals (fp, im, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=nc && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=nc && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Mems[data+c1-1] else a = Mems[data+c2-1] if (c2 <= col2) b = (Mems[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargs (Mems[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, " %4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, " %4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Mems[FP_V1(fp,j)] else c = Mems[FP_V2(fp,j)] if (l2 <= line2) { d = (Mems[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargs (Mems[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Mems[data+i-1] = nint (val) } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure xx_fpvals (fp, im, line) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int i pointer data, imgl2s() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mems[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Mems[FP_V2(fp,i)] = 0. } return (NULL) } data = imgl2s (im, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mems[FP_V1(fp,i)] = Mems[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Mems[FP_V2(fp,i)] = Mems[data+FP_COL(fp,i)-1] } return (data) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure xx_fpi (fp, im, line, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer imgl2i(), xx_fpsi() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2i (im, line)) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (xx_fpsi (fp, im, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure xx_fpsi (fp, im, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val int indef pointer pm, data, bp bool pm_linenotempty() pointer imgl2i(), xx_fpvali() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2i (im, line)) # Initialize pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_INT call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFI call amovki (indef, Memi[FP_V1(fp,1)], ncols) call amovki (indef, Memi[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (imgl2i (im, line)) else return (xx_fpvali (fp, im, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=nc && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=nc && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Memi[data+c1-1] else a = Memi[data+c2-1] if (c2 <= col2) b = (Memi[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargi (Memi[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, " %4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, " %4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Memi[FP_V1(fp,j)] else c = Memi[FP_V2(fp,j)] if (l2 <= line2) { d = (Memi[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargi (Memi[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Memi[data+i-1] = nint (val) } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure xx_fpvali (fp, im, line) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int i pointer data, imgl2i() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memi[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Memi[FP_V2(fp,i)] = 0. } return (NULL) } data = imgl2i (im, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memi[FP_V1(fp,i)] = Memi[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Memi[FP_V2(fp,i)] = Memi[data+FP_COL(fp,i)-1] } return (data) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure xx_fpl (fp, im, line, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer imgl2l(), xx_fpsl() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2l (im, line)) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (xx_fpsl (fp, im, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure xx_fpsl (fp, im, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val long indef pointer pm, data, bp bool pm_linenotempty() pointer imgl2l(), xx_fpvall() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2l (im, line)) # Initialize pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_LONG call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFL call amovkl (indef, Meml[FP_V1(fp,1)], ncols) call amovkl (indef, Meml[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (imgl2l (im, line)) else return (xx_fpvall (fp, im, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=nc && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=nc && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Meml[data+c1-1] else a = Meml[data+c2-1] if (c2 <= col2) b = (Meml[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargl (Meml[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, " %4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, " %4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Meml[FP_V1(fp,j)] else c = Meml[FP_V2(fp,j)] if (l2 <= line2) { d = (Meml[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargl (Meml[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Meml[data+i-1] = nint (val) } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure xx_fpvall (fp, im, line) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int i pointer data, imgl2l() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Meml[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Meml[FP_V2(fp,i)] = 0. } return (NULL) } data = imgl2l (im, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Meml[FP_V1(fp,i)] = Meml[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Meml[FP_V2(fp,i)] = Meml[data+FP_COL(fp,i)-1] } return (data) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure xx_fpr (fp, im, line, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer imgl2r(), xx_fpsr() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2r (im, line)) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (xx_fpsr (fp, im, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure xx_fpsr (fp, im, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val real indef pointer pm, data, bp bool pm_linenotempty() pointer imgl2r(), xx_fpvalr() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2r (im, line)) # Initialize pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_REAL call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFR call amovkr (indef, Memr[FP_V1(fp,1)], ncols) call amovkr (indef, Memr[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (imgl2r (im, line)) else return (xx_fpvalr (fp, im, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=nc && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=nc && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Memr[data+c1-1] else a = Memr[data+c2-1] if (c2 <= col2) b = (Memr[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargr (Memr[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, " %4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, " %4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Memr[FP_V1(fp,j)] else c = Memr[FP_V2(fp,j)] if (l2 <= line2) { d = (Memr[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargr (Memr[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Memr[data+i-1] = val } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure xx_fpvalr (fp, im, line) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int i pointer data, imgl2r() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memr[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Memr[FP_V2(fp,i)] = 0. } return (NULL) } data = imgl2r (im, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memr[FP_V1(fp,i)] = Memr[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Memr[FP_V2(fp,i)] = Memr[data+FP_COL(fp,i)-1] } return (data) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure xx_fpd (fp, im, line, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer imgl2d(), xx_fpsd() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2d (im, line)) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (xx_fpsd (fp, im, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure xx_fpsd (fp, im, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] double a, b, c, d, val double indef pointer pm, data, bp bool pm_linenotempty() pointer imgl2d(), xx_fpvald() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2d (im, line)) # Initialize pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_DOUBLE call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFD call amovkd (indef, Memd[FP_V1(fp,1)], ncols) call amovkd (indef, Memd[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (imgl2d (im, line)) else return (xx_fpvald (fp, im, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=nc && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=nc && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Memd[data+c1-1] else a = Memd[data+c2-1] if (c2 <= col2) b = (Memd[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargd (Memd[data+i-1]) call pargd (val) if (c1 >= col1) { call fprintf (fd, " %4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, " %4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Memd[FP_V1(fp,j)] else c = Memd[FP_V2(fp,j)] if (l2 <= line2) { d = (Memd[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargd (Memd[data+i-1]) call pargd (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Memd[data+i-1] = val } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure xx_fpvald (fp, im, line) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int i pointer data, imgl2d() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memd[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Memd[FP_V2(fp,i)] = 0. } return (NULL) } data = imgl2d (im, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memd[FP_V1(fp,i)] = Memd[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Memd[FP_V2(fp,i)] = Memd[data+FP_COL(fp,i)-1] } return (data) end ����������������mscred-5.05-2018.07.09/src/ccdred/src/hdmflag.x�����������������������������������������������������0000664�0000000�0000000�00000002321�13321663143�0020361�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������define STEPS "|overscan|zerocor|flatcor|" define O 1 define Z 2 define F 3 # HDMFLAG -- Determine if a 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 hdmflag (im, name) pointer im # IMIO pointer char name[ARB] # Header flag name int i, strdic(), stridxs() 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) # Support both PROCTOOL and CCDPROC conventions. call hdmgstr (im, "PROCDONE", Memc[str1], SZ_LINE) if (Memc[str1] != EOS) { i = strdic (name, Memc[str2], SZ_LINE, STEPS) switch (i) { case O: flag = (stridxs ("B", Memc[str1]) > 0) case Z: flag = (stridxs ("ZS", Memc[str1]) > 0) case F: flag = (stridxs ("F", Memc[str1]) > 0) default: flag = false } } else { # 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 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/hdrmap.com����������������������������������������������������0000664�0000000�0000000�00000000127�13321663143�0020543�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Common for HDRMAP package. pointer stp # Symbol table pointer common /hdmcom/ stp �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/hdrmap.x������������������������������������������������������0000664�0000000�0000000�00000031213�13321663143�0020234�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include .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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/mkpkg���������������������������������������������������������0000664�0000000�0000000�00000004643�13321663143�0017633�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Make CCDRED Package. $checkout libccdred.a mscbin$ $update libccdred.a $checkin libccdred.a mscbin$ $exit update: $call update@combine ; 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 $ifolder (generic/xtfp.x, xtfp.gx) $(GEN) xtfp.gx -o generic/xtfp.x $endif ; lcombine: $call lcombine@combine ; libccdred.a: $ifeq (USE_GENERIC, yes) $call generic $endif @generic bleed.x bleed.com calimage.x calimage.com calimage.h ccdtypes.h \ ccdamp.x ccdcache.x ccdcache.com ccdcache.com ccdcache.h ccdtypes.h\ ccdcheck.x ccdtypes.h ccdcmp.x ccdcopy.x ccddelete.x ccdflag.x ccdlog.x ccdmean.x ccdnscan.x ccdtypes.h ccdproc.x ccdred.h ccdtypes.h ccdsection.x ccdsubsets.x ccdtypes.x ccdtypes.h doproc.x ccdred.h hdrmap.x hdrmap.com hdmflag.x readcor.x scancor.x setbpmask.x ccdred.h setdark.x ccdred.h ccdtypes.h setfixpix.x ccdred.h ccdtypes.h setflat.x ccdred.h ccdtypes.h setfringe.x ccdred.h ccdtypes.h setheader.x ccdred.h setillum.x ccdred.h ccdtypes.h setinmask.x ccdred.h ccdtypes.h setinput.x ccdtypes.h setinteract.x setnoi.x ccdred.h setoutput.x ccdred.h setoverscan.x ccdred.h \ setproc.x ccdred.h setreadcor.x ccdred.h setsaturate.x ccdred.h setsections.x ccdred.h setsflat.x ccdred.h ccdtypes.h settrim.x ccdred.h setzero.x ccdred.h ccdtypes.h t_ccdgroups.x t_ccdhedit.x t_ccdinst.x ccdtypes.h t_ccdlist.x ccdtypes.h t_ccdmask.x t_ccdproc.x ccdred.h t_ccdtool.x ccdred.h timelog.x xtfixpix.x xtfixpix.h xtpmmap.x ; ���������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/proc.gx�������������������������������������������������������0000664�0000000�0000000�00000057543�13321663143�0020111�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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, setsflat, setillum, setfringe .endhelp ---------------------------------------------------------------------- $for (sr) # PROC1 -- Process CCD images with readout axis 1 (lines). procedure proc1$t (ccd) pointer ccd # CCD structure bool dosat, dointerp, rep, findmean int l, nc, ncols, coff, loff, nmean, nsum int overscan_type, overscan_c1, noverscan real overscan, darkscale, gainscale, flatscale, sflatscale real illumscale, frgscale, minflat, maxflat double sum, mean PIXEL minrep pointer sp, nflatbuf pointer inbuf, outbuf, outbuf1, noibuf, noibuf1 pointer overscan_vec, zerobuf, darkbuf, flatbuf, sflatbuf, illumbuf, fringebuf pointer in, bpin, zeroim, darkim, flatim, flatim2, illumim, fringeim pointer out, bpout, fdnoi $if (datatype != r) pointer outbufr, noibufr $endif double procmean$t() real find_overscan$t() pointer imgl2$t(), impl2$t(), ccd_gl$t(), xx_fps$t() $if (datatype != s) pointer impl2s(), imgl2s() $endif errchk bld_open begin call smark (sp) # Set input. in = IN_IM(ccd) bpin = BPIN_IM(ccd) # Set output. out = OUT_IM(ccd) bpout = BPOUT_IM(ccd) fdnoi = NOIOUT_IM(ccd) ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 coff = IN_C1(ccd) - OUT_C1(ccd) loff = IN_L1(ccd) - OUT_L1(ccd) if (out == NULL) nc = IM_LEN(in,1) else nc = IM_LEN(out,1) # If there is no output image allocate a buffer. if (out == NULL) call salloc (outbuf, nc, TY_PIXEL) noibuf = NULL $if (datatype != r) noibufr = NULL $endif # Set saturated and bleed pixel parameters. If interpolating, # the output I/O is done in BLD_INTERP and we dont't use the # IMIO buffer so we must allocate memory. dosat = false dointerp = false if (CORS(ccd,SATURATE) == YES && (CORS(ccd,FIXPIX) == YES || bpout != NULL || fdnoi != NULL)) { dosat = true if (CORS(ccd,FIXPIX) == YES) dointerp = true if (dointerp && out != NULL) call salloc (outbuf, nc, TY_PIXEL) $if (datatype != r) call salloc (outbufr, nc, TY_REAL) $endif if (dointerp && fdnoi != NULL) call salloc (noibuf, nc, TY_PIXEL) $if (datatype != r) call salloc (noibufr, nc, TY_REAL) $endif # Initialize the saturation/bleed pixel routines. call bld_open (out, fdnoi, bpout, bpin, dointerp, SATVAL(ccd), 4, SATGROW(ccd), BLDVAL(ccd), 5, BLDGROW(ccd), BLDTRAIL(ccd), IN_C1(ccd), OUT_C1(ccd)) } # Initialize mean value computation. findmean = (CORS(ccd, FINDMEAN) == YES) if (findmean) { sum = 0. nsum = 0. } # Set lower threshold replacement parameters. rep = (CORS(ccd, MINREP) == YES) if (rep) minrep = MINREPLACE(ccd) # Set overscan parameters. 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 } # Set calibration images. # If the calibration image is 1D then just get the data once. 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 = 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),2) == 1) { flatim = NULL flatbuf = ccd_gl$t (FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), 1) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } else { flatim = FLAT_IM(ccd) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } if (CORS(ccd, SFLATCOR) == 0) { flatim2 = NULL sflatbuf = 1 } else if (IM_LEN(SFLAT_IM(ccd),2) == 1) { flatim2 = NULL sflatbuf = ccd_gl$t (SFLAT_IM(ccd), SFLAT_C1(ccd), SFLAT_C2(ccd), 1) sflatscale = SFLATSCALE(ccd) minflat = 0.01 maxflat = 100. } else { flatim2 = SFLAT_IM(ccd) sflatscale = SFLATSCALE(ccd) minflat = 0.01 maxflat = 100. } if (CORS(ccd, FLATCOR) != 0 || CORS(ccd, SFLATCOR) != 0) { call salloc (nflatbuf, ncols, TY_REAL) if (flatim == NULL && flatim2 == NULL) call cor1flat$t (CORS(ccd,1), Memr[nflatbuf], Mem$t[flatbuf], Mem$t[sflatbuf], ncols, flatscale, sflatscale, minflat, maxflat) } else nflatbuf = 1 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 output line read line from the input. Data outside the # trim region is simply copied to the output. Procedure XT_FPS # replaces input bad pixels by interpolation. The BLD procedures # find saturated and bleed pixels which are added to the output bad # pixel mask and replaced by interpolation in the output image. # Procedure COR1 does the pixel corrections. A mean of the output # data is computed. # # If not interpolating saturated or bleed pixels this routine does # the output I/O otherwise it is done in BLD_INTERP. # Copy initial untrimmed lines. if (out != NULL) { do l = 1, OUT_L1(ccd)-1 { call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(out,l)], nc) if (fdnoi != NULL) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = 1, OUT_L1(ccd)-1 call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } if (bpout != NULL) { do l = 1, OUT_L1(ccd)-1 call aclrs (Mems[impl2s(bpout,l)], nc) } # Process output lines. do l = OUT_L1(ccd), OUT_L2(ccd) { # Set output line buffer. Use IMIO buffer if an output image # is being created and if not interpolating. if (out != NULL && !dointerp) outbuf = impl2$t (out, l) outbuf1 = outbuf + OUT_C1(ccd) - 1 if (fdnoi != NULL && !dointerp) noibuf = impl2$t (fdnoi, l) noibuf1 = noibuf + OUT_C1(ccd) - 1 # Get input data, fix bad pixels, and copy to output line buffer. if (BPIN_FP(ccd) != NULL && noibuf != NULL) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[noibuf], nc) inbuf = xx_fps$t (BPIN_FP(ccd), in, l+loff, IN_C1(ccd), IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) call amov$t (Mem$t[inbuf+coff], Mem$t[outbuf], nc) if (BPIN_FP(ccd) == NULL && noibuf != NULL) call amov$t (Mem$t[outbuf], Mem$t[noibuf], nc) # Set the calibration data. 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+l-OUT_L1(ccd)] } if (zeroim != NULL) zerobuf = ccd_gl$t (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), l+ZERO_L1(ccd)-OUT_L1(ccd)) if (darkim != NULL) darkbuf = ccd_gl$t (darkim, DARK_C1(ccd), DARK_C2(ccd), l+DARK_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL) flatbuf = ccd_gl$t (flatim, FLAT_C1(ccd), FLAT_C2(ccd), l+FLAT_L1(ccd)-OUT_L1(ccd)) if (flatim2 != NULL) sflatbuf = ccd_gl$t (flatim2, SFLAT_C1(ccd), SFLAT_C2(ccd), l+SFLAT_L1(ccd)-OUT_L1(ccd)) if (illumim != NULL) illumbuf = ccd_gl$t (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), l+ILLUM_L1(ccd)-OUT_L1(ccd)) if (fringeim != NULL) fringebuf = ccd_gl$t (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), l+FRINGE_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL || flatim2 != NULL) call cor1flat$t (CORS(ccd,1), Memr[nflatbuf], Mem$t[flatbuf], Mem$t[sflatbuf], ncols, flatscale, sflatscale, minflat, maxflat) # Find the saturated and bleed pixels before other processing. if (dosat) { $if (datatype == r) call bld_mask (bpout, l, Memr[outbuf], bpin) $else call acht$tr (Mem$t[outbuf], Memr[outbufr], nc) call bld_mask (bpout, l, Memr[outbufr], bpin) $endif } else if (bpout != NULL) { if (bpin != NULL) call amovs (Mems[imgl2s(bpin,l+loff)+coff], Mems[impl2s(bpout,l)], nc) else call aclrs (Mems[impl2s(bpout,l)], nc) } # Process the line. call cor1$t (CORS(ccd,1), Mem$t[outbuf1], overscan, Mem$t[zerobuf], Mem$t[darkbuf], Memr[nflatbuf], Mem$t[illumbuf], Mem$t[fringebuf], ncols, darkscale, flatscale, illumscale, frgscale) if (noibuf != NULL) call cor1$t (CORS(ccd,1), Mem$t[noibuf1], overscan, Mem$t[zerobuf], Mem$t[darkbuf], Memr[nflatbuf], Mem$t[illumbuf], Mem$t[fringebuf], ncols, darkscale, flatscale, illumscale, frgscale) # Interpolate the saturated and bleed pixels and set the # uninterpolated image and output mask if desired. if (dointerp) { $if (datatype == r) call bld_interp (out, fdnoi, l, noibuf, Mem$t[outbuf]) $else call acht$tr (Mem$t[outbuf], Memr[outbufr], nc) if (noibuf != NULL) call acht$tr (Mem$t[noibuf], Memr[noibufr], nc) call bld_interp (out, fdnoi, l, noibufr, Memr[outbufr]) $endif } # Apply a lower threshold to the output. if (rep) call amaxk$t (Mem$t[outbuf1], minrep, Mem$t[outbuf1], ncols) # Compute the mean. if (findmean) { mean = procmean$t (Mem$t[outbuf1], ncols, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } } # Copy final untrimmed lines. if (out != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) { call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(out,l)], nc) if (fdnoi != NULL) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } if (bpout != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call aclrs (Mems[impl2s(bpout,l)], nc) } # Compute the mean from the sum of the output pixels. if (findmean) { if (nsum > 0) MEAN(ccd) = sum / nsum else MEAN(ccd) = 1. } # Finish up. if (dosat) call bld_close () call sfree (sp) end # PROC2 -- Process CCD images with readout axis 2 (columns). procedure proc2$t (ccd) pointer ccd # CCD structure bool dosat, dointerp, rep, findmean int l, nc, ncols, coff, loff, nmean, nsum real darkscale, gainscale, flatscale, sflatscale real illumscale, frgscale, minflat, maxflat double sum, mean PIXEL minrep pointer sp, nflatbuf pointer inbuf, outbuf, outbuf1, noibuf, noibuf1 pointer overscan_vec, zerobuf, darkbuf, flatbuf, sflatbuf, illumbuf, fringebuf pointer in, bpin, zeroim, darkim, flatim, flatim2, illumim, fringeim pointer out, bpout, fdnoi $if (datatype != r) pointer outbufr, noibufr $endif double procmean$t() pointer imgl2$t(), impl2$t(), imgs2$t(), ccd_gl$t(), xx_fps$t() $if (datatype != s) pointer impl2s(), imgl2s() $endif errchk bld_open begin call smark (sp) # Set input. in = IN_IM(ccd) bpin = BPIN_IM(ccd) # Set output. out = OUT_IM(ccd) bpout = BPOUT_IM(ccd) fdnoi = NOIOUT_IM(ccd) ncols = OUT_C2(ccd) - OUT_C1(ccd) + 1 coff = IN_C1(ccd) - OUT_C1(ccd) loff = IN_L1(ccd) - OUT_L1(ccd) if (out == NULL) nc = IM_LEN(in,1) else nc = IM_LEN(out,1) # If there is no output image allocate a buffer. if (out == NULL) call salloc (outbuf, nc, TY_PIXEL) noibuf = NULL $if (datatype != r) noibufr = NULL $endif # Set saturated and bleed pixel parameters. If interpolating, # the output I/O is done in BLD_INTERP and we dont't use the # IMIO buffer so we must allocate memory. dosat = false dointerp = false if (CORS(ccd,SATURATE) == YES && (CORS(ccd,FIXPIX) == YES || bpout != NULL || fdnoi != NULL)) { dosat = true if (CORS(ccd,FIXPIX) == YES) dointerp = true if (dointerp && out != NULL) call salloc (outbuf, nc, TY_PIXEL) $if (datatype != r) call salloc (outbufr, nc, TY_REAL) $endif if (dointerp && fdnoi != NULL) call salloc (noibuf, nc, TY_PIXEL) $if (datatype != r) call salloc (noibufr, nc, TY_REAL) $endif # Initialize the saturation/bleed pixel routines. call bld_open (out, fdnoi, bpout, bpin, dointerp, SATVAL(ccd), 4, SATGROW(ccd), BLDVAL(ccd), 5, BLDGROW(ccd), BLDTRAIL(ccd), IN_C1(ccd), OUT_C1(ccd)) } # Initialize mean value computation. findmean = (CORS(ccd, FINDMEAN) == YES) if (findmean) { sum = 0. nsum = 0. } # Set lower threshold replacement parameters. rep = (CORS(ccd, MINREP) == YES) if (rep) minrep = MINREPLACE(ccd) # Set overscan parameters. overscan_vec = OVERSCAN_VEC(ccd) # Set calibration images. # If the calibration image is 1D then just get the data once. 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)) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } else { flatim = FLAT_IM(ccd) gainscale = GAINSCALE(ccd) flatscale = FLATSCALE(ccd) * gainscale minflat = 0.01 / gainscale maxflat = 100. / gainscale } if (CORS(ccd, SFLATCOR) == 0) { flatim2 = NULL sflatbuf = 1 } else if (IM_LEN(SFLAT_IM(ccd),1) == 1) { flatim2 = NULL sflatbuf = imgs2$t (SFLAT_IM(ccd), 1, 1, SFLAT_L1(ccd), SFLAT_L2(ccd)) sflatscale = SFLATSCALE(ccd) } else { flatim2 = SFLAT_IM(ccd) sflatscale = SFLATSCALE(ccd) } if (CORS(ccd, FLATCOR) != 0 || CORS(ccd, SFLATCOR) != 0) call malloc (nflatbuf, ncols, TY_REAL) else nflatbuf = 1 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 output line read line from the input. Data outside the # trim region is simply copied to the output. Procedure XT_FPS # replaces input bad pixels by interpolation. The BLD procedures # find saturated and bleed pixels which are added to the output bad # pixel mask and replaced by interpolation in the output image. # Procedure COR1 does the pixel corrections. A mean of the output # data is computed. # # If not interpolating saturated or bleed pixels this routine does # the output I/O otherwise it is done in BLD_INTERP. # Copy initial untrimmed lines. if (out != NULL) { do l = 1, OUT_L1(ccd)-1 { call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(out,l)], nc) if (fdnoi != NULL) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = 1, OUT_L1(ccd)-1 call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } if (bpout != NULL) call aclrs (Mems[impl2s(bpout,l)], nc) # Process output lines. do l = OUT_L1(ccd), OUT_L2(ccd) { # Set output line buffer. Use IMIO buffer if an output image # is being created and if not interpolating. if (out != NULL && !dointerp) outbuf = impl2$t (out, l) outbuf1 = outbuf + OUT_C1(ccd) - 1 if (fdnoi != NULL && !dointerp) noibuf = impl2$t (fdnoi, l) noibuf1 = noibuf + OUT_C1(ccd) - 1 # Get input data, fix bad pixels, and copy to output line buffer. if (BPIN_FP(ccd) != NULL && noibuf != NULL) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[noibuf], nc) inbuf = xx_fps$t (BPIN_FP(ccd), in, l+loff, IN_C1(ccd), IN_C2(ccd), IN_L1(ccd), IN_L2(ccd), NULL) call amov$t (Mem$t[inbuf+coff], Mem$t[outbuf], nc) if (BPIN_FP(ccd) == NULL && noibuf != NULL) call amov$t (Mem$t[outbuf], Mem$t[noibuf], nc) # Set the calibration data. if (zeroim != NULL) zerobuf = ccd_gl$t (zeroim, ZERO_C1(ccd), ZERO_C2(ccd), l+ZERO_L1(ccd)-OUT_L1(ccd)) if (darkim != NULL) darkbuf = ccd_gl$t (darkim, DARK_C1(ccd), DARK_C2(ccd), l+DARK_L1(ccd)-OUT_L1(ccd)) if (flatim != NULL) flatbuf = ccd_gl$t (flatim, FLAT_C1(ccd), FLAT_C2(ccd), l+FLAT_L1(ccd)-OUT_L1(ccd)) if (flatim2 != NULL) sflatbuf = ccd_gl$t (flatim2, SFLAT_C1(ccd), SFLAT_C2(ccd), l+SFLAT_L1(ccd)-OUT_L1(ccd)) if (illumim != NULL) illumbuf = ccd_gl$t (illumim, ILLUM_C1(ccd), ILLUM_C2(ccd), l+ILLUM_L1(ccd)-OUT_L1(ccd)) if (fringeim != NULL) fringebuf = ccd_gl$t (fringeim, FRINGE_C1(ccd), FRINGE_C2(ccd), l+FRINGE_L1(ccd)-OUT_L1(ccd)) call cor2flat$t (CORS(ccd,1), Memr[nflatbuf], Mem$t[flatbuf], Mem$t[sflatbuf], ncols, flatim, flatim2, flatscale, sflatscale, minflat, maxflat) # Find the saturated and bleed pixels before other processing. if (dosat) { $if (datatype == r) call bld_mask (bpout, l, Memr[outbuf], bpin) $else call acht$tr (Mem$t[outbuf], Memr[outbufr], nc) call bld_mask (bpout, l, Memr[outbufr], bpin) $endif } else if (bpout != NULL) { if (bpin != NULL) call amovs (Mems[imgl2s(bpin,l+loff)+coff], Mems[impl2s(bpout,l)], nc) else call aclrs (Mems[impl2s(bpout,l)], nc) } # Process the line. call cor2$t (l-OUT_L1(ccd)+1, CORS(ccd,1), Mem$t[outbuf1], Memr[overscan_vec], Mem$t[zerobuf], Mem$t[darkbuf], Memr[flatbuf], Mem$t[illumbuf], Mem$t[fringebuf], ncols, zeroim, darkscale, illumscale, frgscale) if (noibuf != NULL) call cor2$t (l-OUT_L1(ccd)+1, CORS(ccd,1), Mem$t[noibuf1], Memr[overscan_vec], Mem$t[zerobuf], Mem$t[darkbuf], Memr[flatbuf], Mem$t[illumbuf], Mem$t[fringebuf], ncols, zeroim, darkscale, illumscale, frgscale) # Interpolate the saturated and bleed pixels and set the # output no interplation image and output mask. if (dointerp) { $if (datatype == r) call bld_interp (out, fdnoi, l, noibuf, Mem$t[outbuf]) $else call acht$tr (Mem$t[outbuf], Memr[outbufr], nc) if (noibuf != NULL) call acht$tr (Mem$t[noibuf], Memr[noibufr], nc) call bld_interp (out, fdnoi, l, noibufr, Memr[outbufr]) $endif } # Apply a lower threshold to the output. if (rep) call amaxk$t (Mem$t[outbuf1], minrep, Mem$t[outbuf1], ncols) # Compute the mean. if (findmean) { mean = procmean$t (Mem$t[outbuf1], ncols, 2., nmean) sum = sum + nmean * mean nsum = nsum + nmean } } # Copy final untrimmed lines. if (out != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) { call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(out,l)], nc) if (fdnoi != NULL) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } } else if (fdnoi != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call amov$t (Mem$t[imgl2$t(in,l+loff)+coff], Mem$t[impl2$t(fdnoi,l)], nc) } if (bpout != NULL) { do l = OUT_L2(ccd)+1, IM_LEN(out,2) call aclrs (Mems[impl2s(bpout,l)], nc) } # Compute the mean from the sum of the output pixels. if (findmean) { if (nsum > 0) MEAN(ccd) = sum / nsum else MEAN(ccd) = 1. } # Finish up. if (dosat) call bld_close () call sfree (sp) 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 } if (npix > 2) overscan = (overscan - dmin - dmax) / (npix - 2) else overscan = overscan / npix } 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 # PROCMEAN -- Find mean of data. double procedure procmean$t (pix, n, ksig, nmean) PIXEL pix[n] #I Pixels int n #I Number of pixels real ksig #I Sigma clipping factor int nmean #O Number of pixels in the mean $if (datatype == dl) double mean, sigma, lcut, hcut $else real mean, sigma, lcut, hcut $endif int awvg$t() $if (datatype == csir) real asum$t() $else $if (datatype == ld) double asum$t() $else PIXEL asum$t() $endif $endif begin if (ksig <= 0.) { mean = asum$t (pix, n) / n nmean = n } else { lcut = 0. hcut = 0. nmean = awvg$t (pix, n, mean, sigma, lcut, hcut) lcut = mean - abs (ksig) * sigma hcut = mean + abs (ksig) * sigma nmean = awvg$t (pix, n, mean, sigma, lcut, hcut) } return (double (mean)) end $endfor �������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/readcor.x�����������������������������������������������������0000664�0000000�0000000�00000007532�13321663143�0020407�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # 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, output) char input[ARB] # Input image char output[ARB] # 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 pointer sp, temp, str, in, out, data real asumr() int clgwrd() bool clgetb(), ccdflag(), streq() 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 (temp, 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. if (streq (input, output)) { call mktemp ("tmp", Memc[temp], SZ_FNAME) #call set_output (Memc[temp], NULL, ???, in, out, bpm) call error (1, "READCOR") } else #call set_output (output, NULL, ???, in, out, bpm) call error (1, "READCOR") # 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]) call imunmap (in) call imunmap (out) # Replace the input image by the output image if needed. if (streq (input, output)) { call ccddelete (input) call imrename (Memc[temp], input) } call sfree (sp) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/scancor.x�����������������������������������������������������0000664�0000000�0000000�00000021372�13321663143�0020416�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include 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 (output, NULL, ???, in, out, bpm) call error (1, "SCANCOR") 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setbpmask.x���������������������������������������������������0000664�0000000�0000000�00000001625�13321663143�0020756�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "ccdred.h" # SET_BPMASK -- Set bad pixel mask output parameters. procedure set_bpmask (ccd, bpmask) pointer ccd #I CCD structure char bpmask[ARB] #I Output mask name int imaccess() begin # Check if operation is required. if (bpmask[1] == EOS || imaccess (bpmask, READ_ONLY) == YES) return # If not processing list operation only. if (LISTPROC(ccd) == YES) { call eprintf (" [TO BE DONE] Output mask %s\n") call pargstr (bpmask) return } # Set input mask. call set_inmask (ccd) # Save mask name. call strcpy (bpmask, BPOUT_NAME(ccd), LEN_CCDSTR) # Set flags. COR(ccd) = YES CORBPM(ccd) = YES # Log output. call sprintf (BPOUTLOG(ccd), LEN_LOG, "Output mask is %s") call pargstr (BPOUT_NAME(ccd)) call timelog (BPOUTLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), BPOUTLOG(ccd)) end �����������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setdark.x�����������������������������������������������������0000664�0000000�0000000�00000006702�13321663143�0020423�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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 real darktime1, darktime2 pointer sp, image, str, im bool clgetb(), ccdflag(), ccdcheck() int ccdnscan() real hdmgetr() pointer ccd_cache() errchk cal_image, ccd_cache, ccdproc1, ccdproc2, hdmgetr, set_calsection 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), IN_CCDTYPE(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 (LISTPROC(ccd) == YES) { call eprintf (" [TO BE DONE] Dark 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) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[str], Memc[str], DARK) case CALPROC_NO: call ccdproc2 (Memc[str], Memc[str], DARK) PROC(ccd) = NO call sfree (sp) return } } call scancor (Memc[str], Memc[image], nscan, INDEF) im = ccd_cache (Memc[image], DARK) } if (ccdcheck (im, DARK, "")) { call ccd_flush (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[image], Memc[image], DARK) case CALPROC_NO: call ccdproc2 (Memc[image], Memc[image], DARK) PROC(ccd) = NO call sfree (sp) return } im = ccd_cache (Memc[image], DARK) } DARK_IM(ccd) = im # Check and set data section. call set_calsection (ccd, DARK_IM(ccd), DARK_C1(ccd), DARK_C2(ccd), DARK_L1(ccd), DARK_L2(ccd)) # Get the dark count integration times. # Return an error if not found or zero. 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]) } COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, DARKCOR) = D DARKSCALE(ccd) = darktime1 / darktime2 # Record the operation in the output image and write a log record. call sprintf (DARKLOG(ccd), LEN_LOG, "Dark is %s, scale %g") call pargstr (Memc[image]) call pargr (DARKSCALE(ccd)) call timelog (DARKLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), DARKLOG(ccd)) call sfree (sp) end ��������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setfixpix.x���������������������������������������������������0000664�0000000�0000000�00000006767�13321663143�0021024�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include "ccdred.h" include "ccdtypes.h" # SET_FIXPIX -- Set parameters and structures 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. Set the fixpix interpolation routines. # 4. Log the operation (to user, logfile, and output image header). procedure set_fixpix (ccd) pointer ccd # CCD structure pointer str bool clgetb(), ccdflag() int i, btoi(), strlen(), fnroot() errchk set_inmask begin # Check if the user wants this operation or it has been done. CORS(ccd,FIXPIX) = btoi (clgetb ("fixpix") && !ccdflag (IN_IM(ccd), "fixpix")) if (CORS(ccd,FIXPIX)==NO) return # Get input mask. call set_inmask (ccd) # Cancel if there is no input mask. if (BPIN_IM(ccd) == NULL) { CORS(ccd,FIXPIX) = NO return } # If no processing is desired print bad pixel mask and return. if (LISTPROC(ccd) == YES && CORS(ccd,FIXPIX) == YES) { call eprintf (" [TO BE DONE] Pixel mask is %s.\n") call pargstr (BPIN_NAME(ccd)) return } if (CORS(ccd,FIXPIX) == YES) { COR(ccd) = YES COROUT(ccd) = YES #BPIN_PM(ccd) = imstati (BPIN_IM(ccd), IM_PMDES) #BPIN_FP(ccd) = xx_fpinit (BPIN_PM(ccd), 2, 3) call set_fp (BPIN_IM(ccd), BPIN_FP(ccd)) # Log operation. call sprintf (FIXLOG(ccd), LEN_LOG, "Fix pixels in %s") call pargstr (BPIN_NAME(ccd)) call timelog (FIXLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), FIXLOG(ccd)) # Set processing keyword. call sprintf (FIXLOG(ccd), LEN_LOG, "Fix %s") call pargstr (BPIN_NAME(ccd)) if (!IS_INDEF(SATVAL(ccd))) call strcat (" + sat", FIXLOG(ccd), LEN_LOG) if (!IS_INDEF(BLDVAL(ccd))) call strcat (" + bleed", FIXLOG(ccd), LEN_LOG) if (strlen (FIXLOG(ccd)) > 55) { call malloc (str, SZ_LINE, TY_CHAR) i = fnroot (BPIN_IM(ccd), Memc[str], SZ_LINE) call sprintf (FIXLOG(ccd), LEN_LOG, "Fix %s") call pargstr (Memc[str]) if (!IS_INDEF(SATVAL(ccd))) call strcat ("+sat", FIXLOG(ccd), LEN_LOG) if (!IS_INDEF(BLDVAL(ccd))) call strcat ("+bleed", FIXLOG(ccd), LEN_LOG) call mfree (str, TY_CHAR) } call timelog (FIXLOG(ccd), LEN_LOG) } end # SET_FP -- Set the fixpix mask. # # This routine transforms the input mask values into the output mask # values. It allows the input mask to have two classes of bad pixels; # those which are interpolated and those which are not. procedure set_fp (im, fp) pointer im #I Input mask image pointer pointer fp #O FIXPIX interpolation pointer int i, j, nc, nl long v[2] pointer data1, data2, pm, pmi int imstati(), pm_newcopy() pointer xx_fpinit() errchk malloc, xx_fpinit begin # Set the image size and data buffers. nc = IM_LEN(im,1) nl = IM_LEN(im,2) call malloc (data1, nc, TY_SHORT) call malloc (data2, nc, TY_SHORT) # Get the pixel mask from the image. pm = imstati (im, IM_PMDES) # Extract the pixels to be interpolated. pmi = pm_newcopy (pm) v[1] = 1 do j = 1, nl { v[2] = j call pmglps (pm, v, Mems[data1], 0, nc, PIX_SRC) do i = 0, nc-1 { if (Mems[data1+i] > 1) Mems[data1+i] = 0 } call pmplps (pmi, v, Mems[data1], 0, nc, PIX_SRC) } # Set the interpolation. fp = xx_fpinit (pmi, 2, 3) # Finish up. call mfree (data1, TY_SHORT) call mfree (data2, TY_SHORT) call pm_close (pmi) end ���������mscred-5.05-2018.07.09/src/ccdred/src/setflat.x�����������������������������������������������������0000664�0000000�0000000�00000006363�13321663143�0020433�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include 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 pointer sp, str, image, im, ccd_cache() bool clgetb(), ccdflag(), ccdcheck() int nscan, ccdnscan() real ccdmean(), hdmgetr() errchk cal_image, ccd_cache, ccdproc1, ccdproc2, ccdmean, set_calsection 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), IN_CCDTYPE(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 (LISTPROC(ccd) == YES) { call eprintf (" [TO BE DONE] Flat 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) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[str], Memc[str], FLAT) case CALPROC_NO: call ccdproc2 (Memc[str], Memc[str], FLAT) PROC(ccd) = NO call sfree (sp) return } } call scancor (Memc[str], Memc[image], nscan, MINREPLACE(ccd)) im = ccd_cache (Memc[image], FLAT) } if (ccdcheck (im, FLAT, "")) { call ccd_flush (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[image], Memc[image], FLAT) case CALPROC_NO: call ccdproc2 (Memc[image], Memc[image], FLAT) PROC(ccd) = NO call sfree (sp) return } im = ccd_cache (Memc[image], FLAT) } FLAT_IM(ccd) = im # Check and set data section. call set_calsection (ccd, FLAT_IM(ccd), FLAT_C1(ccd), FLAT_C2(ccd), FLAT_L1(ccd), FLAT_L2(ccd)) # Set the scaling factor from the mean. FLATSCALE(ccd) = ccdmean (im) # Set gain scaling. iferr (GAINSCALE(ccd) = hdmgetr (IN_IM(ccd), "gainnorm")) GAINSCALE(ccd) = 1. COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, FLATCOR) = F # Log the operation. if (GAINSCALE(ccd) != 1.) { call sprintf (FLATLOG(ccd), LEN_LOG, "Gain scale is %g") call pargr (GAINSCALE(ccd)) call timelog (FLATLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), FLATLOG(ccd)) } call sprintf (FLATLOG(ccd), LEN_LOG, "Flat is %s, scale %g") call pargstr (Memc[image]) call pargr (FLATSCALE(ccd)) call timelog (FLATLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), FLATLOG(ccd)) call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setfringe.x���������������������������������������������������0000664�0000000�0000000�00000004156�13321663143�0020755�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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 real exptime1, exptime2, fringescale pointer sp, str, image, im bool clgetb(), ccdflag() real hdmgetr() pointer ccd_cache() errchk cal_image, ccd_cache, hdmgetr, set_calsection 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 (LISTPROC(ccd) == YES) { call eprintf ( " [TO BE DONE] Fringe 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.") FRINGE_IM(ccd) = im # Check and set data section. call set_calsection (ccd, FRINGE_IM(ccd), FRINGE_C1(ccd), FRINGE_C2(ccd), FRINGE_L1(ccd), FRINGE_L2(ccd)) # 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. COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, FRINGECOR) = Q FRINGESCALE(ccd) = exptime1 / exptime2 * fringescale # Log the operation. call sprintf (FRINGELOG(ccd), LEN_LOG, "Fringe %s, scale %g") call pargstr (Memc[image]) call pargr (FRINGESCALE(ccd)) call timelog (FRINGELOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), FRINGELOG(ccd)) call sfree (sp) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setheader.x���������������������������������������������������0000664�0000000�0000000�00000012404�13321663143�0020726�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include "ccdred.h" define FUDGE 10 # Number of seconds to fudge the CCDMEANT value. # SET_HEADER -- Set the output image headers. procedure set_header (ccd) pointer ccd # CCD structure int i, j, nc, nl, c1, c2, l1, l2, cs, ls real shift[2] pointer sp, str, out[3], bpm, im, mw, mw_openim(), immap() long clktime() begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) out[1] = OUT_IM(ccd) out[2] = NOIOUT_IM(ccd) out[3] = BPOUT_IM(ccd) do j = 1, 3 { im = out[j] if (im == NULL) next nc = IM_LEN(im,1) nl = IM_LEN(im,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 (im, "datasec", Memc[str]) } else { iferr (call hdmdelf (im, "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 (im, "ccdsec", Memc[str]) # Set the detector section. The default is CCDSEC. call hdmgstr (IN_IM(ccd), "detsec", Memc[str], SZ_LINE) l1 = CCD_L1(ccd) - CCD_LS(ccd) * TRIM_DL1(ccd) l2 = CCD_L2(ccd) - CCD_LS(ccd) * TRIM_DL2(ccd) c1 = CCD_C1(ccd) - CCD_CS(ccd) * TRIM_DC1(ccd) c2 = CCD_C2(ccd) - CCD_CS(ccd) * TRIM_DC2(ccd) cs = 1 ls = 1 call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) if ((abs(cs) != 1) || (abs(ls) != 1)) call error (0, "Error in DETSEC parameter") if (IN_CFLIP(ccd) == YES) { i = c1 c1 = c2 c2 = i cs = -cs } if (IN_LFLIP(ccd) == YES) { i = l1 l1 = l2 l2 = i ls = -ls } c1 = c1 + CCD_CS(ccd) * TRIM_DC1(ccd) c2 = c2 + CCD_CS(ccd) * TRIM_DC2(ccd) l1 = l1 + CCD_LS(ccd) * TRIM_DL1(ccd) l2 = l2 + CCD_LS(ccd) * TRIM_DL2(ccd) iferr { if ((abs(c2-c1) != abs(CCD_C2(ccd)-CCD_C1(ccd))) || (abs(l2-l1) != abs (CCD_L2(ccd)-CCD_L1(ccd)))) call error (0, "Size of DETSEC and CCDSEC do not agree") call sprintf (Memc[str], SZ_LINE, "[%d:%d,%d:%d]") call pargi (c1) call pargi (c2) call pargi (l1) call pargi (l2) call hdmpstr (im, "detsec", Memc[str]) } then { call erract (EA_WARN) iferr (call hdmdelf (im, "detsec")) ; } # If trimming update trim and bias section parameters and the WCS. if (CORS(ccd, TRIM) == YES) { iferr (call hdmdelf (im, "trimsec")) ; iferr (call hdmdelf (im, "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 (im, "biassec", Memc[str]) } mw = mw_openim (im) shift[1] = 1 - IN_C1(ccd) shift[2] = 1 - IN_L1(ccd) call mw_shift (mw, shift, 3) call mw_saveim (mw, im) if (bpm != NULL) call mw_saveim (mw, bpm) call mw_close (mw) } # Put log in header. if (SATLOG(ccd) != EOS) call hdmpstr (im, "satproc", SATLOG(ccd)) if (BLDLOG(ccd) != EOS) call hdmpstr (im, "bldproc", BLDLOG(ccd)) if (TRIMLOG(ccd) != EOS) call hdmpstr (im, "trim", TRIMLOG(ccd)) if (FIXLOG(ccd) != EOS) call hdmpstr (im, "fixpix", FIXLOG(ccd)) if (BIASLOG(ccd) != EOS) call hdmpstr (im, "overscan", BIASLOG(ccd)) if (ZEROLOG(ccd) != EOS) call hdmpstr (im, "zerocor", ZEROLOG(ccd)) if (DARKLOG(ccd) != EOS) call hdmpstr (im, "darkcor", DARKLOG(ccd)) if (FLATLOG(ccd) != EOS) call hdmpstr (im, "flatcor", FLATLOG(ccd)) if (SFLATLOG(ccd) != EOS) call hdmpstr (im, "sflatcor", SFLATLOG(ccd)) if (ILLUMLOG(ccd) != EOS) call hdmpstr (im, "illumcor", ILLUMLOG(ccd)) if (FRINGELOG(ccd) != EOS) call hdmpstr (im, "fringcor", FRINGELOG(ccd)) # Set new BPM in output image. If no output set in input. if (out[3] != NULL) { if (out[1] == NULL) { call imstats (IN_IM(ccd), IM_IMAGENAME, Memc[str], SZ_LINE) call imunmap (IN_IM(ccd)) iferr (IN_IM(ccd) = immap (Memc[str], READ_WRITE, 0)) IN_IM(ccd) = immap (Memc[str], READ_ONLY, 0) else { call imstats (out[3], IM_IMAGENAME, Memc[str], SZ_LINE) call hdmpstr (IN_IM(ccd), "bpm", Memc[str]) } } call imstats (out[3], IM_IMAGENAME, Memc[str], SZ_LINE) call hdmpstr (im, "bpm", Memc[str]) } # Set mean value if desired. if (CORS(ccd, FINDMEAN) == YES) { call hdmputr (im, "ccdmean", MEAN(ccd)) call hdmputi (im, "ccdmeant", int (clktime (long (0)))+FUDGE) } # Mark image as processed. call sprintf (Memc[str], SZ_LINE, "CCD processing done") call timelog (Memc[str], SZ_LINE) call hdmpstr (im, "ccdproc", Memc[str]) # Update OBSID. call xt_procid (im) } call sfree (sp) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setillum.x����������������������������������������������������0000664�0000000�0000000�00000003666�13321663143�0020632�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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 pointer sp, str, image, im bool clgetb(), ccdflag() real ccdmean() pointer ccd_cache() errchk cal_image, ccd_cache, ccdmean, set_calsection 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 (LISTPROC(ccd) == YES) { call eprintf ( " [TO BE DONE] Illumination 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") } ILLUM_IM(ccd) = im # Check and set data section. call set_calsection (ccd, ILLUM_IM(ccd), ILLUM_C1(ccd), ILLUM_C2(ccd), ILLUM_L1(ccd), ILLUM_L2(ccd)) # Set the scale from the mean. ILLUMSCALE (ccd) = ccdmean (im) COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, ILLUMCOR) = I # Log the operation. call sprintf (ILLUMLOG(ccd), LEN_LOG, "Illumination is %s, scale %g") call pargstr (Memc[image]) call pargr (ILLUMSCALE(ccd)) call timelog (ILLUMLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), ILLUMLOG(ccd)) call sfree (sp) end ��������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setinmask.x���������������������������������������������������0000664�0000000�0000000�00000004543�13321663143�0020765�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "ccdred.h" include "ccdtypes.h" # SET_INMASK -- Set input mask. # 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_inmask (ccd) pointer ccd # CCD structure int nscan pointer sp, str, image, im pointer xt_pmmap() bool clgetb(), ccdcheck() int ccdnscan() errchk xt_pmmap, cal_image, ccdproc1, ccdproc2 begin # Check if the input mask has already been opened. if (BPIN_IM(ccd) != NULL) return call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) # Get the bad pixel mask. Return without an error if not found. if (clgetb ("scancor")) nscan = ccdnscan (IN_IM(ccd), IN_CCDTYPE(ccd)) else nscan = 1 iferr (call cal_image (IN_IM(ccd),MASK,nscan,Memc[image],SZ_FNAME)) { call strcpy ("NONE", BPIN_NAME(ccd), LEN_CCDSTR) return } # If no processing just set the mask name. if (LISTPROC(ccd) == YES) { call strcpy (Memc[image], BPIN_NAME(ccd), LEN_CCDSTR) call sfree (sp) return } # Map the image and return on an error. # Process the mask image if necessary. # If nscan > 1 then the mask may not yet exist so create it # from the unscanned mask. iferr (im = xt_pmmap (Memc[image], IN_IM(ccd), Memc[image], SZ_FNAME)) { call cal_image (IN_IM(ccd), MASK, 1, Memc[str], SZ_LINE) im = xt_pmmap (Memc[str], IN_IM(ccd), Memc[str], SZ_LINE) if (ccdcheck (im, MASK, "")) { call yt_pmunmap (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[str], Memc[str], MASK) case CALPROC_NO: call ccdproc2 (Memc[str], Memc[str], MASK) PROC(ccd) = NO call sfree (sp) return } } call scancor (Memc[str], Memc[image], nscan, INDEF) im = xt_pmmap (Memc[image], IN_IM(ccd), Memc[image], SZ_FNAME) } if (ccdcheck (im, MASK, "")) { call yt_pmunmap (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[image], Memc[image], MASK) case CALPROC_NO: call ccdproc2 (Memc[image], Memc[image], MASK) PROC(ccd) = NO call sfree (sp) return } im = xt_pmmap (Memc[image], IN_IM(ccd), Memc[image], SZ_FNAME) } BPIN_IM(ccd) = im call strcpy (Memc[image], BPIN_NAME(ccd), LEN_CCDSTR) call sfree (sp) end �������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setinput.x����������������������������������������������������0000664�0000000�0000000�00000002200�13321663143�0020626�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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 ccdtypecl(), ccdtypes() 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. ccdtype = ccdtypecl ("ccdtype", Memc[str1], SZ_LINE) ccdtype = ccdtypes (im, Memc[str2], SZ_LINE) if (Memc[str1] != EOS) { if (strne (Memc[str1], Memc[str2])) call imunmap (im) } call sfree (sp) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setinteract.x�������������������������������������������������0000664�0000000�0000000�00000001552�13321663143�0021311�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # 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 ������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setnoi.x������������������������������������������������������0000664�0000000�0000000�00000000666�13321663143�0020272�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "ccdred.h" # SET_NOI -- Set output no interpolation image procedure set_noi (ccd, noi) pointer ccd #I CCD structure char noi[ARB] #I Output name int imaccess() begin # Check if operation is required. if (noi[1] == EOS || imaccess (noi, READ_ONLY) == YES) return # Save mask name. call strcpy (noi, NOIOUT_NAME(ccd), LEN_CCDSTR) end ��������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setoutput.x���������������������������������������������������0000664�0000000�0000000�00000004306�13321663143�0021040�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include "ccdred.h" # SET_OUTPUT -- Setup the output images. # The user may select a pixel datatype with higher precision though not # lower. procedure set_output (output, noi, bpmask, ccd, in, out, fdnoi, bpout) char output[ARB] # Image name char noi[ARB] # Uninterpolated image name char bpmask[ARB] # Mask name pointer ccd # CCD pointer pointer in # Input IMIO pointer pointer out # Output IMIO pointer pointer fdnoi # Output nointerpolation pointer pointer bpout # Output BPM pointer int i, clscan(), nscan() char type[1] pointer immap(), ic_pmmap() errchk immap, ic_pmmap begin # Workaround to copy any keywords added to input. IM_HDRLEN(in) = IM_LENHDRMEM(in) # Set output image. if (COROUT(ccd) == YES) { out = immap (output, NEW_COPY, in) if (ccd != NULL) { OUT_IM(ccd) = out IM_LEN(out,1) = TRIM_C2(ccd) - TRIM_C1(ccd) + 1 IM_LEN(out,2) = TRIM_L2(ccd) - TRIM_L1(ccd) + 1 } 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 error (0, "Unknown pixel type") } } } } else out = NULL # Set output bad pixel mask. if (CORBPM(ccd) == YES && bpmask[1] != EOS) { if (out != NULL) bpout = ic_pmmap (bpmask, NEW_COPY, out) else bpout = ic_pmmap (bpmask, NEW_COPY, in) } else bpout = NULL BPOUT_IM(ccd) = bpout # Set output uninterpolated image. if ((CORS(ccd,FIXPIX)==YES || CORS(ccd,SATURATE)==YES) && noi[1]!=EOS) { if (out != NULL) fdnoi = immap (noi, NEW_COPY, out) else fdnoi = immap (noi, NEW_COPY, in) } else fdnoi = NULL NOIOUT_IM(ccd) = fdnoi end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setoverscan.x�������������������������������������������������0000664�0000000�0000000�00000022240�13321663143�0021315�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include 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. Average the overscan columns or lines. # 4. 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 real ovsnmean pointer sp, str, errstr, 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 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 (LISTPROC(ccd) == YES) { 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 } if (PROC(ccd) == NO) { 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[str], SZ_LINE, OVERSCAN_TYPES) if (READAXIS(ccd) == 1) { if (type < OVERSCAN_FIT) overscan = NULL else { 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 = IN_L2(ccd) - IN_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 { if (type < OVERSCAN_FIT) { call error (1, "Overscan function type not allow with readaxis = 2") } 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 = IN_C2(ccd) - IN_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. COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, OVERSCAN) = O OVERSCAN_TYPE(ccd) = type OVERSCAN_VEC(ccd) = overscan # Log the operation. if (type < OVERSCAN_FIT) { call sprintf (BIASLOG(ccd), LEN_LOG, "Overscan is [%d:%d,%d:%d], function=%s") call pargi (c1) call pargi (c2) call pargi (l1) call pargi (l2) call pargstr (Memc[str]) } else { ovsnmean = asumr (Memr[overscan], npts) / npts call sprintf (BIASLOG(ccd), LEN_LOG, "Overscan is [%d:%d,%d:%d], mean %g") call pargi (c1) call pargi (c2) call pargi (l1) call pargi (l2) call pargr (ovsnmean) iferr (call imaddr (IN_IM(ccd), "OVSNMEAN", ovsnmean)) ; } call timelog (BIASLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), BIASLOG(ccd)) 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setproc.x�����������������������������������������������������0000664�0000000�0000000�00000004510�13321663143�0020440�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include "ccdred.h" # SET_PROC -- Set the processing parameter structure pointer. procedure set_proc (in, proc, calproc, listproc, ccd) pointer in # Input IMIO pointer pointer ccd # CCD structure (returned) int proc # Process image? int calproc # Process calibration images? int listproc # List processing to be done? int ccdtypes(), 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 BPIN_IM(ccd) = NULL IN_CCDTYPE(ccd) = ccdtypes (in, Memc[str], SZ_LINE) PROC(ccd) = proc CALPROC(ccd) = calproc LISTPROC(ccd) = listproc COR(ccd) = NO COROUT(ccd) = NO CORBPM(ccd) = NO CORS(ccd, SATURATE) = 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 (BPIN_IM(ccd) != NULL) call yt_pmunmap (BPIN_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 (SFLAT_IM(ccd) != NULL) call ccd_unmap (SFLAT_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 (BPIN_FP(ccd) != NULL) { # Bug fix for V2.11.1 if (Memi[BPIN_FP(ccd)+11] == NULL) { switch (CALCTYPE (ccd)) { case TY_SHORT: Memi[BPIN_FP(ccd)+11] = TY_SHORT default: Memi[BPIN_FP(ccd)+11] = TY_REAL } } call xx_fpfree (BPIN_FP(ccd)) } call mfree (ccd, TY_STRUCT) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setreadcor.x��������������������������������������������������0000664�0000000�0000000�00000001111�13321663143�0021106�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "ccdred.h" # SET_READCOR -- Set readcor flags. procedure set_readcor (ccd) pointer ccd # CCD structure bool clgetb(), ccdflag() begin # Check if the user wants this operation or it has been done. if (!clgetb ("readcor") || ccdflag (IN_IM(ccd), "readcor")) return # If no processing is desired print operation and return. if (clgetb ("noproc")) { call eprintf (" [TO BE DONE] Convert to 1D readout correction.\n") return } # Set flags. CORS(ccd, READCOR) = YES end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setsaturate.x�������������������������������������������������0000664�0000000�0000000�00000017127�13321663143�0021335�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "ccdred.h" define SATUNITS "|ADUs|electrons|" define UNKNOWN 0 # Saturation in unknown units define ADU 1 # Saturation in ADU define ELECTRON 2 # Saturation in electrons # SET_SATURATE -- Set saturation parameters. procedure set_saturate (ccd) pointer ccd #I CCD structure bool satproc, bldproc, fixpix int i, satunit, bldunit real sat, bleed, gain pointer sp, str, str1 bool clgetb(), ccdflag() int clgeti(), ctowrd(), ctor(), strdic(), strlen(), fnroot() real hdmgetr() errchk hdmgetr begin # Check if the operation is required. satproc = ccdflag (IN_IM(ccd), "satproc") bldproc = ccdflag (IN_IM(ccd), "satproc") if (satproc && bldproc) return # If there is no output mask or pixel fixing then skip this operation. fixpix = (clgetb ("fixpix") && !ccdflag (IN_IM(ccd), "fixpix")) if (CORBPM(ccd) == NO && !fixpix) return call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) call salloc (str1, SZ_LINE, TY_CHAR) # Set saturation value. Need to set this even if done before in # case the bleed value is based on the saturation. call clgstr ("saturation", Memc[str], SZ_LINE) i = 1 if (ctor (Memc[str], i, sat) == 0) { if (ctowrd (Memc[str], i, Memc[str1], SZ_LINE) > 0) { if (Memc[str1] == '!') call strcpy (Memc[str1+1], Memc[str1], SZ_LINE) iferr (sat = hdmgetr (IN_IM(ccd), Memc[str1])) sat = INDEF } } satunit = strdic (Memc[str+i-1], Memc[str1], SZ_LINE, SATUNITS) SATVALE(ccd) = sat if (!IS_INDEFR(sat)) { switch (satunit) { case ELECTRON: gain = hdmgetr (IN_IM(ccd), "gain") sat = sat / gain default: iferr (gain = hdmgetr (IN_IM(ccd), "gain")) SATVALE(ccd) = INDEFR else SATVALE(ccd) = sat * gain } SATGROW(ccd) = clgeti ("sgrow") } if (satproc) SATVAL(ccd) = INDEFR else SATVAL(ccd) = sat # Set bleed value. if (!bldproc) { call clgstr ("bleed", Memc[str], SZ_LINE) i = 1 if (ctor (Memc[str], i, bleed) == 0) { if (ctowrd (Memc[str], i, Memc[str1], SZ_LINE) > 0) { if (Memc[str1] == '!') { call strcpy (Memc[str1+1], Memc[str1], SZ_LINE) iferr (bleed = hdmgetr (IN_IM(ccd), Memc[str1])) bleed = INDEF } else { call set_bldval (ccd, sat, Memc[str], bleed) call strcpy ("ADU", Memc[str], SZ_LINE) i = 1 } } } bldunit = strdic (Memc[str+i-1], Memc[str1], SZ_LINE, SATUNITS) BLDVALE(ccd) = bleed if (!IS_INDEFR(bleed)) { switch (bldunit) { case ELECTRON: gain = hdmgetr (IN_IM(ccd), "gain") bleed = bleed / gain default: iferr (gain = hdmgetr (IN_IM(ccd), "gain")) BLDVALE(ccd) = INDEFR else BLDVALE(ccd) = bleed * gain } BLDTRAIL(ccd) = clgeti ("btrail") BLDGROW(ccd) = clgeti ("bgrow") if (BLDTRAIL(ccd) == 0) bleed = INDEF BLDVAL(ccd) = bleed } BLDVAL(ccd) = bleed } else BLDVAL(ccd) = INDEFR # If there is no correction skip this operation. if (IS_INDEF(SATVAL(ccd)) && IS_INDEF(BLDVAL(ccd))) { call sfree (sp) return } # If not processing list operation only. if (LISTPROC(ccd) == YES) { call eprintf (", Sat: %g ADU (%g e-), grw=%d.\n") call pargr (SATVAL(ccd)) call pargr (SATVALE(ccd)) call pargi (SATGROW(ccd)) call eprintf (", Bleed: %g ADU (%g e-), len=%d, grw=%d.\n") call pargr (BLDVAL(ccd)) call pargr (BLDVALE(ccd)) call pargi (BLDTRAIL(ccd)) call pargi (BLDGROW(ccd)) return } # Set input mask. call set_inmask (ccd) # Set flags. COR(ccd) = YES CORS(ccd,SATURATE) = YES # Set pixel fixing and log parameters. if (fixpix) { COROUT(ccd) = YES CORS(ccd,FIXPIX) = YES # Log operations. if (!IS_INDEF(SATVAL(ccd))) { call sprintf (FIXLOG(ccd), LEN_LOG, "Fix saturated pixels") call timelog (FIXLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), FIXLOG(ccd)) } if (!IS_INDEF(BLDVAL(ccd))) { call sprintf (FIXLOG(ccd), LEN_LOG, "Fix bleed pixels") call timelog (FIXLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), FIXLOG(ccd)) } # Set processing keyword. if (BPIN_IM(ccd) != NULL) { call sprintf (FIXLOG(ccd), LEN_LOG, "Fix %s") call pargstr (BPIN_NAME(ccd)) if (!IS_INDEF(SATVAL(ccd))) call strcat (" + sat", FIXLOG(ccd), LEN_LOG) if (!IS_INDEF(BLDVAL(ccd))) call strcat (" + bleed", FIXLOG(ccd), LEN_LOG) } else if (!IS_INDEF(SATVAL(ccd))) { call sprintf (FIXLOG(ccd), LEN_LOG, "Fix saturated") if (!IS_INDEF(BLDVAL(ccd))) call strcat (" and bleed trail", FIXLOG(ccd), LEN_LOG) call strcat (" pixels", FIXLOG(ccd), LEN_LOG) } else call sprintf (FIXLOG(ccd), LEN_LOG, "Fix bleed trail pixels") if (strlen (FIXLOG(ccd)) > 55) { i = fnroot (BPIN_IM(ccd), Memc[str], SZ_LINE) call sprintf (FIXLOG(ccd), LEN_LOG, "Fix %s") call pargstr (Memc[str]) if (!IS_INDEF(SATVAL(ccd))) call strcat ("+sat", FIXLOG(ccd), LEN_LOG) if (!IS_INDEF(BLDVAL(ccd))) call strcat ("+bleed", FIXLOG(ccd), LEN_LOG) } call timelog (FIXLOG(ccd), LEN_LOG) } # Log saturation and bleed trail parameters. if (!IS_INDEF(sat)) { call sprintf (SATLOG(ccd), LEN_LOG, "Sat: %.6g ADU (%.6g e-), grw=%d") call pargr (SATVAL(ccd)) call pargr (SATVALE(ccd)) call pargi (SATGROW(ccd)) call timelog (SATLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), SATLOG(ccd)) } if (!IS_INDEF(bleed)) { call sprintf (BLDLOG(ccd), LEN_LOG, "Bleed: %.6g ADU (%.6g e-), len=%d, grw=%d") call pargr (BLDVAL(ccd)) call pargr (BLDVALE(ccd)) call pargi (BLDTRAIL(ccd)) call pargi (BLDGROW(ccd)) call timelog (BLDLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), BLDLOG(ccd)) } end define BLDTRIM 10 # Number of lines and columns to trim in mean define BLDSAMPLE 100 # Number of sample ines for the mean # SET_BLDVAL -- Set the bleed value from a string. # This routine parses threshold strings of the form # [mean|saturation][*|+] # where value is a numeric value. procedure set_bldval (ccd, sth, bthresh, bth) pointer ccd #I CCD structure real sth #I Saturation value char bthresh[ARB] #I Threshold for candidate bleed pixels real bth #I Bleed threshold (ADU) int i, l, nc, nl, nmean real mean, asumr() pointer sp, str, in, imgl2r() int nowhite(), strncmp(), ctor() errchk imgl2r begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) # Parse the bleed threshold string. bth = INDEFR i = nowhite (bthresh, Memc[str], SZ_LINE) call strlwr (Memc[str]) if (strncmp (Memc[str], "mean", 4) == 0) { i = 6 l = ctor (Memc[str], i, bth) if (l == 0 || (Memc[str+4] != '*' && Memc[str+4] != '+')) call error (2, "Syntax error in bleed threshold") # Compute sample mean. in = IN_IM(ccd) nc = IN_C2(ccd) - IN_C1(ccd) + 1 nl = IN_L2(ccd) - IN_L1(ccd) + 1 mean = 0. nmean = 0 i = (nl - 2 * BLDTRIM) / BLDSAMPLE do l = IN_L1(ccd)+BLDTRIM, IN_L2(ccd)-BLDTRIM, i { mean = mean + asumr (Memr[imgl2r(in,l)+BLDTRIM], nc-2*BLDTRIM) / (nc - 2*BLDTRIM) nmean = nmean + 1 } mean = mean / nmean if (Memc[str+4] == '+') bth = bth + mean else if (Memc[str+4] == '*') bth = bth * mean } else if (strncmp (Memc[str], "saturation", 10) == 0) { i = 12 l = ctor (Memc[str], i, bth) if (l == 0 || (Memc[str+10] != '/' && Memc[str+10] != '-')) call error (2, "Syntax error in bleed threshold") if (IS_INDEFR(sth)) bth = sth else if (Memc[str+10] == '-') bth = sth - bth else if (Memc[str+10] == '/') bth = sth / bth } else { i = 1 if (ctor (Memc[str], i, bth) == 0) call error (2, "Syntax error in bleed threshold") } call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setsections.x�������������������������������������������������0000664�0000000�0000000�00000020335�13321663143�0021327�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include 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, key, str, mw, lterm, mw_openim() real ltv1, ltv2, ltm1_1, ltm2_2 int i, j, nc, nl, c1, c2, cs, csum, l1, l2, ls, lsum, ndim bool cflip, lflip, streq() int ctoi(), mw_stati(), btoi() begin call smark (sp) call salloc (key, SZ_LINE, TY_CHAR) 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) cflip = (cs < 0) lflip = (ls < 0) if (cflip) { i = c1 c1 = c2 c2 = i cs = -cs } if (lflip) { i = l1 l1 = l2 l2 = i ls = -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 IN_CFLIP(ccd) = btoi (cflip) IN_LFLIP(ccd) = btoi (lflip) # 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[key], SZ_LINE) if (streq (Memc[key], "image")) call strcpy ("!trimsec", Memc[key], SZ_LINE) if (Memc[key] == '!') call hdmgstr (IN_IM(ccd), Memc[key+1], Memc[str], SZ_LINE) else call strcpy (Memc[key], Memc[str], SZ_LINE) call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) if ((abs(cs)!=1)||(abs(ls)!=1)) call error (0, "Error in TRIMSEC parameter") TRIM_C1(ccd) = min(c1,c2) TRIM_C2(ccd) = max(c1,c2) TRIM_L1(ccd) = min(l1,l2) TRIM_L2(ccd) = max(l1,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[key], SZ_LINE) if (streq (Memc[key], "image")) call strcpy ("!biassec", Memc[key], SZ_LINE) if (Memc[key] == '!') call hdmgstr (IN_IM(ccd), Memc[key+1], Memc[str], SZ_LINE) else call strcpy (Memc[key], Memc[str], SZ_LINE) call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) if ((abs(cs)!=1)||(abs(ls)!=1)) call error (0, "Error in BIASSEC parameter") BIAS_C1(ccd) = min(c1,c2) BIAS_C2(ccd) = max(c1,c2) BIAS_L1(ccd) = min(l1,l2) BIAS_L2(ccd) = max(l1,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 ((abs(cs) != 1) || (abs(ls) != 1)) call error (0, "Error in CCDSEC parameter") if (cflip) { i = c1 c1 = c2 c2 = i cs = -cs } if (lflip) { i = l1 l1 = l2 l2 = i ls = -ls } CCD_C1(ccd) = c1 CCD_C2(ccd) = c2 CCD_CS(ccd) = cs CCD_L1(ccd) = l1 CCD_L2(ccd) = l2 CCD_LS(ccd) = ls # Set the binning. call hdmgstr (IN_IM(ccd), "ccdsum", Memc[str], SZ_LINE) if (Memc[str] == EOS) { csum = 1 lsum = 1 } else { i = 1 if (ctoi (Memc[str], i, csum) == 0) csum = 0 if (ctoi (Memc[str], i, lsum) == 0) lsum = 0 } if (csum < 1 || lsum < 1) call error (1, "Error in CCDSUM parameter") CCD_CS(ccd) = CCD_CS(ccd) * csum CCD_LS(ccd) = CCD_LS(ccd) * lsum i = (abs (CCD_C2(ccd) - CCD_C1(ccd)) + 1) / abs (CCD_CS(ccd)) j = (abs (CCD_L2(ccd) - CCD_L1(ccd)) + 1) / abs (CCD_LS(ccd)) if (IN_C2(ccd)-IN_C1(ccd)+1!=i || IN_L2(ccd)-IN_L1(ccd)+1!=j) 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) ltm1_1 = 1. / CCD_CS(ccd) ltm2_2 = 1. / CCD_LS(ccd) if (ltm1_1 > 0) ltv1 = IN_C1(ccd) - ltm1_1 * (CCD_C1(ccd) + 0.5 * (1 / ltm1_1 - 1)) else ltv1 = IN_C1(ccd) - ltm1_1 * (CCD_C1(ccd) + 0.5 * (1 / ltm1_1 + 1)) if (ltm2_2 > 0) ltv2 = IN_L1(ccd) - ltm2_2 * (CCD_L1(ccd) + 0.5 * (1 / ltm2_2 - 1)) else ltv2 = IN_L1(ccd) - ltm2_2 * (CCD_L1(ccd) + 0.5 * (1 / ltm2_2 + 1)) Memr[lterm] = ltv1 Memr[lterm+1] = ltv2 Memr[lterm+ndim] = ltm1_1 Memr[lterm+ndim+1] = 0. Memr[lterm+ndim+ndim] = 0. Memr[lterm+ndim+ndim+1] = ltm2_2 call mw_sltermr (mw, Memr[lterm+ndim], Memr[lterm], ndim) call mw_saveim (mw, IN_IM(ccd)) call mw_close (mw) call sfree (sp) end # SET_CALSECTION -- Check and set calibration sections. procedure set_calsection (ccd, im, data_c1, data_c2, data_l1, data_l2) pointer ccd #I CCD structure pointer im #I Calibration image pointer int data_c1 #O Calibration image starting column int data_c2 #O Calibration image ending column int data_l1 #O Calibration image starting line int data_l2 #O Calibration image ending line bool cflip, lflip int i, nc, nl, c1, c2, cs, csum, l1, l2, ls, lsum, ctoi() pointer sp, str begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) # Check data section. 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 ((cs<0 && IN_CFLIP(ccd)==NO) || (cs>0 && IN_CFLIP(ccd)==YES) || # (ls<0 && IN_LFLIP(ccd)==NO) || (ls>0 && IN_LFLIP(ccd)==YES)) # call error (1, "Data section flipped relative to target image") # cflip = (IN_CFLIP(ccd)==YES) # lflip = (IN_LFLIP(ccd)==YES) cflip = (cs < 0) lflip = (ls < 0) if (cflip) { i = c1 c1 = c2 c2 = i cs = -cs } if (lflip) { i = l1 l1 = l2 l2 = i ls = -ls } if ((c1<1)||(c2>nc)||(l1<1)||(l2>nl)||(cs!=1)||(ls!=1)) { call sprintf (Memc[str], SZ_LINE, "Data section error: image size=[%d,%d], datasec=[%d:%d,%d:%d]") call pargi (nc) call pargi (nl) call pargi (c1) call pargi (c2) call pargi (l1) call pargi (l2) call error (1, Memc[str]) } data_c1 = c1 data_l1 = l1 # Check CCDSEC. c1 = 1 c2 = nc l1 = 1 l2 = nl call hdmgstr (im, "ccdsec", Memc[str], SZ_FNAME) call ccd_section (Memc[str], c1, c2, cs, l1, l2, ls) if ((abs (cs) != 1) || (abs (ls) != 1)) call error (1, "Error in CCDSEC parameter") if (cflip) { i = c1 c1 = c2 c2 = i cs = -cs } if (lflip) { i = l1 l1 = l2 l2 = i ls = -ls } if (nc == 1) { c1 = CCD_C1(ccd) c2 = CCD_C2(ccd) } if (nl == 1) { l1 = CCD_L1(ccd) l2 = CCD_L2(ccd) } call hdmgstr (im, "ccdsum", Memc[str], SZ_FNAME) if (Memc[str] == EOS) { csum = 1 lsum = 1 } else { i = 1 if (ctoi (Memc[str], i, csum) == 0) csum = 0 if (ctoi (Memc[str], i, lsum) == 0) lsum = 0 } if (csum < 1 || lsum < 1) call error (1, "Error in CCDSUM parameter") cs = cs * csum ls = ls * lsum if (cs != CCD_CS(ccd) || ls != CCD_LS(ccd)) { call sprintf (Memc[str], SZ_LINE, "CCD sum error: target='%d %d', calibration='%d %d'") call pargi (CCD_CS(ccd)) call pargi (CCD_LS(ccd)) call pargi (cs) call pargi (ls) call error (0, Memc[str]) } if ((IN_C2(ccd)-IN_C1(ccd) != (CCD_C2(ccd)-CCD_C1(ccd))/cs) || (IN_L2(ccd)-IN_L1(ccd) != (CCD_L2(ccd)-CCD_L1(ccd))/ls)) { if ((min(c1,c2) > min(CCD_C1(ccd),CCD_C2(ccd))) || (max(c1,c2) < max(CCD_C1(ccd),CCD_C2(ccd))) || (min(l1,l2) > min(CCD_L1(ccd),CCD_L2(ccd))) || (max(l1,l2) < max(CCD_L1(ccd),CCD_L2(ccd)))) { call sprintf (Memc[str], SZ_LINE, "CCD section error: target=[%d:%d,%d:%d], calibration=[%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 pargi (c1) call pargi (c2) call pargi (l1) call pargi (l2) call error (1, Memc[str]) } } data_c2 = (CCD_C2(ccd) - c1) / cs + data_c1 data_c1 = (CCD_C1(ccd) - c1) / cs + data_c1 data_l2 = (CCD_L2(ccd) - l1) / ls + data_l1 data_l1 = (CCD_L1(ccd) - l1) / ls + data_l1 call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setsflat.x����������������������������������������������������0000664�0000000�0000000�00000006267�13321663143�0020621�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include "ccdred.h" include "ccdtypes.h" # SET_SFLAT -- Set parameters for second flat field correction. # # 1. Return immediately if the sky flat field correction is not requested or # if the image has been previously corrected. # 2. Get the sky flat field image and return on an error. # 3. If the sky 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_sflat (ccd) pointer ccd # CCD structure pointer sp, str, image, im, ccd_cache() bool clgetb(), ccdflag(), ccdcheck() int nscan, ccdnscan() real ccdmean() errchk cal_image, ccd_cache, ccdproc1, ccdproc2, ccdmean, set_calsection begin # Check if the user wants this operation or if it has been done. if (!clgetb ("sflatcor") || ccdflag (IN_IM(ccd), "sflatcor")) return # Require the first flat field correction to be done. #if (!ccdflag (IN_IM(ccd), "flatcor") && CORS(ccd, FLATCOR) != F) # call error (1, # "Sky flat field correction requires flat field correction") call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) # Get the sky flat field correction image. if (clgetb ("scancor")) nscan = ccdnscan (IN_IM(ccd), IN_CCDTYPE(ccd)) else nscan = 1 call cal_image (IN_IM(ccd), SFLAT, nscan, Memc[image], SZ_FNAME) # If not processing print sky flat field image name and return. if (LISTPROC(ccd) == YES) { call eprintf (" [TO BE DONE] Sky flat is %s.\n") call pargstr (Memc[image]) call sfree (sp) return } # Map the image and return on an error. # Process the sky 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], SFLAT)) { call cal_image (IN_IM(ccd), SFLAT, 1, Memc[str], SZ_LINE) im = ccd_cache (Memc[str], SFLAT) if (ccdcheck (im, SFLAT, "")) { call ccd_flush (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[str], Memc[str], SFLAT) case CALPROC_NO: call ccdproc2 (Memc[str], Memc[str], SFLAT) PROC(ccd) = NO call sfree (sp) return } } call scancor (Memc[str], Memc[image], nscan, MINREPLACE(ccd)) im = ccd_cache (Memc[image], SFLAT) } if (ccdcheck (im, SFLAT, "")) { call ccd_flush (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[image], Memc[image], SFLAT) case CALPROC_NO: call ccdproc2 (Memc[image], Memc[image], SFLAT) PROC(ccd) = NO call sfree (sp) return } im = ccd_cache (Memc[image], SFLAT) } SFLAT_IM(ccd) = im # Check and set data section. call set_calsection (ccd, SFLAT_IM(ccd), SFLAT_C1(ccd), SFLAT_C2(ccd), SFLAT_L1(ccd), SFLAT_L2(ccd)) # Set the scaling factor from the mean. SFLATSCALE(ccd) = ccdmean (im) COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, SFLATCOR) = S # Log the operation. call sprintf (SFLATLOG(ccd), LEN_LOG, "Sky flat is %s, scale %g") call pargstr (Memc[image]) call pargr (SFLATSCALE(ccd)) call timelog (SFLATLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), SFLATLOG(ccd)) call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/settrim.x�����������������������������������������������������0000664�0000000�0000000�00000005614�13321663143�0020456�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include 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 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")) { TRIM_C1(ccd) = 1 TRIM_C2(ccd) = IM_LEN(IN_IM(ccd),1) TRIM_L1(ccd) = 1 TRIM_L2(ccd) = IM_LEN(IN_IM(ccd),2) TRIM_DC1(ccd) = 0 TRIM_DC2(ccd) = 0 TRIM_DL1(ccd) = 0 TRIM_DL2(ccd) = 0 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 (LISTPROC(ccd) == YES) { 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) TRIM_DC1(ccd) = max (0, c1 - IN_C1(ccd)) TRIM_DC2(ccd) = min (0, c2 - IN_C2(ccd)) TRIM_DL1(ccd) = max (0, l1 - IN_L1(ccd)) TRIM_DL2(ccd) = min (0, l2 - IN_L2(ccd)) CCD_C1(ccd) = CCD_C1(ccd) + CCD_CS(ccd) * TRIM_DC1(ccd) CCD_C2(ccd) = CCD_C2(ccd) + CCD_CS(ccd) * TRIM_DC2(ccd) CCD_L1(ccd) = CCD_L1(ccd) + CCD_LS(ccd) * TRIM_DL1(ccd) CCD_L2(ccd) = CCD_L2(ccd) + CCD_LS(ccd) * TRIM_DL2(ccd) IN_C1(ccd) = IN_C1(ccd) + TRIM_DC1(ccd) IN_C2(ccd) = IN_C2(ccd) + TRIM_DC2(ccd) IN_L1(ccd) = IN_L1(ccd) + TRIM_DL1(ccd) IN_L2(ccd) = IN_L2(ccd) + TRIM_DL2(ccd) 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 COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, TRIM) = YES call sprintf (TRIMLOG(ccd), LEN_LOG, "Trim is [%d:%d,%d:%d]") call pargi (c1) call pargi (c2) call pargi (l1) call pargi (l2) call timelog (TRIMLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), TRIMLOG(ccd)) call sfree (sp) end ��������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/setzero.x�����������������������������������������������������0000664�0000000�0000000�00000005516�13321663143�0020463�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include 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 pointer sp, str, image, im, ccd_cache() bool clgetb(), ccdflag(), ccdcheck() int nscan, ccdnscan() errchk cal_image, ccd_cache, ccdproc1, ccdproc2, set_calsection 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), IN_CCDTYPE(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 (LISTPROC(ccd) == YES) { call eprintf (" [TO BE DONE] Zero 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) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[str], Memc[str], ZERO) case CALPROC_NO: call ccdproc2 (Memc[str], Memc[str], ZERO) PROC(ccd) = NO call sfree (sp) return } } call scancor (Memc[str], Memc[image], nscan, INDEF) im = ccd_cache (Memc[image], ZERO) } if (ccdcheck (im, ZERO, "")) { call ccd_flush (im) switch (CALPROC(ccd)) { case CALPROC_YES: call ccdproc1 (Memc[image], Memc[image], ZERO) case CALPROC_NO: call ccdproc2 (Memc[image], Memc[image], ZERO) PROC(ccd) = NO call sfree (sp) return } im = ccd_cache (Memc[image], ZERO) } ZERO_IM(ccd) = im # Check and set data section. call set_calsection (ccd, ZERO_IM(ccd), ZERO_C1(ccd), ZERO_C2(ccd), ZERO_L1(ccd), ZERO_L2(ccd)) COR(ccd) = YES COROUT(ccd) = YES CORS(ccd, ZEROCOR) = Z # Log the operation. call sprintf (ZEROLOG(ccd), LEN_LOG, "Zero is %s") call pargstr (Memc[image]) call timelog (ZEROLOG(ccd), LEN_LOG) call ccdlog (IN_IM(ccd), ZEROLOG(ccd)) call sfree (sp) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdgroups.x�������������������������������������������������0000664�0000000�0000000�00000023444�13321663143�0021304�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include # Group type definitions. define GROUPS "|keyword|ccdtype|subset|amplifier|ccdname|ampsubsets|\ |position|date|" define KEYWORD 1 # Group by keyword define CCDTYPE 2 # Group by ccdtype define SUBSET 3 # Group by subset define AMP 4 # Group by amp define CCDNAME 5 # Group by ccdname define AMPSUB 6 # Group by amp and subset define POSITION 8 # Group by position define DATE 9 # Group by position define GRP_LEN 200 # Length of strings define GRP_GSYMLEN 102 # Length of group symbol define GRP_INDEX Memi[$1] # Group index define GRP_SEQ Memi[$1+1] # Group sequence number define GRP_ID Memc[P2C($1+2)] # Group identification define GRP_FSYMLEN 1 define GRP_NMEMBER Memi[$1] # Number of members define NALLOC 10 # Allocate memory in this size block define SZ_KEYS (10*SZ_LINE) # Size of key string # 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 pointer list # Output file containing list of files pointer ccdtype # CCD type to select int mingroup # Minumum number in a group bool sequence # Break into sequences? int group # Group type int keywords # Keywords real radius # Position radius bool cluster # Output only cluster name? bool verbose # Verbose output (package parameter) int i, fd, fdlist, npositions pointer im, sp, image, keyword, key, keys, output, positions pointer stpg, stpf, sym, ptr bool clgetb(), strne() real clgetr() int clgeti(), clpopnu(), clgfil(), imtopenp(), imtlen(), imtgetim() int open(), clgwrd(), stridxs(), nowhite() int ccdtypecl(), ccdtypes() pointer stopen(), sthead(), stnext(), stenter(), stname(), immap() errchk open, hdmgstr, ccdtypes, ccdsubset, ccdamp, ccdname errchk group_position, group_name begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (root, SZ_FNAME, TY_CHAR) call salloc (list, SZ_FNAME, TY_CHAR) call salloc (ccdtype, SZ_LINE, TY_CHAR) call salloc (keyword, SZ_FNAME, TY_CHAR) call salloc (key, SZ_LINE, TY_CHAR) call salloc (keys, SZ_KEYS, TY_CHAR) call salloc (output, SZ_FNAME, TY_CHAR) # Get the task parameters. images = imtopenp ("images") call clgstr ("output", Memc[root], SZ_FNAME) call clgstr ("list", Memc[list], SZ_FNAME) i = ccdtypecl ("ccdtype", Memc[ccdtype], SZ_LINE) mingroup = clgeti ("mingroup") sequence = clgetb ("sequence") group = clgwrd ("group", Memc[image], SZ_FNAME, GROUPS) keywords = clpopnu ("keywords") radius = clgetr ("radius") call clgstr ("instrument", Memc[image], SZ_FNAME) call hdmopen (Memc[image]) cluster = clgetb ("cluster") verbose = clgetb ("verbose") # Open file for list of filenames. if (nowhite (Memc[list], Memc[list], SZ_FNAME) > 0) fdlist = open (Memc[list], NEW_FILE, TEXT_FILE) else fdlist = NULL # Setup the groups and files symbol tables. i = imtlen (images) stpg = stopen ("groups", i, i, i * SZ_LINE) stpf = stopen ("files", i, i, i * SZ_LINE) # Loop through the images and place them into groups. positions = NULL npositions = 0 while (imtgetim (images, Memc[image], SZ_FNAME) != EOF) { # Map the input and check the CCDTYPE. iferr (im = immap (Memc[image], READ_ONLY, 0)) { call erract (EA_WARN) next } i = ccdtypes (im, Memc[key], SZ_LINE) if (Memc[ccdtype] != EOS && strne (Memc[ccdtype], Memc[key])) { call imunmap (im) next } iferr { # Set the key string. call clprew (keywords) Memc[keys] = EOS while (clgfil (keywords, Memc[keyword], SZ_LINE) != EOF) { ifnoerr (call hdmgstr (im, Memc[keyword], Memc[key], SZ_LINE)) { call strcat (Memc[key], Memc[keys], SZ_KEYS) call strcat (" ", Memc[keys], SZ_KEYS) } } # Define the output group file. switch (group) { case KEYWORD: call group_name (stpg, stpf, Memc[keys], "", sequence, Memc[root], Memc[output], SZ_FNAME) case CCDTYPE: i = ccdtypes (im, Memc[key], SZ_FNAME) call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], Memc[key], sequence, Memc[root], Memc[output], SZ_FNAME) case SUBSET: call ccdsubset (im, Memc[key], SZ_FNAME) call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], Memc[key], sequence, Memc[root], Memc[output], SZ_FNAME) case AMP: call ccdamp (im, Memc[key], SZ_FNAME) call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], Memc[key], sequence, Memc[root], Memc[output], SZ_FNAME) case CCDNAME: call ccdname (im, Memc[key], SZ_FNAME) call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], Memc[key], sequence, Memc[root], Memc[output], SZ_FNAME) case AMPSUB: call ccdamp (im, Memc[key], SZ_FNAME) call ccdsubset (im, Memc[output], SZ_FNAME) call strcat (Memc[output], Memc[key], SZ_FNAME) call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], Memc[key], sequence, Memc[root], Memc[output], SZ_FNAME) case POSITION: call group_position (im, positions, npositions, radius, Memc[key], SZ_LINE) call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], "", sequence, Memc[root], Memc[output], SZ_FNAME) case DATE: call hdmgstr (im, "date-obs", Memc[key], SZ_LINE) i = stridxs ("T", Memc[key]) if (i > 0) Memc[key+i-1] = EOS call strcat (Memc[key], Memc[keys], SZ_KEYS) call group_name (stpg, stpf, Memc[keys], "", sequence, Memc[root], Memc[output], SZ_FNAME) } # Print the operation if verbose. if (verbose) { call printf ("%s --> %s\n") call pargstr (Memc[image]) call pargstr (Memc[output]) } # Enter the image or cluster in the appropriate group file. if (cluster) call imgcluster (Memc[image], Memc[image], SZ_FNAME) 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) } # Write list of filenames. First create a new symbol table in # order to reverse the order. if (fdlist != NULL) { call stclose (stpg) stpg = stopen ("files", 10, 10, 10 * SZ_LINE) for (sym = sthead (stpf); sym != NULL; sym = stnext (stpf, sym)) { output = stname (stpf, sym) if (GRP_NMEMBER(sym) < mingroup) call delete (Memc[output]) else ptr = stenter (stpg, Memc[output], GRP_FSYMLEN) } for (sym = sthead (stpg); sym != NULL; sym = stnext (stpg, sym)) { output = stname (stpg, sym) call fprintf (fdlist, "%s\n") call pargstr (Memc[output]) } call close (fdlist) } # Finish up. call imtclose (images) if (positions != NULL) call mfree (positions, TY_REAL) call stclose (stpf) call stclose (stpg) call sfree (sp) end # GROUP_NAME -- Group images. procedure group_name (stpg, stpf, key, id, sequence, root, fname, maxchar) pointer stpg #I Group symbol table pointer stpf #I File symbol table char key[ARB] #U Key string char id[ARB] #I Identification string bool sequence #I Break into sequences? char root[ARB] #I Root filename char fname[ARB] #O Output filename int maxchar #I Size of output filename pointer sym #O Symbol table pointer pointer lastsym, symseq, stfind(), stenter(), sthead() errchk hdmgstr, stfind, stenter, sthead begin if (key[1] == EOS) sym = stfind (stpg, "NULL") else sym = stfind (stpg, key) if (sym == NULL) { lastsym = sthead (stpg) if (key[1] == EOS) sym = stenter (stpg, "NULL", GRP_GSYMLEN) else sym = stenter (stpg, key, GRP_GSYMLEN) if (lastsym == NULL) GRP_INDEX(sym) = 1 else GRP_INDEX(sym) = GRP_INDEX(lastsym) + 1 GRP_SEQ(sym) = 0 if (id[1] == EOS) { call sprintf (GRP_ID(sym), GRP_LEN, "%03d") call pargi (GRP_INDEX(sym)) } else call strcpy (id, GRP_ID(sym), GRP_LEN) } else if (sym != symseq) GRP_SEQ(sym) = GRP_SEQ(sym) + 1 if (!sequence || GRP_SEQ(sym) == 0) { call sprintf (fname, maxchar, "%s%s") call pargstr (root) call pargstr (GRP_ID(sym)) } else { call sprintf (fname, maxchar, "%s%s.%d") call pargstr (root) call pargstr (GRP_ID(sym)) call pargstr (GRP_SEQ(sym)) } symseq = sym sym = stfind (stpf, fname) if (sym == NULL) { sym = stenter (stpf, fname, GRP_FSYMLEN) GRP_NMEMBER(sym) = 1 } else GRP_NMEMBER(sym) = GRP_NMEMBER(sym) + 1 end # GROUP_POSITION -- Group by RA and DEC position. The RA is in hours and # the DEC is in degrees. The radius is in seconds of arc. procedure group_position (im, positions, npositions, radius, key, maxchar) pointer im # Image pointer positions # Positions int npositions # Number of positions real radius # Matching radius char key[ARB] #O Key int maxchar #I Size of key 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 } call sprintf (key, maxchar, "%d") call pargi (i) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdhedit.x��������������������������������������������������0000664�0000000�0000000�00000004553�13321663143�0021062�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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 �����������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdinst.x���������������������������������������������������0000664�0000000�0000000�00000051172�13321663143�0020741�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include 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|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|amplifier|" 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 BIASSEC 15 # Bias section define CCDSEC 16 # CCD section define DATASEC 17 # Data section define TRIMSEC 18 # Trim section define DARKCOR 19 # Dark count flag define FIXPIX 20 # Bad pixel flag define FLATCOR 21 # Flat field flag define FRINGCOR 22 # Fringe flag define ILLUMCOR 23 # Illumination flag define OVERSCAN 24 # Overscan flag define READCOR 25 # Readout flag define SCANCOR 26 # Scan mode flag define NSCANROW 41 # Number of scan rows define TRIM 27 # Trim flag define ZEROCOR 28 # Zero level flag define CCDMEAN 29 # CCD mean value define FRINGSCL 30 # Fringe scale value define ILLUMFLT 31 # Illumination flat flag define MKFRINGE 32 # Illumination flag define MKILLUM 33 # Illumination flag define SKYFLAT 34 # Sky flat flag define NCOMBINE 35 # NCOMBINE parameter define DATEOBS 36 # Date define DEC 37 # Dec define RA 38 # RA define TITLE 39 # Title define NEXT 40 # Next image define AMP 42 # Amplifier parameter # T_CCDINST -- Check and modify instrument translations procedure t_ccdinst () int list, level, ncmd, imtopenp(), imtgetim(), scan(), access(), clgwrd() pointer sp, image, inst, ampfile, 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 (ampfile, 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 ("ampfile", Memc[ampfile], SZ_FNAME) call clgstr ("ssfile", Memc[ssfile], SZ_FNAME) level = clgwrd ("parameters", Memc[image], SZ_FNAME, LEVELS) 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[ampfile], Memc[ssfile], level, ncmd, update) else call ccdinst_hdr (im, Memc[image], Memc[inst], Memc[ampfile], 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, ampfile, ssfile, level, ncmd, update) pointer im # Image pointer char image[SZ_FNAME] # Image name char inst[SZ_FNAME] # Instrument file char ampfile[SZ_FNAME] # Amplifier file char ssfile[SZ_FNAME] # Subset file int level # Parameter level int ncmd # Last command bool update # Update? bool strne() int ccdcode, scan(), nscan(), strdic(), access(), ccdtypes() 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, ampfile, 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, ampfile, 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, ampfile, ssfile, level) } } case TRANSLATE: ccdcode = 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 AMP: call ccdinst_e (im, "amplifier parameter", "amp", 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 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, ampfile, ssfile, level) pointer im # Image pointer char image[SZ_FNAME] # Image name char inst[SZ_FNAME] # Instrument file char ampfile[SZ_FNAME] # Amplifier 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 ("Amplifier file: %s\n") call pargstr (ampfile) 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, "amp", 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 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, ccdcode, strdic(), hdmaccf(), ccdtypes() 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) ccdcode = ccdtypes (im, def, SZ_LINE) call printf (" %-8s %-.39s\n") call pargstr (def) call pargstr (value) case AMP: call printf ("%-8s %-8s %-8s") call pargstr (name) call pargstr (key) call pargstr (def) call ccdamp (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 MASK, 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdlist.x���������������������������������������������������0000664�0000000�0000000�00000025307�13321663143�0020740�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include 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, amp/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, type, str, im bool clgetb(), strne() int imtopenp(), imtgetim(), ccdtypecl(), ccdtypes() pointer immap() begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (type, SZ_LINE, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) # Get the task parameters and open the translation file. list = imtopenp ("images") ccdtype = ccdtypecl ("ccdtype", Memc[type], SZ_LINE) names = clgetb ("names") lformat = clgetb ("long") call clgstr ("instrument", Memc[image], SZ_FNAME) call hdmopen (Memc[image]) # List each image. while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { iferr (im = immap (Memc[image], READ_ONLY, 0)) { call erract (EA_WARN) next } # Check the CCD type. ccdtype = ccdtypes (im, Memc[str], SZ_LINE) if (Memc[type] != EOS && strne (Memc[type], Memc[str])) 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, # image size, pixel type, image type, amplifier, subset ID, processing flags, # and title. procedure shortlist (image, ccdtype, im) char image # Image name int ccdtype # CCD image type pointer im # IMIO pointer int ccdcode, ccdtypes() bool ccdflag() pointer sp, str, amp, subset begin call smark (sp) call salloc (str, SZ_CCDLINE, TY_CHAR) call salloc (amp, SZ_CCDLINE, TY_CHAR) call salloc (subset, SZ_CCDLINE, TY_CHAR) # Get the image type, amp, and subset ID. ccdcode = ccdtypes (im, Memc[str], SZ_CCDLINE) call ccdamp (im, Memc[amp], 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][%s][%s]") 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[amp]) call pargstr (Memc[subset]) # Format and list the processing flags. Memc[str] = EOS if (ccdflag (im, "xtalkcor")) call strcat ("X", Memc[str], SZ_CCDLINE) 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, "sflatcor")) call strcat ("S", 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, key, instr, outstr bool clgetb(), ccdflag(), streq() define done_ 99 begin call smark (sp) call salloc (key, SZ_LINE, TY_CHAR) 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, "xtalkcor")) { call hdmgstr (im, "xtalkcor", Memc[outstr], SZ_LINE) call printf (" %s\n") call pargstr (Memc[outstr]) } else if (clgetb ("xtalkcor")) { call clgstr ("xtalkfile", Memc[outstr], SZ_LINE) call printf (" [TO BE DONE] Crosstalk file is %s\n") call pargstr (Memc[outstr]) } 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[key], SZ_LINE) if (streq (Memc[key], "image")) call strcpy ("!biassec", Memc[key], SZ_LINE) if (Memc[key] == '!') call hdmgstr (im, Memc[key+1], Memc[outstr], SZ_LINE) else call strcpy (Memc[key], 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[key], SZ_LINE) if (streq (Memc[key], "image")) call strcpy ("!trimsec", Memc[key], SZ_LINE) if (Memc[key] == '!') call hdmgstr (im, Memc[key+1], Memc[outstr], SZ_LINE) else call strcpy (Memc[key], Memc[outstr], SZ_LINE) call printf (" [TO BE DONE] Trim image section is %s\n") call pargstr (Memc[outstr]) } 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 printf (" [TO BE DONE] Bad pixel fixing\n") 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, "sflatcor")) { call hdmgstr (im, "sflatcor", 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 == SFLAT) { # 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, "sflatcor")) { call hdmgstr (im, "sflatcor", 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, "sflatcor")) { call hdmgstr (im, "sflatcor", Memc[outstr], SZ_LINE) call printf (" %s\n") call pargstr (Memc[outstr]) } else if (clgetb ("sflatcor")) call printf (" [TO BE DONE] Sky 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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdmask.x���������������������������������������������������0000664�0000000�0000000�00000024417�13321663143�0020721�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 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 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 �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdproc.x���������������������������������������������������0000664�0000000�0000000�00000002073�13321663143�0020723�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "ccdred.h" # T_CCDPROC -- Process CCD images # # This is a task entry procedure that get the input image list and then # calls the main processing task ccdproc1. The input images are # processed to a temporary output image which then replaces the # input image. Calibration images are also automatically processed. procedure t_ccdproc () int inlist # List of input CCD images int outlist # List of output CCD images int noilist # List of uninterpolated images int bpmlist # List of output bad pixel masks char selecttype[SZ_FNAME] # CCD image type int i, imtopen(), imtopenp(), ccdtypecl() errchk ccdproc1 begin # Set the input and output lists and the CCD type. inlist = imtopenp ("images") outlist = imtopenp ("output") noilist = imtopen ("") bpmlist = imtopenp ("bpmasks") i = ccdtypecl ("ccdtype", selecttype, SZ_FNAME) # Process the images. call ccdproc (inlist, outlist, noilist, bpmlist, ONERR_ORIG, selecttype, "", YES) # Finish up. call imtclose (bpmlist) call imtclose (noilist) call imtclose (outlist) call imtclose (inlist) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/t_ccdtool.x���������������������������������������������������0000664�0000000�0000000�00000003002�13321663143�0020726�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "ccdred.h" # T_CCDTOOL -- Process CCD images # # This is a task entry procedure that get input and output image lists # and then calls the main processing task ccdproc. It does not # automatically process calibration images. procedure t_ccdtool () int inlist # List of input CCD images int outlist # List of output CCD images int noilist # List of output no interplolation images int bpmlist # List of output bad pixel masks char selecttype[SZ_FNAME] # CCD type to select (if not null) char proctype[SZ_FNAME] # CCD processing type (if not null) int onerror # Error action int i, calproc, clgwrd(), imtopenp(), imtlen() ccdtypecl(), nowhite() errchk ccdproc begin # Set the input and output lists and the CCD type. inlist = imtopenp ("input") outlist = imtopenp ("output") noilist = imtopenp ("nointerp") bpmlist = imtopenp ("bpmasks") onerror = clgwrd ("onerror", selecttype, SZ_FNAME, ONERROR) call clgstr ("calproc", proctype, SZ_FNAME) calproc = CALPROC_NO if (nowhite(proctype, proctype, SZ_FNAME) == 0) calproc = CALPROC_IGNORE i = ccdtypecl ("ccdtype", selecttype, SZ_FNAME) i = ccdtypecl ("proctype", proctype, SZ_FNAME) if (imtlen (outlist) > 1 && imtlen (outlist) != imtlen (inlist)) call error (1, "Input and output image lists do not match") # Process the images. call ccdproc (inlist, outlist, noilist, bpmlist, onerror, selecttype, proctype, calproc) # Finish up. call imtclose (bpmlist) call imtclose (noilist) call imtclose (outlist) call imtclose (inlist) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/timelog.x�����������������������������������������������������0000664�0000000�0000000�00000001260�13321663143�0020420�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # 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 ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/xtfixpix.h����������������������������������������������������0000664�0000000�0000000�00000001777�13321663143�0020640�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# XT_FIXPIX data structure. define FP_LEN 13 # Length of FP structure define FP_PM Memi[$1] # Pixel mask pointer define FP_LVAL Memi[$1+1] # Mask value for line interpolation define FP_CVAL Memi[$1+2] # Mask value for column interpolation define FP_NCOLS Memi[$1+3] # Number of columns to interpolate define FP_PCOL Memi[$1+4] # Pointer to columns define FP_PL1 Memi[$1+5] # Pointer to start lines define FP_PL2 Memi[$1+6] # Pointer to end lines define FP_PV1 Memi[$1+7] # Pointer to start values define FP_PV2 Memi[$1+8] # Pointer to end values define FP_LMIN Memi[$1+9] # Minimum line define FP_LMAX Memi[$1+10] # Maximum line define FP_PIXTYPE Memi[$1+11] # Pixel type for values define FP_DATA Memi[$1+12] # Data values define FP_COL Memi[FP_PCOL($1)+$2-1] define FP_L1 Memi[FP_PL1($1)+$2-1] define FP_L2 Memi[FP_PL2($1)+$2-1] define FP_V1 (FP_PV1($1)+$2-1) define FP_V2 (FP_PV2($1)+$2-1) define FP_LDEF 1 # Default line interpolation code define FP_CDEF 2 # Default column interpolation code �mscred-5.05-2018.07.09/src/ccdred/src/xtfixpix.x����������������������������������������������������0000664�0000000�0000000�00000015764�13321663143�0020661�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include "xtfixpix.h" # XT_FPINIT -- Initialize FIXPIX data structure. # If the mask is null or empty a null pointer is returned. # If the mask is not empty the mask is examined for bad pixels requiring # column interpolation. The columns and interpolation endpoints are # recorded. Note that line interpolation does not need to be mapped since # this can be done efficiently as the reference image is accessed line by # line. pointer procedure xx_fpinit (pmin, lvalin, cvalin) pointer pmin #I Pixel mask int lvalin #I Input line interpolation code int cvalin #I Input column interpolation code int i, j, k, l, n, nc, nl, l1, l2, lmin, lmax, ncols, lval, cval, ncompress short val long v[IM_MAXDIM] pointer pm, fp, ptr, col, pl1, pl2 pointer sp, buf, cols bool pm_empty() pointer pm_newcopy() errchk pmglrs, pmplrs begin # Check for empty mask. if (pmin == NULL) return (NULL) if (pm_empty (pmin)) return (NULL) # Make an internal copy of the mask. pm = pm_newcopy (pmin) # Get mask size. call pm_gsize (pm, i, v, j) nc = v[1] nl = v[2] # Allocate memory and data structure. call smark (sp) call salloc (buf, 3*max(nc, nl), TY_SHORT) call salloc (cols, nc, TY_SHORT) call calloc (fp, FP_LEN, TY_STRUCT) # Set the mask codes. Go through the mask and change any mask codes # that match the input mask code to the output mask code (if they are # different). This is done to move the mask codes to a range that # won't conflict with the length values. For any other code replace # the value by the length of the bad region along the line. This # value will be used in comparison to the length along the column for # setting the interpolation for the narrower dimension. if ((IS_INDEFI(lvalin)||lvalin<1) && (IS_INDEFI(cvalin)||cvalin<1)) { lval = FP_LDEF cval = FP_CDEF } else if (IS_INDEFI(lvalin) || lvalin < 1) { lval = FP_LDEF cval = mod (cvalin - 1, nc) + 1 if (lval == cval) lval = FP_CDEF } else if (IS_INDEFI(cvalin) || cvalin < 1) { lval = mod (lvalin - 1, nc) + 1 cval = FP_CDEF if (cval == lval) cval = FP_LDEF } else if (lvalin != cvalin) { lval = mod (lvalin - 1, nc) + 1 cval = mod (cvalin - 1, nc) + 1 } else { call mfree (fp, TY_STRUCT) call sfree (sp) call error (1, "Interpolation codes cannot be the same") } call xx_fpsinterp (pmin, pm, nc, nl, v, Mems[buf], lvalin, cvalin, lval, cval) # Go through and check if there is any need for column interpolation; # i.e. are there any mask values different from the line interpolation. call aclrs (Mems[cols], nc) call amovkl (long(1), v, IM_MAXDIM) do l = 1, nl { v[2] = l call pmglrs (pm, v, Mems[buf], 0, nc, 0) ptr = buf + 3 do i = 2, Mems[buf] { val = Mems[ptr+2] if (val != lval) { val = 1 n = Mems[ptr+1] call amovks (val, Mems[cols+Mems[ptr]-1], n) } ptr = ptr + 3 } } n = 0 do i = 1, nc if (Mems[cols+i-1] != 0) n = n + 1 # If there are mask codes for either column interpolation or # interpolation lengths along lines to compare against column # interpolation check the interpolation length against the # column and set the line interpolation endpoints to use. # compute the minimum and maximum lines that are endpoints # to restrict the random access pass that will be needed to # get the endpoint values. if (n > 0) { n = n + 10 call malloc (col, n, TY_INT) call malloc (pl1, n, TY_INT) call malloc (pl2, n, TY_INT) ncols = 0 lmin = nl lmax = 0 ncompress = 0 do i = 1, nc { if (Mems[cols+i-1] == 0) next v[1] = i do l = 1, nl { v[2] = l call pmglps (pm, v, Mems[buf+l-1], 0, 1, 0) } for (l1=1; l1<=nl && Mems[buf+l1-1]==0; l1=l1+1) ; while (l1 <= nl) { l1 = l1 - 1 for (l2=l1+1; l2<=nl && Mems[buf+l2-1]!=0; l2=l2+1) ; j = 0 k = nc + l2 - l1 - 1 do l = l1+1, l2-1 { val = Mems[buf+l-1] if (val == cval) j = j + 1 else if (val > nc) { if (val > k) { j = j + 1 val = cval } else val = lval v[2] = l call pmplps (pm, v, val, 0, 1, PIX_SRC) ncompress = ncompress + 1 } } if (ncompress > 100) { call pm_compress (pm) ncompress = 0 } if (j > 0) { if (ncols == n) { n = n + 10 call realloc (col, n, TY_INT) call realloc (pl1, n, TY_INT) call realloc (pl2, n, TY_INT) } j = 1 + l1 - 1 k = 1 + l2 - 1 lmin = min (lmin, j, k) lmax = max (lmax, j, k) Memi[col+ncols] = i Memi[pl1+ncols] = j Memi[pl2+ncols] = k ncols = ncols + 1 } for (l1=l2+1; l1<=nl && Mems[buf+l1-1]==0; l1=l1+1) ; } } FP_LMIN(fp) = lmin FP_LMAX(fp) = lmax FP_NCOLS(fp) = ncols FP_PCOL(fp) = col FP_PL1(fp) = pl1 FP_PL2(fp) = pl2 } FP_PM(fp) = pm FP_LVAL(fp) = lval FP_CVAL(fp) = cval call sfree (sp) return (fp) end # XT_SINTERP -- Set length of line interpolation regions. # The mask values are set to the length of any column interpolation # plus an offset leaving any line and column interpolation codes # unchanged. These values will be used in a second pass to compare # to the lengths of line interpolation and then the mask values will # be reset to one of the line or column interpolation codes based on # the minimum distance. procedure xx_fpsinterp (pmin, pm, nc, nl, v, data, lvalin, cvalin, lvalout, cvalout) pointer pmin #I Input pixel mask pointer pm #I Modified pixel mask int nc, nl #I Mask size long v[ARB] #I Coordinate vector short data[ARB] #I Data buffer int lvalin #I Input line interpolation code int cvalin #I Input column interpolation code int lvalout #I Output line interpolation code int cvalout #I Output column interpolation code int c, l, c1, c2, val bool pm_linenotempty() begin call amovkl (long(1), v, IM_MAXDIM) do l = 1, nl { v[2] = l if (!pm_linenotempty (pmin, v)) next call pmglps (pmin, v, data, 0, nc, 0) for (c1=1; c1<=nc && data[c1]==0; c1=c1+1) ; while (c1 <= nc) { for (c2=c1+1; c2<=nc && data[c2]!=0; c2=c2+1) ; c2 = c2 - 1 do c = c1, c2 { val = data[c] if (val == lvalin) { if (lvalin != lvalout) data[c] = lvalout } else if (val == cvalin) { if (cvalin != cvalout) data[c] = cvalout } else { data[c] = nc + c2 - c1 + 1 } } for (c1=c2+2; c1<=nc && data[c1]==0; c1=c1+1) ; } call pmplps (pm, v, data, 0, nc, PIX_SRC) } end # XT_FPFREE -- Free FIXPIX data structures. procedure xx_fpfree (fp) pointer fp #U FIXPIX data structure begin if (fp == NULL) return call mfree (FP_PCOL(fp), TY_INT) call mfree (FP_PL1(fp), TY_INT) call mfree (FP_PL2(fp), TY_INT) if (FP_PV1(fp) != NULL) call mfree (FP_PV1(fp), FP_PIXTYPE(fp)) if (FP_PV2(fp) != NULL) call mfree (FP_PV2(fp), FP_PIXTYPE(fp)) if (FP_DATA(fp) != NULL) call mfree (FP_DATA(fp), FP_PIXTYPE(fp)) call pm_close (FP_PM(fp)) call mfree (fp, TY_STRUCT) end ������������mscred-5.05-2018.07.09/src/ccdred/src/xtfp.gx�������������������������������������������������������0000664�0000000�0000000�00000014445�13321663143�0020121�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include "../xtfixpix.h" $for (silrd) # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure xx_fp$t (fp, im, line, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer imgl2$t(), xx_fps$t() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2$t (im, line)) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (xx_fps$t (fp, im, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure xx_fps$t (fp, im, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] $if (datatype == silr) real a, b, c, d, val $else PIXEL a, b, c, d, val $endif PIXEL indef pointer pm, data, bp bool pm_linenotempty() pointer imgl2$t(), xx_fpval$t() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (imgl2$t (im, line)) # Initialize pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_PIXEL call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEF call amovk$t (indef, Mem$t[FP_V1(fp,1)], ncols) call amovk$t (indef, Mem$t[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (imgl2$t (im, line)) else return (xx_fpval$t (fp, im, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=nc && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=nc && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Mem$t[data+c1-1] else a = Mem$t[data+c2-1] if (c2 <= col2) b = (Mem$t[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call parg$t (Mem$t[data+i-1]) $if (datatype == silr) call pargr (val) $else call parg$t (val) $endif if (c1 >= col1) { call fprintf (fd, " %4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, " %4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Mem$t[FP_V1(fp,j)] else c = Mem$t[FP_V2(fp,j)] if (l2 <= line2) { d = (Mem$t[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call parg$t (Mem$t[data+i-1]) $if (datatype == silr) call pargr (val) $else call parg$t (val) $endif if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } $if (datatype == sil) Mem$t[data+i-1] = nint (val) $else Mem$t[data+i-1] = val $endif } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure xx_fpval$t (fp, im, line) pointer fp #I FIXPIX pointer pointer im #I Image pointer int line #I Line int i pointer data, imgl2$t() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mem$t[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Mem$t[FP_V2(fp,i)] = 0. } return (NULL) } data = imgl2$t (im, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mem$t[FP_V1(fp,i)] = Mem$t[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Mem$t[FP_V2(fp,i)] = Mem$t[data+FP_COL(fp,i)-1] } return (data) end $endfor ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/src/xtpmmap.x�����������������������������������������������������0000664�0000000�0000000�00000000634�13321663143�0020452�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include # XT_PMUNMAP -- Unmap a mask image. # Note that the imio pointer may be purely an internal pointer opened # with im_pmmapo so we need to free the pl pointer explicitly. procedure yt_pmunmap (im) pointer im #I IMIO pointer for mask pointer pm int imstati() begin pm = imstati (im, IM_PMDES) call pm_close (pm) call imseti (im, IM_PMDES, NULL) call imunmap (im) end ����������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/x_ccdred.x��������������������������������������������������������0000664�0000000�0000000�00000000307�13321663143�0017745�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������task ccddelete = t_ccddelete, ccdgroups = t_ccdgroups, ccdhedit = t_ccdhedit, ccdinstrument = t_ccdinst, ccdlist = t_ccdlist, ccdmask = t_ccdmask, ccdproc = t_ccdproc, ccdtool = t_ccdtool �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdred/zerocombine.cl����������������������������������������������������0000664�0000000�0000000�00000004304�13321663143�0020636�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# ZEROCOMBINE -- Process and combine zero level CCD images. procedure zerocombine (input) string input {prompt="List of zero level images to combine"} file output="Zero" {prompt="Output zero level name"} string combine="average" {prompt="Type of combine operation", enum="average|median"} string reject="minmax" {prompt="Type of rejection", enum="none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip"} string ccdtype="zero" {prompt="CCD image type to combine"} bool process=yes {prompt="Process images before combining?"} bool delete=no {prompt="Delete input images after combining?"} string scale="none" {prompt="Image scaling", enum="none|mode|median|mean|exposure"} string statsec="" {prompt="Image section for computing statistics"} int nlow=0 {prompt="minmax: Number of low pixels to reject"} int nhigh=1 {prompt="minmax: Number of high pixels to reject"} int nkeep=1 {prompt="Minimum to keep (pos) or maximum to reject (neg)"} bool mclip=yes {prompt="Use median in sigma clipping algorithms?"} real lsigma=3. {prompt="Lower sigma clipping factor"} real hsigma=3. {prompt="Upper sigma clipping factor"} string rdnoise="0." {prompt="ccdclip: CCD readout noise (electrons)"} string gain="1." {prompt="ccdclip: CCD gain (electrons/DN)"} string snoise="0." {prompt="ccdclip: Sensitivity noise (fraction)"} real pclip=-0.5 {prompt="pclip: Percentile clipping parameter"} real blank=0. {prompt="Value if there are no pixels"} begin string ims, out ims = input out = output # Process images first if desired. if (process == YES) ccdproc (ims, output="", bpmasks="", ccdtype=ccdtype, noproc=no) # Combine the flat field images. combine (ims, output=out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigma="", imcmb="$I", combine=combine, reject=reject, ccdtype=ccdtype, amps=yes, subsets=no, delete=delete, project=no, outtype="real", outlimits="", offsets="none", masktype="none", blank=blank, scale=scale, zero="none", weight=no, statsec=statsec, lthreshold=INDEF, hthreshold=INDEF, nlow=nlow, nhigh=nhigh, nkeep=nkeep, mclip=mclip, lsigma=lsigma, hsigma=hsigma, rdnoise=rdnoise, gain=gain, snoise=snoise, sigscale=0.1, pclip=pclip, grow=0) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccdsection.x�������������������������������������������������������������0000664�0000000�0000000�00000004056�13321663143�0017071�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # 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 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/ccsetwcs.x���������������������������������������������������������������0000664�0000000�0000000�00000070603�13321663143�0016572�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include "skywcs.h" # Define the possible pixel types define CC_PIXTYPESTR "|logical|physical|" define CC_LOGICAL 1 define CC_PHYSICAL 2 procedure t_ccsetwcs () char image[SZ_FNAME] char wcssol[SZ_LINE], database[SZ_FNAME], solution[SZ_FNAME] pointer im, mw, immap(), ccsetwcs() int nscan() begin call clgstr ("image", image, SZ_FNAME) im = immap (image, READ_WRITE, 0) ifnoerr (call imgstr (im, "wcssol", wcssol, SZ_LINE)) { call sscan (wcssol) call gargwrd (database, SZ_FNAME) call gargwrd (solution, SZ_FNAME) if (nscan() != 2) call error (1, "Invalid WCSSOL keyword") mw = ccsetwcs (im, database, solution) if (mw != NULL) { call mw_saveim (mw, im) call mw_close (mw) call imdelf (im, "wcssol") } } call imunmap (im) end # CCSETWCS -- Read database and return MWCS pointer. pointer procedure ccsetwcs (im, database, solution) pointer im #I IMIO pointer char database[ARB] #I Database char solution[ARB] #I Database solution pointer mw #O MWCS pointer double xref, yref, xscale, yscale, xrot, yrot, lngref, latref int recstat, proj bool transpose pointer sp, projstr pointer dt, coo, sx1, sy1, sx2, sy2 int cc_dtwcs(), strdic() pointer dtmap(), cc_nwcsim() errchk dtmap, cc_dtwcs, cc_nwcsim begin call smark (sp) call salloc (projstr, SZ_LINE, TY_CHAR) mw = NULL # Get database solution. sx1 = NULL; sx2 = NULL sy1 = NULL; sy2 = NULL coo = NULL dt = dtmap (database, READ_ONLY) recstat = cc_dtwcs (dt, solution, coo, Memc[projstr], lngref, latref, sx1, sy1, sx2, sy2, xref, yref, xscale, yscale, xrot, yrot) call dtunmap (dt) # Get MWCS pointer. if (recstat != ERR) { proj = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, WTYPE_LIST) if (proj <= 0 || proj == WTYPE_LIN) Memc[projstr] = EOS transpose = false mw = cc_nwcsim (im, coo, Memc[projstr], lngref, latref, sx1, sy1, sx2, sy2, transpose) } # Free memory. if (coo != NULL) call sk_close (coo) if (sx1 != NULL) call dgsfree (sx1) if (sy1 != NULL) call dgsfree (sy1) call sfree (sp) return (mw) end # CC_DTWCS -- Read the wcs from the database records written by CCMAP. int procedure cc_dtwcs (dt, record, coo, projection, lngref, latref, sx1, sy1, sx2, sy2, xref, yref, xscale, yscale, xrot, yrot) pointer dt #I pointer to the database char record[ARB] #I the database records to be read pointer coo #O pointer to the coordinate structure char projection[ARB] #O the sky projection geometry double lngref, latref #O the reference point world coordinates pointer sx1, sy1 #O pointer to the linear x and y fits pointer sx2, sy2 #O pointer to the distortion x and y fits double xref, yref #O the reference point in pixels double xscale, yscale #O the x and y scale factors double xrot, yrot #O the x and y axis rotation angles int i, op, ncoeff, junk, rec, coostat, lngunits, latunits, pixsys double xshift, yshift, a, b, c, d, denom pointer sp, xcoeff, ycoeff, nxcoeff, nycoeff, mw, projpar, projvalue bool fp_equald() double dtgetd() int dtlocate(), dtgeti(), dtscan(), sk_decwcs(), strdic(), strlen() int gstrcpy() errchk dtgstr(), dtgetd(), dtgeti(), dgsrestore() begin # Locate the appropriate records. iferr (rec = dtlocate (dt, record)) return (ERR) # Open the coordinate structure. iferr (call dtgstr (dt, rec, "coosystem", projection, SZ_FNAME)) return (ERR) coostat = sk_decwcs (projection, mw, coo, NULL) if (coostat == ERR || mw != NULL) { if (mw != NULL) call mw_close (mw) projection[1] = EOS return (ERR) } # Get the pixel coordinate system. iferr (call dtgstr (dt, rec, "pixsystem", projection, SZ_FNAME)) { pixsys = PIXTYPE_LOGICAL } else { pixsys = strdic (projection, projection, SZ_FNAME, PIXTYPE_LIST) if (pixsys != PIXTYPE_PHYSICAL) pixsys = PIXTYPE_LOGICAL } call sk_seti (coo, S_PTYPE, pixsys) # Get the reference point units. iferr (call dtgstr (dt, rec, "lngunits", projection, SZ_FNAME)) return (ERR) lngunits = strdic (projection, projection, SZ_FNAME, SKY_LNG_UNITLIST) if (lngunits > 0) call sk_seti (coo, S_NLNGUNITS, lngunits) iferr (call dtgstr (dt, rec, "latunits", projection, SZ_FNAME)) return (ERR) latunits = strdic (projection, projection, SZ_FNAME, SKY_LAT_UNITLIST) if (latunits > 0) call sk_seti (coo, S_NLATUNITS, latunits) # Get the reference point. iferr (call dtgstr (dt, rec, "projection", projection, SZ_FNAME)) return (ERR) iferr (lngref = dtgetd (dt, rec, "lngref")) return (ERR) iferr (latref = dtgetd (dt, rec, "latref")) return (ERR) # Read in the coefficients. iferr (ncoeff = dtgeti (dt, rec, "surface1")) return (ERR) call smark (sp) call salloc (xcoeff, ncoeff, TY_DOUBLE) call salloc (ycoeff, ncoeff, TY_DOUBLE) do i = 1, ncoeff { junk = dtscan(dt) call gargd (Memd[xcoeff+i-1]) call gargd (Memd[ycoeff+i-1]) } # Restore the linear part of the fit. call dgsrestore (sx1, Memd[xcoeff]) call dgsrestore (sy1, Memd[ycoeff]) # Get and restore the distortion part of the fit. ncoeff = dtgeti (dt, rec, "surface2") if (ncoeff > 0) { call salloc (nxcoeff, ncoeff, TY_DOUBLE) call salloc (nycoeff, ncoeff, TY_DOUBLE) do i = 1, ncoeff { junk = dtscan(dt) call gargd (Memd[nxcoeff+i-1]) call gargd (Memd[nycoeff+i-1]) } iferr { call dgsrestore (sx2, Memd[nxcoeff]) } then { call mfree (sx2, TY_STRUCT) sx2 = NULL } iferr { call dgsrestore (sy2, Memd[nycoeff]) } then { call mfree (sy2, TY_STRUCT) sy2 = NULL } } else { sx2 = NULL sy2 = NULL } # Compute the coefficients. call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) # Compute the reference point. denom = a * d - c * b if (denom == 0.0d0) xref = INDEFD else xref = (b * yshift - d * xshift) / denom if (denom == 0.0d0) yref = INDEFD else yref = (c * xshift - a * yshift) / denom # Compute the scale factors. xscale = sqrt (a * a + c * c) yscale = sqrt (b * b + d * d) # Compute the rotation angles. if (fp_equald (a, 0.0d0) && fp_equald (c, 0.0d0)) xrot = 0.0d0 else xrot = RADTODEG (atan2 (-c, a)) if (xrot < 0.0d0) xrot = xrot + 360.0d0 if (fp_equald (b, 0.0d0) && fp_equald (d, 0.0d0)) yrot = 0.0d0 else yrot = RADTODEG (atan2 (b, d)) if (yrot < 0.0d0) yrot = yrot + 360.0d0 # Read in up to 10 projection parameters. call salloc (projpar, SZ_FNAME, TY_CHAR) call salloc (projvalue, SZ_FNAME, TY_CHAR) op = strlen (projection) + 1 do i = 0, 9 { call sprintf (Memc[projpar], SZ_FNAME, "projp%d") call pargi (i) iferr (call dtgstr (dt, rec, Memc[projpar], Memc[projvalue], SZ_FNAME)) next op = op + gstrcpy (" ", projection[op], SZ_LINE - op + 1) op = op + gstrcpy (Memc[projpar], projection[op], SZ_LINE - op + 1) op = op + gstrcpy (" = ", projection[op], SZ_LINE - op + 1) op = op + gstrcpy (Memc[projvalue], projection[op], SZ_LINE - op + 1) } call sfree (sp) return (OK) end # CC_RPROJ -- Read the projection parameters from a file into an IRAF string # containing the projection type followed by an MWCS WAT string, e.g # "zpn projp1=value projp2=value" . int procedure cc_rdproj (fd, projstr, maxch) int fd #I the input file containing the projection parameters char projstr[ARB] #O the output projection parameters string int maxch #I the maximum size of the output projection string int projection, op pointer sp, keyword, value, param int fscan(), nscan(), strdic(), gstrcpy() begin projstr[1] = EOS if (fscan (fd) == EOF) return (0) call smark (sp) call salloc (keyword, SZ_FNAME, TY_CHAR) call salloc (value, SZ_FNAME, TY_CHAR) call salloc (param, SZ_FNAME, TY_CHAR) call gargwrd (Memc[keyword], SZ_FNAME) projection = strdic (Memc[keyword], Memc[keyword], SZ_FNAME, WTYPE_LIST) if (projection <= 0 || projection == WTYPE_LIN || nscan() == 0) { call sfree (sp) return (0) } # Copy the projection function into the projection string. op = 1 op = op + gstrcpy (Memc[keyword], projstr[op], maxch) # Copy the keyword value pairs into the projection string. while (fscan(fd) != EOF) { call gargwrd (Memc[keyword], SZ_FNAME) call gargwrd (Memc[value], SZ_FNAME) if (nscan() != 2) next call sprintf (Memc[param], SZ_FNAME, " %s = %s") call pargstr (Memc[keyword]) call pargstr (Memc[value]) op = op + gstrcpy (Memc[param], projstr[op], maxch - op + 1) } call sfree (sp) return (projection) end define NEWCD Memd[ncd+(($2)-1)*ndim+($1)-1] # CC_NWCSIM -- Set MWCS pointer. # # This is changed from the IMCOORDS version to # 1. Return the mwcs pointer rather than update the image # 2. If the database has a projection of tan and higher order terms set # a tnx projection # 3. Set the reference point to the one in the image rather than the database. pointer procedure cc_nwcsim (im, coo, projection, lngref, latref, sx1, sy1, sx2, sy2, transpose) pointer im #I the pointer to the input image pointer coo #I the pointer to the coordinate structure char projection[ARB] #I the sky projection geometry double lngref, latref #I the position of the reference point. pointer sx1, sy1 #I pointer to linear surfaces pointer sx2, sy2 #I pointer to distortion surfaces bool transpose #I transpose the wcs pointer mwnew #O MWCS pointer int l, i, ndim, naxes, ax1, ax2, axmap, wtype, szatstr double xshift, yshift, a, b, c, d, denom, xpix, ypix, tlngref, tlatref pointer mw, sp, r, w, cd, ltm, ltv, iltm, nr, ncd, axes, axno, axval pointer projstr, projpars, wpars, atstr bool streq() int mw_stati(), sk_stati(), strdic(), strlen(), itoc() pointer mw_openim(), mw_open() errchk mw_gwattrs(), mw_newsystem() begin # Open the image wcs and determine its size. mw = mw_openim (im) ndim = mw_stati (mw, MW_NPHYSDIM) # Allocate working memory for the wcs attributes, vectors, and # matrices. call smark (sp) call salloc (projstr, SZ_FNAME, TY_CHAR) call salloc (projpars, SZ_LINE, TY_CHAR) call salloc (wpars, SZ_LINE, TY_CHAR) call salloc (axno, IM_MAXDIM, TY_INT) call salloc (axval, IM_MAXDIM, TY_INT) call salloc (axes, IM_MAXDIM, TY_INT) call salloc (r, ndim, TY_DOUBLE) call salloc (w, ndim, TY_DOUBLE) call salloc (cd, ndim * ndim, TY_DOUBLE) call salloc (ltm, ndim * ndim, TY_DOUBLE) call salloc (ltv, ndim, TY_DOUBLE) call salloc (iltm, ndim * ndim, TY_DOUBLE) call salloc (nr, ndim, TY_DOUBLE) call salloc (ncd, ndim * ndim, TY_DOUBLE) # Get the image reference point. call mw_gwtermd (mw, Memd[nr], Memd[w], Memd[ncd], ndim) lngref = Memd[w] latref = Memd[w+1] call sk_seti (coo, S_NLNGUNITS, SKY_DEGREES) call sk_seti (coo, S_NLATUNITS, SKY_DEGREES) # Open the new wcs and set the system type. mwnew = mw_open (NULL, ndim) call mw_gsystem (mw, Memc[projstr], SZ_FNAME) iferr { call mw_newsystem (mw, "image", ndim) } then { call mw_newsystem (mwnew, Memc[projstr], ndim) } else { call mw_newsystem (mwnew, "image", ndim) } # Set the LTERM. call mw_gltermd (mw, Memd[ltm], Memd[ltv], ndim) call mw_sltermd (mwnew, Memd[ltm], Memd[ltv], ndim) # Store the old axis map for later use. call mw_gaxmap (mw, Memi[axno], Memi[axval], ndim) # Get the celestial coordinate axes list. call mw_gaxlist (mw, 03B, Memi[axes], naxes) axmap = mw_stati (mw, MW_USEAXMAP) ax1 = Memi[axes] ax2 = Memi[axes+1] # Set the axes and projection type for the celestial coordinate # axes. Don't worry about the fact that the axes may in fact be # glon and glat, elon and elat, or slon and slat, instead of # ra and dec. This will be fixed up later. if (projection[1] == EOS) { call mw_swtype (mwnew, Memi[axes], ndim, "linear", "") } else { call sscan (projection) call gargwrd (Memc[projstr], SZ_FNAME) call gargstr (Memc[projpars], SZ_LINE) call sprintf (Memc[wpars], SZ_LINE, "axis 1: axtype = ra %s axis 2: axtype = dec %s") call pargstr (Memc[projpars]) call pargstr (Memc[projpars]) if (streq (Memc[projstr], "tnx") && sx2 == NULL && sy2 == NULL) call strcpy ("tan", Memc[projstr], SZ_FNAME) else if (streq (Memc[projstr], "tan") && (sx2!=NULL || sy2==NULL)) call strcpy ("tnx", Memc[projstr], SZ_FNAME) call mw_swtype (mwnew, Memi[axes], ndim, Memc[projstr], Memc[wpars]) } # Copy the attributes of the remaining axes to the new wcs. szatstr = SZ_LINE call malloc (atstr, szatstr, TY_CHAR) do l = 1, ndim { if (l == ax1 || l == ax2) next iferr { call mw_gwattrs (mw, l, "wtype", Memc[projpars], SZ_LINE) } then { call mw_swtype (mwnew, l, 1, "linear", "") } else { call mw_swtype (mwnew, l, 1, Memc[projpars], "") } for (i = 1; ; i = i + 1) { if (itoc (i, Memc[projpars], SZ_LINE) <= 0) Memc[projpars] = EOS repeat { iferr (call mw_gwattrs (mw, l, Memc[projpars], Memc[atstr], szatstr)) Memc[atstr] = EOS if (strlen(Memc[atstr]) < szatstr) break szatstr = szatstr + SZ_LINE call realloc (atstr, szatstr, TY_CHAR) } if (Memc[atstr] == EOS) break call mw_swattrs (mwnew, l, Memc[projpars], Memc[atstr]) } } call mfree (atstr, TY_CHAR) # Compute the new referemce point. switch (sk_stati(coo, S_NLNGUNITS)) { case SKY_DEGREES: tlngref = lngref case SKY_RADIANS: tlngref = RADTODEG(lngref) case SKY_HOURS: tlngref = 15.0d0 * lngref default: tlngref = lngref } switch (sk_stati(coo, S_NLATUNITS)) { case SKY_DEGREES: tlatref = latref case SKY_RADIANS: tlatref = RADTODEG(latref) case SKY_HOURS: tlatref = 15.0d0 * latref default: tlatref = latref } if (! transpose) { Memd[w+ax1-1] = tlngref Memd[w+ax2-1] = tlatref } else { Memd[w+ax1-1] = tlatref Memd[w+ax2-1] = tlngref } # Fetch the linear coefficients of the fit. call geo_gcoeffd (sx1, sy1, xshift, yshift, a, b, c, d) # Compute the new reference pixel. denom = a * d - c * b if (denom == 0.0d0) xpix = INDEFD else xpix = (b * yshift - d * xshift) / denom if (denom == 0.0d0) ypix = INDEFD else ypix = (c * xshift - a * yshift) / denom Memd[nr+ax1-1] = xpix Memd[nr+ax2-1] = ypix # Compute the new CD matrix. if (! transpose) { NEWCD(ax1,ax1) = a / 3600.0d0 NEWCD(ax1,ax2) = c / 3600.0d0 NEWCD(ax2,ax1) = b / 3600.0d0 NEWCD(ax2,ax2) = d / 3600.0d0 } else { NEWCD(ax1,ax1) = c / 3600.0d0 NEWCD(ax1,ax2) = a / 3600.0d0 NEWCD(ax2,ax1) = d / 3600.0d0 NEWCD(ax2,ax2) = b / 3600.0d0 } # Recompute and store the new wcs. call mw_saxmap (mwnew, Memi[axno], Memi[axval], ndim) if (sk_stati (coo, S_PTYPE) == PIXTYPE_PHYSICAL) { call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[ncd], ndim) } else { call mwmmuld (Memd[ncd], Memd[ltm], Memd[cd], ndim) call mwinvertd (Memd[ltm], Memd[iltm], ndim) call asubd (Memd[nr], Memd[ltv], Memd[r], ndim) call mwvmuld (Memd[iltm], Memd[r], Memd[nr], ndim) call mw_swtermd (mwnew, Memd[nr], Memd[w], Memd[cd], ndim) } # Add the second order terms in the form of the wcs attributes # lngcor and latcor. These are not FITS standard and can currently # be understood only by IRAF. if ((streq(Memc[projstr], "zpx") || streq (Memc[projstr], "tnx")) && (sx2 != NULL || sy2 != NULL)) { if (! transpose) call cc_wcscor (im, mwnew, sx1, sx2, sy1, sy2, "lngcor", "latcor", ax1, ax2) else call cc_wcscor (im, mwnew, sx1, sx2, sy1, sy2, "lngcor", "latcor", ax2, ax1) } # Save the fit. if (! transpose) { call sk_seti (coo, S_PLNGAX, ax1) call sk_seti (coo, S_PLATAX, ax2) } else { call sk_seti (coo, S_PLNGAX, ax2) call sk_seti (coo, S_PLATAX, ax1) } call sk_hdrsaveim (coo, mwnew, im) #call mw_saveim (mwnew, im) #call mw_close (mwnew) call mw_close (mw) # Force the CTYPE keywords to update. This will be unecessary when # mwcs is updated to deal with non-quoted and / or non left-justified # CTYPE keywords.. wtype = strdic (Memc[projstr], Memc[projstr], SZ_FNAME, WTYPE_LIST) if (wtype > 0) call sk_seti (coo, S_WTYPE, wtype) #call sk_ctypeim (coo, im) # Reset the fit. #call sk_seti (coo, S_WTYPE, 0) #call sk_seti (coo, S_PLNGAX, 0) #call sk_seti (coo, S_PLATAX, 0) call sfree (sp) return (mwnew) end # CC_WCSCOR -- Reformulate the higher order surface fit into a correction # term in degrees that can be written into the header as a wcs attribute. # This attribute will be written as string containing the surface definition. procedure cc_wcscor (im, mw, sx1, sx2, sy1, sy2, xiname, etaname, xiaxis, etaaxis) pointer im #I pointer to the input image pointer mw #I pointer to the wcs structure pointer sx1, sx2 #I pointer to the linear and distortion xi surfaces pointer sy1, sy2 #I pointer to the linear and distortion eta surfaces char xiname[ARB] #I the wcs xi correction attribute name char etaname[ARB] #I the wcs eta correction attribute name int xiaxis #I the xi axis number int etaaxis #I the eta axis number int i, j, function, xxorder, xyorder, xxterms, yxorder, yyorder, yxterms int nx, ny, npix, ier double sxmin, sxmax, symin, symax, ratio, x, y, xstep, ystep, ximin, ximax double etamin, etamax pointer sp, xpix, ypix, xilin, etalin, dxi, deta, wgt, nsx2, nsy2 int dgsgeti() double dgsgetd() begin if (sx2 == NULL && sy2 == NULL) return if (dgsgeti (sx1, GSTYPE) != dgsgeti (sy1, GSTYPE)) return # Get the function, xmin, xmax, ymin, and ymax parameters for the # surfaces. function = min (dgsgeti (sx1, GSTYPE), dgsgeti (sy1, GSTYPE)) sxmin = max (dgsgetd (sx1, GSXMIN), dgsgetd (sy1, GSXMIN)) sxmax = min (dgsgetd (sx1, GSXMAX), dgsgetd (sy1, GSXMAX)) symin = max (dgsgetd (sx1, GSYMIN), dgsgetd (sy1, GSYMIN)) symax = min (dgsgetd (sx1, GSYMAX), dgsgetd (sy1, GSYMAX)) # Get the order and cross-terms parameters from the higher order # functions. if (sx2 != NULL) { xxorder = dgsgeti (sx2, GSXORDER) xyorder = dgsgeti (sx2, GSYORDER) xxterms = dgsgeti (sx2, GSXTERMS) } else { xxorder = dgsgeti (sx1, GSXORDER) xyorder = dgsgeti (sx1, GSYORDER) xxterms = dgsgeti (sx1, GSXTERMS) } if (sy2 != NULL) { yxorder = dgsgeti (sy2, GSXORDER) yyorder = dgsgeti (sy2, GSYORDER) yxterms = dgsgeti (sy2, GSXTERMS) } else { yxorder = dgsgeti (sy1, GSXORDER) yyorder = dgsgeti (sy1, GSYORDER) yxterms = dgsgeti (sy1, GSXTERMS) } # Choose a reasonable coordinate grid size based on the x and y order # of the fit and the number of rows and columns in the image. ratio = double (IM_LEN(im,2)) / double (IM_LEN(im,1)) nx = max (xxorder + 3, yxorder + 3, 10) ny = max (yyorder + 3, xyorder + 3, nint (ratio * 10)) npix = nx * ny # Allocate some working space. call smark (sp) call salloc (xpix, npix, TY_DOUBLE) call salloc (ypix, npix, TY_DOUBLE) call salloc (xilin, npix, TY_DOUBLE) call salloc (etalin, npix, TY_DOUBLE) call salloc (dxi, npix, TY_DOUBLE) call salloc (deta, npix, TY_DOUBLE) call salloc (wgt, npix, TY_DOUBLE) # Compute the grid of x and y points. xstep = (sxmax - sxmin) / (nx - 1) ystep = (symax - symin) / (ny - 1) y = symin npix = 0 do j = 1, ny { x = sxmin do i = 1, nx { Memd[xpix+npix] = x Memd[ypix+npix] = y x = x + xstep npix = npix + 1 } y = y + ystep } # Compute the weights call amovkd (1.0d0, Memd[wgt], npix) # Evalute the linear surfaces and convert the results from arcseconds # to degrees. call dgsvector (sx1, Memd[xpix], Memd[ypix], Memd[xilin], npix) call adivkd (Memd[xilin], 3600.0d0, Memd[xilin], npix) call alimd (Memd[xilin], npix, ximin, ximax) call dgsvector (sy1, Memd[xpix], Memd[ypix], Memd[etalin], npix) call adivkd (Memd[etalin], 3600.0d0, Memd[etalin], npix) call alimd (Memd[etalin], npix, etamin, etamax) # Evalute the distortion surfaces, convert the results from arcseconds # to degrees, and compute new distortion surfaces. if (sx2 != NULL) { call dgsvector (sx2, Memd[xpix], Memd[ypix], Memd[dxi], npix) call adivkd (Memd[dxi], 3600.0d0, Memd[dxi], npix) call dgsinit (nsx2, function, xxorder, xyorder, xxterms, ximin, ximax, etamin, etamax) call dgsfit (nsx2, Memd[xilin], Memd[etalin], Memd[dxi], Memd[wgt], npix, WTS_UNIFORM, ier) call cc_gsencode (mw, nsx2, xiname, xiaxis) } else nsx2 = NULL if (sy2 != NULL) { call dgsvector (sy2, Memd[xpix], Memd[ypix], Memd[deta], npix) call adivkd (Memd[deta], 3600.0d0, Memd[deta], npix) call dgsinit (nsy2, function, yxorder, yyorder, yxterms, ximin, ximax, etamin, etamax) call dgsfit (nsy2, Memd[xilin], Memd[etalin], Memd[deta], Memd[wgt], npix, WTS_UNIFORM, ier) call cc_gsencode (mw, nsy2, etaname, etaaxis) } else nsy2 = NULL # Store the string in the mcs structure in the format of a wcs # attribute. # Free the new surfaces. if (nsx2 != NULL) call dgsfree (nsx2) if (nsy2 != NULL) call dgsfree (nsy2) call sfree (sp) end # CC_GSENCODE -- Encode the surface in an mwcs attribute. procedure cc_gsencode (mw, gs, atname, axis) pointer mw #I pointer to the mwcs structure pointer gs #I pointer to the surface to be encoded char atname[ARB] #I attribute name for the encoded surface int axis #I axis for which the encode surface is encoded int i, op, nsave, szatstr, szpar pointer sp, coeff, par, atstr int dgsgeti(), strlen(), gstrcpy() begin nsave = dgsgeti (gs, GSNSAVE) call smark (sp) call salloc (coeff, nsave, TY_DOUBLE) call salloc (par, SZ_LINE, TY_CHAR) call dgssave (gs, Memd[coeff]) szatstr = SZ_LINE call malloc (atstr, szatstr, TY_CHAR) op = 0 do i = 1, nsave { call sprintf (Memc[par], SZ_LINE, "%g ") call pargd (Memd[coeff+i-1]) szpar = strlen (Memc[par]) if (szpar > (szatstr - op)) { szatstr = szatstr + SZ_LINE call realloc (atstr, szatstr, TY_CHAR) } op = op + gstrcpy (Memc[par], Memc[atstr+op], SZ_LINE) } call mw_swattrs (mw, axis, atname, Memc[atstr]) call mfree (atstr, TY_CHAR) call sfree (sp) end # GEO_GCOEFF -- Print the coefficents of the linear portion of the # fit, xshift, yshift, procedure geo_gcoeffd (sx, sy, xshift, yshift, a, b, c, d) pointer sx #I pointer to the x surface fit pointer sy #I pointer to the y surface fit double xshift #O output x shift double yshift #O output y shift double a #O output x coefficient of x fit double b #O output y coefficient of x fit double c #O output x coefficient of y fit double d #O output y coefficient of y fit int nxxcoeff, nxycoeff, nyxcoeff, nyycoeff pointer sp, xcoeff, ycoeff double xxrange, xyrange, xxmaxmin, xymaxmin double yxrange, yyrange, yxmaxmin, yymaxmin int dgsgeti() double dgsgetd() begin # Allocate working space. call smark (sp) call salloc (xcoeff, dgsgeti (sx, GSNCOEFF), TY_DOUBLE) call salloc (ycoeff, dgsgeti (sy, GSNCOEFF), TY_DOUBLE) # Get coefficients and numbers of coefficients. call dgscoeff (sx, Memd[xcoeff], nxxcoeff) call dgscoeff (sy, Memd[ycoeff], nyycoeff) nxxcoeff = dgsgeti (sx, GSNXCOEFF) nxycoeff = dgsgeti (sx, GSNYCOEFF) nyxcoeff = dgsgeti (sy, GSNXCOEFF) nyycoeff = dgsgeti (sy, GSNYCOEFF) # Get the data range. if (dgsgeti (sx, GSTYPE) != GS_POLYNOMIAL) { xxrange = (dgsgetd (sx, GSXMAX) - dgsgetd (sx, GSXMIN)) / 2.0d0 xxmaxmin = - (dgsgetd (sx, GSXMAX) + dgsgetd (sx, GSXMIN)) / 2.0d0 xyrange = (dgsgetd (sx, GSYMAX) - dgsgetd (sx, GSYMIN)) / 2.0d0 xymaxmin = - (dgsgetd (sx, GSYMAX) + dgsgetd (sx, GSYMIN)) / 2.0d0 } else { xxrange = double(1.0) xxmaxmin = double(0.0) xyrange = double(1.0) xymaxmin = double(0.0) } if (dgsgeti (sy, GSTYPE) != GS_POLYNOMIAL) { yxrange = (dgsgetd (sy, GSXMAX) - dgsgetd (sy, GSXMIN)) / 2.0d0 yxmaxmin = - (dgsgetd (sy, GSXMAX) + dgsgetd (sy, GSXMIN)) / 2.0d0 yyrange = (dgsgetd (sy, GSYMAX) - dgsgetd (sy, GSYMIN)) / 2.0d0 yymaxmin = - (dgsgetd (sy, GSYMAX) + dgsgetd (sy, GSYMIN)) / 2.0d0 } else { yxrange = double(1.0) yxmaxmin = double(0.0) yyrange = double(1.0) yymaxmin = double(0.0) } # Get the shifts. xshift = Memd[xcoeff] + Memd[xcoeff+1] * xxmaxmin / xxrange + Memd[xcoeff+2] * xymaxmin / xyrange yshift = Memd[ycoeff] + Memd[ycoeff+1] * yxmaxmin / yxrange + Memd[ycoeff+2] * yymaxmin / yyrange # Get the rotation and scaling parameters and correct for normalization. if (nxxcoeff > 1) a = Memd[xcoeff+1] / xxrange else a = double(0.0) if (nxycoeff > 1) b = Memd[xcoeff+nxxcoeff] / xyrange else b = double(0.0) if (nyxcoeff > 1) c = Memd[ycoeff+1] / yxrange else c = double(0.0) if (nyycoeff > 1) d = Memd[ycoeff+nyxcoeff] / yyrange else d = double(0.0) call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/curfit/������������������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0016051�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/curfit/curfit.gx���������������������������������������������������������0000664�0000000�0000000�00000013032�13321663143�0017704�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include "curfit.h" define VERBOSE_OUTPUT 1 define LIST_OUTPUT 2 define DEFAULT_OUTPUT 3 define CF_UNIFORM 1 define CF_USER 2 define CF_STATISTICAL 3 define CF_INSTRUMENTAL 4 # CF_FIT -- Called once for each curve to be fit. $for (rd) procedure cf_fit$t (ic, gt, x, y, wts, nvalues, nmax, device, interactive, ofmt, power) pointer ic # ICFIT pointer pointer gt # Graphics tools pointer PIXEL x[nmax] # X data values PIXEL y[nmax] # Y data values PIXEL wts[nmax] # Weights int nvalues # Number of data points int nmax # Maximum number of data points char device[SZ_FNAME] # Output graphics device int interactive # Fit curve interactively? int ofmt # Type of output listing bool power # Convert coeff to power series? int ncoeff, i, fd PIXEL xmin, xmax pointer sp, fname, gp, cv, coeff pointer gopen() int open(), $tcvstati() begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) # Determine data range and set up curve fitting limits. call alim$t (x, nvalues, xmin, xmax) call ic_putr (ic, "xmin", real (xmin)) call ic_putr (ic, "xmax", real (xmax)) if (interactive == YES) { gp = gopen (device, NEW_FILE, STDGRAPH) call icg_fit$t (ic, gp, "cursor", gt, cv, x, y, wts, nvalues) call gclose (gp) } else # Do fit non-interactively call ic_fit$t (ic, cv, x, y, wts, nvalues, YES, YES, YES, YES) # Output answers. call clgstr ("output", Memc[fname], SZ_FNAME) call ic_vshow$t (ic, Memc[fname], cv, x, y, wts, nvalues, gt) # Convert coefficients if requested for legendre or chebyshev if (power) { # Calculate and print coefficients ncoeff = $tcvstati (cv, CVNCOEFF) call salloc (coeff, ncoeff, TY_PIXEL) call $tcvpower (cv, Mem$t[coeff], ncoeff) fd = open (Memc[fname], APPEND, TEXT_FILE) call fprintf (fd, "# Power series coefficients would be:\n") call fprintf (fd, "# \t\tcoefficient\n") do i = 1, ncoeff { call fprintf (fd, "# \t%d \t%14.7e\n") call pargi (i) call parg$t (Mem$t[coeff+i-1]) } call close (fd) } $if (datatype == r) call cvfree (cv) $else call $tcvfree (cv) $endif #call ic_close$t (ic) call sfree (sp) end # CF_LISTXY -- Print answers to STDOUT as x,y pairs. procedure cf_listxy$t (cv, xvals, yvals, wts, nvalues) pointer cv # Pointer to curfit structure int nvalues # Number of data values PIXEL xvals[nvalues] # Array of x data values PIXEL yvals[nvalues] # Array of y data values PIXEL wts[nvalues] # Array of weights int i PIXEL $tcveval() begin do i = 1, nvalues { call printf ("\t%14.7e \t%14.7e \t%14.7e \t%14.7e\n") call parg$t (xvals[i]) call parg$t ($tcveval (cv, xvals[i])) call parg$t (yvals[i]) call parg$t (wts[i]) } end # IM_PROJECTION -- Given an image section of arbitrary dimension, compute # the projection along a single axis by taking the average over the other # axes. We do not know about bad pixels. procedure im_projection$t (im, x, y, w, npix, weighting, axis) pointer im # Pointer to image header structure PIXEL x[npix] # Index of projection vector PIXEL y[npix] # Receives the projection vector PIXEL w[npix] # Receives the weight vector int weighting # Weighting of the individual points int npix # Length of projection vector int axis # The axis to be projected to (x=1) int i, lastv long v[IM_MAXDIM], nsum, totpix pointer pix PIXEL asum$t() pointer imgnl$t() errchk imgnl$t begin if (im == NULL) call error (1, "Image projection operator called with null im") if (axis < 1 || axis > IM_NDIM(im)) call error (2, "Attempt to take projection over nonexistent axis") # Set the y projection vector call aclr$t (y, npix) call amovkl (long(1), v, IM_MAXDIM) switch (axis) { case 1: # Since the image is read line by line, it is easy to compute the # projection along the x-axis (axis 1). We merely sum all of the # image lines. while (imgnl$t (im, pix, v) != EOF) call aadd$t (Mem$t[pix], y, y, npix) default: # Projecting along any other axis when reading the image line # by line is a bit difficult to understand. Basically, the # element 'axis' of the V vector (position of the line in the # image) gives us the index into the appropriate element of # y. When computing the projection over multiple dimensions, # the same output element will be referenced repeatedly. All # of the elmenents of the input line are summed and added into # this output element. for (lastv=v[axis]; imgnl$t (im, pix, v) != EOF; lastv=v[axis]) { i = lastv if (i <= npix) y[i] = y[i] + asum$t (Mem$t[pix], IM_LEN(im,1)) } } # Now compute the number of pixels contributing to each element # of the output vector. This is the number of pixels in the image # divided by the length of the projection. totpix = 1 do i = 1, IM_NDIM(im) if (i == axis) totpix = totpix * min (npix, IM_LEN(im,i)) else totpix = totpix * IM_LEN(im,i) nsum = totpix / min (npix, IM_LEN(im,axis)) # Compute the average by dividing by the number if pixels summed at # each point. call adivk$t (y, PIXEL (nsum), y, npix) # Set the x and weight vectors do i = 1, npix { x[i] = i switch (weighting) { case CF_STATISTICAL: if (y[i] > 0.0) w[i] = 1.0 / y[i] else if (y[i] < 0.0) w[i] = abs (1.0 / y[i]) else w[i] = 1.0 case CF_UNIFORM: w[i] = 1. default: w[i] = 1. } } end $endfor ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/curfit/curfit.h����������������������������������������������������������0000664�0000000�0000000�00000000663�13321663143�0017523�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# NAMES -- Map generic names to external names. define ic_fitr ic_fit define icg_fitr icg_fit define ic_freer ic_free define ic_errorsr ic_errors define rcvcoeff cvcoeff define rcverrors cverrors define rcveval cveval define rcvfit cvfit define rcvfree cvfree define rcvinit cvinit define rcvpower cvpower define rcvrefit cvrefit define rcvrject cvrject define rcvsolve cvsolve define rcvstati cvstati define rcvvector cvvector �����������������������������������������������������������������������������mscred-5.05-2018.07.09/src/curfit/curfit.x����������������������������������������������������������0000664�0000000�0000000�00000024722�13321663143�0017545�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include "curfit.h" define VERBOSE_OUTPUT 1 define LIST_OUTPUT 2 define DEFAULT_OUTPUT 3 define CF_UNIFORM 1 define CF_USER 2 define CF_STATISTICAL 3 define CF_INSTRUMENTAL 4 # CF_FIT -- Called once for each curve to be fit. procedure cf_fitr (ic, gt, x, y, wts, nvalues, nmax, device, interactive, ofmt, power) pointer ic # ICFIT pointer pointer gt # Graphics tools pointer real x[nmax] # X data values real y[nmax] # Y data values real wts[nmax] # Weights int nvalues # Number of data points int nmax # Maximum number of data points char device[SZ_FNAME] # Output graphics device int interactive # Fit curve interactively? int ofmt # Type of output listing bool power # Convert coeff to power series? int ncoeff, i, fd real xmin, xmax pointer sp, fname, gp, cv, coeff pointer gopen() int open(), rcvstati() begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) # Determine data range and set up curve fitting limits. call alimr (x, nvalues, xmin, xmax) call ic_putr (ic, "xmin", real (xmin)) call ic_putr (ic, "xmax", real (xmax)) if (interactive == YES) { gp = gopen (device, NEW_FILE, STDGRAPH) call icg_fitr (ic, gp, "cursor", gt, cv, x, y, wts, nvalues) call gclose (gp) } else # Do fit non-interactively call ic_fitr (ic, cv, x, y, wts, nvalues, YES, YES, YES, YES) # Output answers. call clgstr ("output", Memc[fname], SZ_FNAME) call ic_vshowr (ic, Memc[fname], cv, x, y, wts, nvalues, gt) # Convert coefficients if requested for legendre or chebyshev if (power) { # Calculate and print coefficients ncoeff = rcvstati (cv, CVNCOEFF) call salloc (coeff, ncoeff, TY_REAL) call rcvpower (cv, Memr[coeff], ncoeff) fd = open (Memc[fname], APPEND, TEXT_FILE) call fprintf (fd, "# Power series coefficients would be:\n") call fprintf (fd, "# \t\tcoefficient\n") do i = 1, ncoeff { call fprintf (fd, "# \t%d \t%14.7e\n") call pargi (i) call pargr (Memr[coeff+i-1]) } call close (fd) } call cvfree (cv) #call ic_close$t (ic) call sfree (sp) end # CF_LISTXY -- Print answers to STDOUT as x,y pairs. procedure cf_listxyr (cv, xvals, yvals, wts, nvalues) pointer cv # Pointer to curfit structure int nvalues # Number of data values real xvals[nvalues] # Array of x data values real yvals[nvalues] # Array of y data values real wts[nvalues] # Array of weights int i real rcveval() begin do i = 1, nvalues { call printf ("\t%14.7e \t%14.7e \t%14.7e \t%14.7e\n") call pargr (xvals[i]) call pargr (rcveval (cv, xvals[i])) call pargr (yvals[i]) call pargr (wts[i]) } end # IM_PROJECTION -- Given an image section of arbitrary dimension, compute # the projection along a single axis by taking the average over the other # axes. We do not know about bad pixels. procedure im_projectionr (im, x, y, w, npix, weighting, axis) pointer im # Pointer to image header structure real x[npix] # Index of projection vector real y[npix] # Receives the projection vector real w[npix] # Receives the weight vector int weighting # Weighting of the individual points int npix # Length of projection vector int axis # The axis to be projected to (x=1) int i, lastv long v[IM_MAXDIM], nsum, totpix pointer pix real asumr() pointer imgnlr() errchk imgnlr begin if (im == NULL) call error (1, "Image projection operator called with null im") if (axis < 1 || axis > IM_NDIM(im)) call error (2, "Attempt to take projection over nonexistent axis") # Set the y projection vector call aclrr (y, npix) call amovkl (long(1), v, IM_MAXDIM) switch (axis) { case 1: # Since the image is read line by line, it is easy to compute the # projection along the x-axis (axis 1). We merely sum all of the # image lines. while (imgnlr (im, pix, v) != EOF) call aaddr (Memr[pix], y, y, npix) default: # Projecting along any other axis when reading the image line # by line is a bit difficult to understand. Basically, the # element 'axis' of the V vector (position of the line in the # image) gives us the index into the appropriate element of # y. When computing the projection over multiple dimensions, # the same output element will be referenced repeatedly. All # of the elmenents of the input line are summed and added into # this output element. for (lastv=v[axis]; imgnlr (im, pix, v) != EOF; lastv=v[axis]) { i = lastv if (i <= npix) y[i] = y[i] + asumr (Memr[pix], IM_LEN(im,1)) } } # Now compute the number of pixels contributing to each element # of the output vector. This is the number of pixels in the image # divided by the length of the projection. totpix = 1 do i = 1, IM_NDIM(im) if (i == axis) totpix = totpix * min (npix, IM_LEN(im,i)) else totpix = totpix * IM_LEN(im,i) nsum = totpix / min (npix, IM_LEN(im,axis)) # Compute the average by dividing by the number if pixels summed at # each point. call adivkr (y, real (nsum), y, npix) # Set the x and weight vectors do i = 1, npix { x[i] = i switch (weighting) { case CF_STATISTICAL: if (y[i] > 0.0) w[i] = 1.0 / y[i] else if (y[i] < 0.0) w[i] = abs (1.0 / y[i]) else w[i] = 1.0 case CF_UNIFORM: w[i] = 1. default: w[i] = 1. } } end procedure cf_fitd (ic, gt, x, y, wts, nvalues, nmax, device, interactive, ofmt, power) pointer ic # ICFIT pointer pointer gt # Graphics tools pointer double x[nmax] # X data values double y[nmax] # Y data values double wts[nmax] # Weights int nvalues # Number of data points int nmax # Maximum number of data points char device[SZ_FNAME] # Output graphics device int interactive # Fit curve interactively? int ofmt # Type of output listing bool power # Convert coeff to power series? int ncoeff, i, fd double xmin, xmax pointer sp, fname, gp, cv, coeff pointer gopen() int open(), dcvstati() begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) # Determine data range and set up curve fitting limits. call alimd (x, nvalues, xmin, xmax) call ic_putr (ic, "xmin", real (xmin)) call ic_putr (ic, "xmax", real (xmax)) if (interactive == YES) { gp = gopen (device, NEW_FILE, STDGRAPH) call icg_fitd (ic, gp, "cursor", gt, cv, x, y, wts, nvalues) call gclose (gp) } else # Do fit non-interactively call ic_fitd (ic, cv, x, y, wts, nvalues, YES, YES, YES, YES) # Output answers. call clgstr ("output", Memc[fname], SZ_FNAME) call ic_vshowd (ic, Memc[fname], cv, x, y, wts, nvalues, gt) # Convert coefficients if requested for legendre or chebyshev if (power) { # Calculate and print coefficients ncoeff = dcvstati (cv, CVNCOEFF) call salloc (coeff, ncoeff, TY_DOUBLE) call dcvpower (cv, Memd[coeff], ncoeff) fd = open (Memc[fname], APPEND, TEXT_FILE) call fprintf (fd, "# Power series coefficients would be:\n") call fprintf (fd, "# \t\tcoefficient\n") do i = 1, ncoeff { call fprintf (fd, "# \t%d \t%14.7e\n") call pargi (i) call pargd (Memd[coeff+i-1]) } call close (fd) } call dcvfree (cv) #call ic_close$t (ic) call sfree (sp) end # CF_LISTXY -- Print answers to STDOUT as x,y pairs. procedure cf_listxyd (cv, xvals, yvals, wts, nvalues) pointer cv # Pointer to curfit structure int nvalues # Number of data values double xvals[nvalues] # Array of x data values double yvals[nvalues] # Array of y data values double wts[nvalues] # Array of weights int i double dcveval() begin do i = 1, nvalues { call printf ("\t%14.7e \t%14.7e \t%14.7e \t%14.7e\n") call pargd (xvals[i]) call pargd (dcveval (cv, xvals[i])) call pargd (yvals[i]) call pargd (wts[i]) } end # IM_PROJECTION -- Given an image section of arbitrary dimension, compute # the projection along a single axis by taking the average over the other # axes. We do not know about bad pixels. procedure im_projectiond (im, x, y, w, npix, weighting, axis) pointer im # Pointer to image header structure double x[npix] # Index of projection vector double y[npix] # Receives the projection vector double w[npix] # Receives the weight vector int weighting # Weighting of the individual points int npix # Length of projection vector int axis # The axis to be projected to (x=1) int i, lastv long v[IM_MAXDIM], nsum, totpix pointer pix double asumd() pointer imgnld() errchk imgnld begin if (im == NULL) call error (1, "Image projection operator called with null im") if (axis < 1 || axis > IM_NDIM(im)) call error (2, "Attempt to take projection over nonexistent axis") # Set the y projection vector call aclrd (y, npix) call amovkl (long(1), v, IM_MAXDIM) switch (axis) { case 1: # Since the image is read line by line, it is easy to compute the # projection along the x-axis (axis 1). We merely sum all of the # image lines. while (imgnld (im, pix, v) != EOF) call aaddd (Memd[pix], y, y, npix) default: # Projecting along any other axis when reading the image line # by line is a bit difficult to understand. Basically, the # element 'axis' of the V vector (position of the line in the # image) gives us the index into the appropriate element of # y. When computing the projection over multiple dimensions, # the same output element will be referenced repeatedly. All # of the elmenents of the input line are summed and added into # this output element. for (lastv=v[axis]; imgnld (im, pix, v) != EOF; lastv=v[axis]) { i = lastv if (i <= npix) y[i] = y[i] + asumd (Memd[pix], IM_LEN(im,1)) } } # Now compute the number of pixels contributing to each element # of the output vector. This is the number of pixels in the image # divided by the length of the projection. totpix = 1 do i = 1, IM_NDIM(im) if (i == axis) totpix = totpix * min (npix, IM_LEN(im,i)) else totpix = totpix * IM_LEN(im,i) nsum = totpix / min (npix, IM_LEN(im,axis)) # Compute the average by dividing by the number if pixels summed at # each point. call adivkd (y, double (nsum), y, npix) # Set the x and weight vectors do i = 1, npix { x[i] = i switch (weighting) { case CF_STATISTICAL: if (y[i] > 0.0) w[i] = 1.0 / y[i] else if (y[i] < 0.0) w[i] = abs (1.0 / y[i]) else w[i] = 1.0 case CF_UNIFORM: w[i] = 1. default: w[i] = 1. } } end ����������������������������������������������mscred-5.05-2018.07.09/src/curfit/mkpkg�������������������������������������������������������������0000664�0000000�0000000�00000000741�13321663143�0017107�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Make the modified curfit task from UTILITIES $checkout libmscred.a mscbin$ $update libmscred.a $checkin libmscred.a .mscbin$ $exit generic: $set GEN = "$$generic -k" $ifolder (curfit.x, curfit.gx) $(GEN) curfit.gx -o curfit.x $endif ; libmscred.a: $ifeq (USE_GENERIC, yes) $call generic $endif curfit.x curfit.h \ t_curfit.x \ ; �������������������������������mscred-5.05-2018.07.09/src/curfit/msccurfit.par�����������������������������������������������������0000664�0000000�0000000�00000001175�13321663143�0020560�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,f,a,,,,input list of files or images output,f,a,,,,output results file function,s,h,legendre,,,type of function to fit weighting,s,h,uniform,,,'Weighting (uniform,user,statistical,instrumental)' order,i,h,4,,,order of the fit interactive,b,h,yes,,,interactively tweak fit parameters? axis,i,h,1,,,projection axis if input is an image listdata,b,h,no,,,two column output list? verbose,b,h,no,,,lengthy output format? calctype,s,h,"double","|real|double|",,Calculation datatype power,b,h,no,,,convert coeffecients to power series? device,s,h,"stdgraph",,,name of interactive plotting device cursor,*gcur,h,"",,,Graphics cursor input ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/curfit/t_curfit.x��������������������������������������������������������0000664�0000000�0000000�00000024254�13321663143�0020070�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include define VERBOSE_OUTPUT 1 define LIST_OUTPUT 2 define DEFAULT_OUTPUT 3 define IMAGE_OP 1 define LIST_OP 2 define CF_UNIFORM 1 define CF_USER 2 define CF_STATISTICAL 3 define CF_INSTRUMENTAL 4 define NADD 20 # Number of points that can be added by ICFIT # T_CURFIT -- cl interface to the curfit package. Task CURFIT provides # four fitting options: legendre, chebyshev, cubic spline or linear spline. # The output can be printed in default, verbose or tabular formats. The # user can also choose to interactively fit the curve. procedure t_curfit () pointer x, y, w, gt, fcn, fname, flist, dev, str, sp, ic bool listdata, verbose, power, redir int fd, ofmt, interactive, datatype int axis, nvalues, nmax, weighting pointer gt_init() bool clgetb() int imtopen(), clgeti(), cf_operand(), cf_rimage(), cf_rlist() int imtgetim(), clgwrd() int fstati() begin # Allocate space for string buffers call smark (sp) call salloc (fcn, SZ_FNAME, TY_CHAR) call salloc (fname, SZ_FNAME, TY_CHAR) call salloc (flist, SZ_LINE, TY_CHAR) call salloc (dev, SZ_FNAME, TY_CHAR) call salloc (str, SZ_FNAME, TY_CHAR) # First get cl parameters. Check to see if input has been redirected. redir = false if (fstati (STDIN, F_REDIR) == YES) { redir = true call strcpy ("STDIN", Memc[fname], SZ_FNAME) } else { call clgstr ("input", Memc[flist], SZ_LINE) fd = imtopen (Memc[flist]) } listdata = clgetb ("listdata") verbose = clgetb ("verbose") ofmt = DEFAULT_OUTPUT if (listdata) ofmt = LIST_OUTPUT else if (verbose) ofmt = VERBOSE_OUTPUT # Determine the calculation datatype. switch (clgwrd ("calctype", Memc[dev], SZ_FNAME, "|real|double|")) { case 1: datatype = TY_REAL case 2: datatype = TY_DOUBLE } if (clgetb ("interactive")) { interactive = YES call clgstr ("device", Memc[dev], SZ_FNAME) } else { interactive = ALWAYSNO call strcpy ("", Memc[dev], SZ_FNAME) } power = clgetb ("power") call ic_open (ic) call clgstr ("function", Memc[fcn], SZ_FNAME) call ic_pstr (ic, "function", Memc[fcn]) call ic_puti (ic, "order", clgeti ("order")) weighting = clgwrd ("weighting", Memc[str], SZ_FNAME, "|uniform|user|statistical|instrumental|") gt = gt_init () repeat { if (!redir) { if (imtgetim (fd, Memc[fname], SZ_FNAME) == EOF) break } if (cf_operand (Memc[fname]) == IMAGE_OP) { axis = clgeti ("axis") nvalues = cf_rimage (Memc[fname], axis, x, y, w, weighting, datatype) call gt_sets (gt, GTTYPE, "line") } else { nvalues = cf_rlist (Memc[fname], x, y, w, weighting, datatype) call gt_sets (gt, GTTYPE, "mark") # For list input only, order the input array. The # rg_ranges package requires an x ordered input array, or else # points will be excluded from the fit. This test can be # removed when/if the ordering restriction is removed from # rg_xranges. Sorted data is required even when no sampling # is done, as in the default case of sample=*. (ShJ 6-24-88) switch (datatype) { case TY_REAL: call xt_sort3 (Memr[x], Memr[y], Memr[w], nvalues) case TY_DOUBLE: call xt_sort3d (Memd[x], Memd[y], Memd[w], nvalues) } } # Allow for adding points. nmax = nvalues + NADD call realloc (x, nmax, datatype) call realloc (y, nmax, datatype) call realloc (w, nmax, datatype) call gt_sets (gt, GTTITLE, Memc[fname]) switch (datatype) { case TY_REAL: call cf_fitr (ic, gt, Memr[x], Memr[y], Memr[w], nvalues, nmax, Memc[dev], interactive, ofmt, power) case TY_DOUBLE: call cf_fitd (ic, gt, Memd[x], Memd[y], Memd[w], nvalues, nmax, Memc[dev], interactive, ofmt, power) } call flush (STDOUT) call mfree (x, datatype) call mfree (y, datatype) call mfree (w, datatype) if (redir) break } switch (datatype) { case TY_REAL: call ic_closer (ic) case TY_DOUBLE: call ic_closed (ic) } if (!redir) call imtclose (fd) call gt_free (gt) call sfree (sp) end define IMAGE_OP 1 define LIST_OP 2 # CF_OPERAND -- Determine whether the operand argument is an image section # or a list. If the string is STDIN, it is a list; if a subscript is # present, it is an image; otherwise we must test whether or not it is a # binary file and make the decision based on that. int procedure cf_operand (operand) char operand[ARB] # Input list int first, last, ip int access(), strncmp() begin # Strip off any whitespace at the beginning or end of the string. for (ip=1; IS_WHITE(operand[ip]); ip=ip+1) ; first = ip for (last=ip; operand[ip] != EOS; ip=ip+1) if (!IS_WHITE(operand[ip])) last = ip if (first == last) return (LIST_OP) else if (strncmp (operand[first], "STDIN", 5) == 0) return (LIST_OP) else if (operand[last] == ']') return (IMAGE_OP) else if (access (operand, 0, TEXT_FILE) == YES) return (LIST_OP) else return (IMAGE_OP) end define SZ_BUF 1000 # CF_RLIST -- Read a list of two dimensional data pairs into two type # datatype arrays in memory. Return pointers to the arrays and a count of the # number of pixels. int procedure cf_rlist (fname, x, y, w, weighting, datatype) char fname[ARB] # Name of list file pointer x # Pointer to x data values (returned) pointer y # Pointer to y data values (returned) pointer w # Pointer to weight values (returned) int weighting # Type of weighting int datatype # Datatype of x and Y values int buflen, n, fd, ncols, lineno pointer sp, lbuf, ip double cf_divzd() int getline(), nscan(), open() real cf_divzr() extern cf_divzr(), cf_divzd() errchk open, sscan, getline, malloc begin call smark (sp) call salloc (lbuf, SZ_LINE, TY_CHAR) fd = open (fname, READ_ONLY, TEXT_FILE) n = 0 ncols = 0 lineno = 0 while (getline (fd, Memc[lbuf]) != EOF) { # Skip comment lines and blank lines. lineno = lineno + 1 if (Memc[lbuf] == '#') next for (ip=lbuf; IS_WHITE(Memc[ip]); ip=ip+1) ; if (Memc[ip] == '\n' || Memc[ip] == EOS) next if (n == 0) { buflen = SZ_BUF iferr { call malloc (x, buflen, datatype) call malloc (y, buflen, datatype) call malloc (w, buflen, datatype) } then call erract (EA_FATAL) } else if (n + 1 > buflen) { buflen = buflen + SZ_BUF call realloc (x, buflen, datatype) call realloc (y, buflen, datatype) call realloc (w, buflen, datatype) } # Decode the points to be plotted. call sscan (Memc[ip]) switch (datatype) { case TY_REAL: call gargr (Memr[x+n]) call gargr (Memr[y+n]) call gargr (Memr[w+n]) case TY_DOUBLE: call gargd (Memd[x+n]) call gargd (Memd[y+n]) call gargd (Memd[w+n]) } # The first line determines whether we have an x,y list or a # y-list. It is an error if only one value can be decoded when # processing a two column list. if (ncols == 0 && nscan() > 0) ncols = nscan() switch (nscan()) { case 0: call eprintf ("no args; %s, line %d: %s\n") call pargstr (fname) call pargi (lineno) call pargstr (Memc[lbuf]) next case 1: if (ncols >= 2) { call eprintf ("only 1 arg; %s, line %d: %s\n") call pargstr (fname) call pargi (lineno) call pargstr (Memc[lbuf]) next } else { switch (datatype) { case TY_REAL: Memr[y+n] = Memr[x+n] Memr[x+n] = n + 1.0 Memr[w+n] = 1.0 case TY_DOUBLE: Memd[y+n] = Memd[x+n] Memd[x+n] = n + 1.0 Memd[w+n] = 1.0d0 } } case 2: if (ncols == 3) { call eprintf ("only 2 args; %s, line %d: %s\n") call pargstr (fname) call pargi (lineno) call pargstr (Memc[lbuf]) next } else { switch (datatype) { case TY_REAL: Memr[w+n] = 1.0 case TY_DOUBLE: Memd[w+n] = 1.0d0 } } } n = n + 1 } call realloc (x, n, datatype) call realloc (y, n, datatype) call realloc (w, n, datatype) switch (weighting) { case CF_UNIFORM: if (datatype == TY_REAL) call amovkr (1.0, Memr[w], n) else call amovkd (1.0d0, Memd[w], n) case CF_USER: ; case CF_STATISTICAL: if (datatype == TY_REAL) { call aabsr (Memr[y], Memr[w], n) call arczr (1.0, Memr[w], Memr[w], n, cf_divzr (1.0)) } else { call aabsd (Memd[y], Memd[w], n) call arczd (1.0d0, Memd[w], Memd[w], n, cf_divzd (1.0d0)) } case CF_INSTRUMENTAL: if (datatype == TY_REAL) { call apowkr (Memr[w], 2, Memr[w], n) call arczr (1.0, Memr[w], Memr[w], n, cf_divzr (0.0)) } else { call apowkd (Memd[w], 2, Memd[w], n) call arczd (1.0d0, Memd[w], Memd[w], n, cf_divzd (0.0d0)) } } call close (fd) call sfree (sp) return (n) end # CF_RIMAGE -- Read an image section and compute the projection about # one dimension, producing x and y vectors as output. int procedure cf_rimage (imsect, axis, x, y, w, weighting, datatype) char imsect[ARB] # Name of image section pointer x # Pointer to x data values pointer y # Pointer to y data values pointer w # Pointer to weight values int weighting # Type of weighting int axis # Axis about which projection is taken int datatype # Datatype of data values int npix pointer im pointer immap() errchk immap, im_projectionr, im_projectiond, malloc begin im = immap (imsect, READ_ONLY, 0) if (axis < 1 || axis > IM_NDIM(im)) call error (2, "Attempt to take projection over nonexistent axis") npix = IM_LEN(im,axis) call malloc (x, npix, datatype) call malloc (y, npix, datatype) call malloc (w, npix, datatype) switch (datatype) { case TY_REAL: call im_projectionr (im, Memr[x], Memr[y], Memr[w], npix, weighting, axis) case TY_DOUBLE: call im_projectiond (im, Memd[x], Memd[y], Memd[w], npix, weighting, axis) } call imunmap (im) return (npix) end # CF_DIVZR -- Procedure to return a real number in case of a divide by zero. real procedure cf_divzr (a) real a # real number begin return (a) end # CF_DIVZD -- Procedure to return a double number in case of a divide by zero. double procedure cf_divzd (a) double a # double precision number number begin return (a) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/dispsnap.cl��������������������������������������������������������������0000664�0000000�0000000�00000003763�13321663143�0016727�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# DISPSNAP -- Display and snap and image using MSCDISPLAY. # This task requires an image display server to be running. procedure dispsnap (input, output, format) file input {prompt="Input mosaic file or single image"} file output {prompt="Output rootname"} string format {prompt="Output format"} file coords = "" {prompt="Coordinate list (optional)"} string radii = "40" {prompt="Radii of coordinate circles"} string size = "imt1024" {prompt="Display buffer size"} string outbands = "" {prompt="Export outbands function"} file logfile = "" {prompt="Logfile"} begin file in, root, out, logf, temp string fmt in = input root = output fmt = format out = root // "." // fmt if (access (out)) error (1, "DISPSNAP: Output already exists ("//out//")") set stdimage = (size) logf = logfile if (logf == "") logf = "dev$null" printf ("DISPSNAP: %s -> %s\n", in, out, >> logf) mscdisplay (in, 1, mimpars="", check=no, onepass=no, bpmask="BPM", bpdisplay="none", bpcolors="red", overlay="", ocolors="+203", erase=yes, border_erase=no, select_frame=yes, repeat=no, fill=no, zscale=yes, contrast=0.25, zrange=yes, zmask="", zcombine="auto", nsample=1000, order=0, z1=0., z2=1000., ztrans="linear", lutfile="", extname="", xgap=72, ygap=36, process=no, >> logf) if (coords != "") if (access (coords)) msctvmark (coords, 1, wcs="world", mark="circle", radii=radii, lengths="0", font="raster", color=204, label=no, nxoffset=0, nyoffset=0, pointsize=3, txsize=1) temp = mktemp ("tmp") tvmark (1, "", logfile="", autolog=no, outimage=temp, deletions="", commands="", mark="circle", radii="20", lengths="0", font="raster", color=205, label=no, number=no, nxoffset=0, nyoffset=0, pointsize=3, txsize=1, tolerance=1.5, interactive=no) export (temp, root, fmt, header="yes", outtype="", outbands=outbands, interleave=0, bswap="no", verbose=no, >& "dev$null") printf ("\n", out, >> logf) imdelete (temp, verify-) end mscred-5.05-2018.07.09/src/ffpupilcor.cl000066400000000000000000000177701332166314300172620ustar00rootroot00000000000000# FFPUPILCOR -- Correct broad band flat field for the pupil image in mosaic # data. This uses a narrow band flat field as the template for the pupil # ghost image. procedure ffpupilcor (input, output, template) file input {prompt="Input mosaic exposure"} file output {prompt="Output mosaic exposure"} file template {prompt="Template mosaic exposure"} string extname = "[2367]" {prompt="Extensions for fit"} file statsec = "mscred$noao/kpno/4meter/ffpupilcor.dat" {prompt="List of image sections"} int blkavg = 8 {prompt="Block average factor"} real radius = INDEF {prompt="Correction circle radius (pixels)"} real xcenter = 0. {prompt="Center of correction circle (pixels)"} real ycenter = 0. {prompt="Center of correction circle (pixels)"} bool mscexam = no {prompt="Examine corrections with MSCEXAM?"} real scale = 1. {prompt="Scale (0=quit, -1=abort)", mode="q"} struct *fd1, *fd2, *fd3 begin file in, out, tmplt file tmpout, im1, im2, im3, im4, im5 file alllist, inlist, temp, inblk, outblk, tblk int nextn real mean, xc, yc, r, s, sbest, x, y struct str string junk cache imextensions # Define temporary files and images. alllist = mktemp ("tmp$iraf") inlist = mktemp ("tmp$iraf") temp = mktemp ("tmp$iraf") # Get query parameters. in = input out = output tmplt = template # Check images. if (!imaccess (in//"[1]")) error (1, "Can't access input image ("//in//")") if (!imaccess (tmplt//"[1]")) error (1, "Can't access template image ("//tmplt//")") if (imaccess (out//"[1]")) error (1, "Output image already exists ("//out//")") # Check statsec if (!access (statsec)) error (1, "Can't access statistics file ("//statsec//")") # Expand extensions. imextensions (in, output="file", index="1-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > alllist) imextensions (in, output="file", index="1-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) imextensions (tmplt, output="file", index="1-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) nextn = imextensions.nimages # Block average to make things go faster. if (blkavg > 1) { printf ("Block averaging %s and %s by a factor of %d ...\n", in, tmplt, blkavg) inblk = mktemp ("tmp") tblk = mktemp ("tmp") outblk = mktemp ("tmp") imcopy (in//"[0]", inblk, verbose-) imcopy (tmplt//"[0]", tblk, verbose-) fd1 = inlist while (fscan (fd1, im1, im2) != EOF) { blkavg (im1, inblk//"[append,inherit]", blkavg, blkavg, option = "average") blkavg (im2, tblk//"[append,inherit]", blkavg, blkavg, option = "average") } fd1 = "" } else { inblk = in tblk = tmplt outblk = out } # Expand block average extensions. rename (inlist, temp, field="all") imextensions (inblk, output="file", index="1-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) rename (inlist, temp, field="all") imextensions (tblk, output="file", index="1-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) # Compute replacement circle and normalization factor. printf ("Computing normalizations ...\n") fd1 = inlist fd2 = statsec fd3 = alllist i = fscan (fd1, im1, im2, im3, im4) while (fscan (fd3, im5) != EOF) { if (fscan (fd2, str) == EOF) { delete (alllist, verify-) delete (inlist, verify-) delete (temp, verify-, >> "dev$null") if (inblk != in) imdelete (inblk, verify-) if (tblk != tmplt) imdelete (tblk, verify-) error (1, "Missing statistic section for " // im1) } if (im5 != im1) next # Compute replacement circle in block averaged image. if (radius == INDEF) { xc = INDEF yc = INDEF r = INDEF } else { printf ("0 0\n") | mscctran ("STDIN", "STDOUT", im3, "astrometry", "physical", columns="1 2", units="", formats="", min_sig=9, verbose-) | scan (x, y) x = x + xcenter y = y + ycenter printf ("%g %g\n", x, y) | mscctran ("STDIN", "STDOUT", im3, "physical", "logical", columns="1 2", units="", formats="", min_sig=9, verbose-) | scan (xc, yc) x = x + radius + blkavg - 1 printf ("%g %g\n", x, y) | mscctran ("STDIN", "STDOUT", im3, "physical", "logical", columns="1 2", units="", formats="", min_sig=9, verbose-) | scan (x, y) r = (x-xc)**2 + (y-yc)**2 } # Compute normalization. imstatistics (im2//str, fields="mean", lower=INDEF, upper=INDEF, binwidth=0.1, format=no) | scan (mean) printf ("%s %s %s %s %.2f %.2f %.2f %g\n", im1, im2, im3, im4, xc, yc, r, mean, >> temp) i = fscan (fd1, im1, im2, im3, im4) } fd1 = ""; fd2 = ""; fd3 = "" delete (inlist, verify-) rename (temp, inlist, field="all") # Scale loop. printf ("Displaying %s ...\n", in) mscdisplay (inblk, 1, extname=extname, >> "dev$null") sbest = INDEF for (s=scale; s > 0.; s=scale) { printf ("Scaling %s by %.3g and dividing into %s ...\n", tmplt, s, in) imdelete (outblk, verify-, >& "dev$null") imcopy (inblk//"[0]", outblk, verbose-) fd1 = inlist while (fscan (fd1, im1, im2, im3, im4, xc, yc, r, mean) != EOF) { if (radius == INDEF) { printf ("a/((b/%g-1)*%g+1)\n", mean, s) | scan (str) } else { printf ("((I-%g)**2+(J-%g)**2<%g)?a/((b/%g-1)*%g+1):a\n", xc, yc, r, mean, s) | scan (str) } imexpr (str, outblk//"[append,inherit]", im3, im4, dims="auto", intype="auto", outtype="auto", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") } fd1 = "" printf ("Displaying corrected version of %s ...\n", in) mscdisplay (outblk, 2, extname=extname, >> "dev$null") if (mscexam) { printf ("Entering MSCEXAM (quit with 'q') ...\n") mscexamine } sbest = s } if (inblk != in) imdelete (inblk, verify-) if (tblk != tmplt) imdelete (tblk, verify-) if (s == -1) { sbest = INDEF if (outblk == out) imdelete (outblk, verify-) } # Create output corrected image. if (sbest!=INDEF && (outblk!=out || imextensions.nimages!=nextn)) { printf ("Creating corrected output image %s with scale %.3g ...\n", out, sbest) imdelete (outblk, verify-) imcopy (in//"[0]", out, verbose-) fd1 = inlist fd2 = alllist i = fscan (fd1, im1, im2, im3, im4, xc, yc, r, mean) while (fscan (fd2, im5) != EOF) { if (im5 != im1) imcopy (im5, out//"[append,inherit]", verbose-) else { if (radius == INDEF) { printf ("a/((b/%g-1)*%g+1)\n", mean, sbest) | scan (str) } else { # Compute replacement circle in full image. printf ("0 0\n") | mscctran ("STDIN", "STDOUT", im1, "astrometry", "physical", columns="1 2", units="", formats="", min_sig=9, verbose-) | scan (x, y) x = x + xcenter y = y + ycenter printf ("%g %g\n", x, y) | mscctran ("STDIN", "STDOUT", im1, "physical", "logical", columns="1 2", units="", formats="", min_sig=9, verbose-) | scan (xc, yc) x = x + radius + blkavg - 1 printf ("%g %g\n", x, y) | mscctran ("STDIN", "STDOUT", im1, "physical", "logical", columns="1 2", units="", formats="", min_sig=9, verbose-) | scan (x, y) r = (x-xc)**2 + (y-yc)**2 printf ("((I-%g)**2+(J-%g)**2<%g)?a/((b/%g-1)*%g+1):a\n", xc, yc, r, mean, sbest) | scan (str) } imexpr (str, out//"[append,inherit]", im1, im2, dims="auto", intype="auto", outtype="auto", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") i = fscan (fd1, im1, im2, im3, im4, xc, yc, r, mean) } } fd1 = ""; fd2 = "" } delete (alllist, verify-) delete (inlist, verify-) end mscred-5.05-2018.07.09/src/fitscopy.par000066400000000000000000000010631332166314300171210ustar00rootroot00000000000000input,s,a,,,,"Input list of FITS files" output,s,a,,,,"Output list of FITS files" listonly,b,h,no,,,"List only?" shortlist,b,h,yes,,,"Short listing?" longlist,b,h,no,,,"Long listing?" extn,s,h,"fits",,,"Extension for output disk filenames" offset,i,h,0,,,"Offset for numbering of output disk filenames" original,b,h,no,,,"Restore original filename?" intape,b,h,no,,,"Input files on tape?" outtape,b,h,no,,,"Output files to tape?" tapefiles,s,h,"1-",,,"List of tape file numbers" newtape,b,a,,,,"New tape?" blocking_factor,i,h,10,1,10,"FITS tape blocking factor" mscred-5.05-2018.07.09/src/getcatalog.par000066400000000000000000000006741332166314300174020ustar00rootroot00000000000000images,s,a,,,,List of images with common tangent point ra,r,a,,0.,24.,Field RA (hours) dec,r,a,,-90.,90,Field DEC (degrees) radius,r,a,,0.,,Field radius (arcmin) magmin,r,h,0.,,,Minimum magnitude magmax,r,h,25.,,,Maximum magnitude rmin,r,h,0.,0.,,Minimum radius (arcmin) catalog,s,h,"usnob1@noao",,,Catalog output,s,h,"STDOUT",,,Output file radecsys,s,h,"FK5","|FK5|",,RA/DEC system for output equinox,r,h,2000.,2000.,2000.,Equinox for output mscred-5.05-2018.07.09/src/imstat.h000066400000000000000000000022401332166314300162250ustar00rootroot00000000000000# Header file for the IMSTATISTICS task. define LEN_IMSTAT 20 define IS_SUMX Memd[P2D($1)] define IS_SUMX2 Memd[P2D($1+2)] define IS_SUMX3 Memd[P2D($1+4)] define IS_SUMX4 Memd[P2D($1+6)] define IS_LO Memr[P2R($1+8)] define IS_HI Memr[P2R($1+9)] define IS_MIN Memr[P2R($1+10)] define IS_MAX Memr[P2R($1+11)] define IS_MEAN Memr[P2R($1+12)] define IS_MEDIAN Memr[P2R($1+13)] define IS_MODE Memr[P2R($1+14)] define IS_STDDEV Memr[P2R($1+15)] define IS_SKEW Memr[P2R($1+16)] define IS_KURTOSIS Memr[P2R($1+17)] define IS_NPIX Memi[$1+18] define IS_FIELDS "|image|npix|min|max|mean|midpt|mode|stddev|skew|kurtosis|" define NFIELDS 10 define IS_KIMAGE "IMAGE" define IS_KNPIX "NPIX" define IS_KMIN "MIN" define IS_KMAX "MAX" define IS_KMEAN "MEAN" define IS_KMEDIAN "MIDPT" define IS_KMODE "MODE" define IS_KSTDDEV "STDDEV" define IS_KSKEW "SKEW" define IS_KKURTOSIS "KURTOSIS" define IS_FIMAGE 1 define IS_FNPIX 2 define IS_FMIN 3 define IS_FMAX 4 define IS_FMEAN 5 define IS_FMEDIAN 6 define IS_FMODE 7 define IS_FSTDDEV 8 define IS_FSKEW 9 define IS_FKURTOSIS 10 define IS_FCOLUMN "%10d" define IS_FINTEGER "%10d" define IS_FREAL "%10.4g" define IS_FSTRING "%20s" mscred-5.05-2018.07.09/src/imsurfit/000077500000000000000000000000001332166314300164175ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/imsurfit/imsurfit.h000066400000000000000000000016051332166314300204340ustar00rootroot00000000000000# Header file for IMSURFIT define LEN_IMSFSTRUCT 20 # surface parameters define SURFACE_TYPE Memi[$1] define XORDER Memi[$1+1] define YORDER Memi[$1+2] define CROSS_TERMS Memi[$1+3] define TYPE_OUTPUT Memi[$1+4] # median processing parameters define MEDIAN Memi[$1+5] define XMEDIAN Memi[$1+6] define YMEDIAN Memi[$1+7] define MEDIAN_PERCENT Memr[P2R($1+8)] # pixel rejection parameters define REJECT Memi[$1+9] define NGROW Memi[$1+10] define NITER Memi[$1+11] define LOWER Memr[P2R($1+12)] define UPPER Memr[P2R($1+13)] define DIV_MIN Memr[P2R($1+14)] # definitions for type_output define FIT 1 define CLEAN 2 define RESID 3 define RESP 4 # definitions for good regions define REGIONS "|all|columns|rows|border|sections|circle|invcircle|mask|" define ALL 1 define COLUMNS 2 define ROWS 3 define BORDER 4 define SECTIONS 5 define CIRCLE 6 define INVCIRCLE 7 define MASK 8 mscred-5.05-2018.07.09/src/imsurfit/imsurfit.par000066400000000000000000000020461332166314300207670ustar00rootroot00000000000000# IMSURFIT input,f,a,,,,Input images to be fit output,f,a,,,,Output images xorder,i,a,2,1,,Order of function in x yorder,i,a,2,1,,Order of function in y type_output,s,h,'fit',,,'Type of output (fit,residual,response,clean)' function,s,h,'leg',,,'Function to be fit (legendre,chebyshev,spline3)' cross_terms,b,h,y,,,Include cross-terms for polynomials? xmedian,i,h,1,1,,X length of median box ymedian,i,h,1,1,,Y length of median box median_percent,r,h,50.,,,Minimum fraction of pixels in median box lower,r,h,0.0,0.0,,Lower limit for residuals upper,r,h,0.0,0.0,,Upper limit for residuals ngrow,i,h,0,0,,Radius of region growing circle niter,i,h,0,0,,Maximum number of rejection cycles regions,s,h,'all',,, 'Good regions (all,rows,columns,border,sections,circle,invcircle,mask)' rows,s,h,'*',,,Rows to be fit columns,s,h,'*',,,Columns to be fit border,s,h,'50',,,Width of border to be fit sections,s,h,,,,File name for sections list circle,s,h,,,,Circle specifications mask,s,h,"BPM",,,Mask div_min,r,h,INDEF,,,Division minimum for response output mode,s,h,'ql' mscred-5.05-2018.07.09/src/imsurfit/imsurfit.x000066400000000000000000000753351332166314300204670ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include "imsurfit.h" # IMSURFIT -- Procedure to fit a surface to a single image including # optional pixel rejection. procedure imsurfit (imin, imout, imfit, gl) pointer imin # pointer to the input image pointer imout # pointer to the output image pointer imfit # pointer to the imsurfit parameters pointer gl # pointer to the good regions list pointer sf, rl errchk isfree, prl_free errchk all_pixels, good_pixels, good_median, all_medians, do_reject errchk set_outimage begin sf = NULL rl = NULL # Accumulate and solve the surface. if (gl == NULL) { if (MEDIAN(imfit) == NO) call all_pixels (imin, imfit, sf) else call all_medians (imin, imfit, sf) } else { if (MEDIAN(imfit) == NO) call good_pixels (imin, imfit, gl, sf) else call good_medians (imin, imfit, gl, sf) } # Perform the reject cycle. if (REJECT(imfit) == YES || TYPE_OUTPUT(imfit) == CLEAN) call do_reject (imin, imfit, gl, sf, rl) # Evaluate surface for appropriate output type. call set_outimage (imin, imout, imfit, sf, rl) # Cleanup. call prl_free (rl) call isfree (sf) rl = NULL sf = NULL end # ALL_PIXELS -- Accumulate surface when there are no bad regions # and no median processing. procedure all_pixels (im, imfit, sf) pointer im # pointer to the input image pointer imfit # pointer to the imsurfit structure pointer sf # pointer to the surface descriptor int i, lp, ncols, nlines, ier long v[IM_MAXDIM] pointer sp, cols, lines, wgt, lbuf int imgnlr() errchk smark, salloc, sfree, imgnlr errchk isinit, islfit, islrefit, issolve begin ncols = IM_LEN(im, 1) nlines = IM_LEN(im,2) # Initialize the surface fit. call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), CROSS_TERMS(imfit), ncols, nlines) # Allocate working space for fitting. call smark (sp) call salloc (cols, ncols, TY_INT) call salloc (lines, nlines, TY_INT) call salloc (wgt, ncols, TY_REAL) # Initialize the x and weight buffers. do i = 1, ncols Memi[cols - 1 + i] = i call amovkr (1.0, Memr[wgt], ncols) # Loop over image lines. lp = 0 call amovkl (long (1), v, IM_MAXDIM) do i = 1, nlines { # Read in the image line. if (imgnlr (im, lbuf, v) == EOF) call error (0, "Error reading image") # Fit each image line. if (i == 1) call islfit (sf, Memi[cols], i, Memr[lbuf], Memr[wgt], ncols, SF_USER, ier) else call islrefit (sf, Memi[cols], i, Memr[lbuf], Memr[wgt]) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call eprintf ("Warning: Too few columns to fit line: %d\n") call pargi (i) case SINGULAR: call eprintf ("Warning: Solution singular for line: %d\n") call pargi (i) Memi[lines + lp] = i lp = lp + 1 default: Memi[lines + lp] = i lp = lp + 1 } } # Solve the surface. call issolve (sf, Memi[lines], lp, ier) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call error (0, "ALL_PIXELS: Cannot fit surface.") case SINGULAR: call eprintf ("Warning: Solution singular for surface.\n") default: # everything OK } # Free space. call sfree (sp) end # GOOD_PIXELS -- Get surface when good regions are defined and median # processing is off. procedure good_pixels (im, imfit, gl, sf) pointer im # input image pointer imfit # pointer to imsurfit header structure pointer gl # pointer to good region list pointer sf # pointer to the surface descriptor int lp, lineno, prevlineno, ncols, nlines, npts, nranges, ier, ijunk int max_nranges pointer sp, colsfit, lines, buf, fbuf, wgt, ranges int prl_nextlineno(), prl_eqlines(), prl_get_ranges(), is_expand_ranges() int is_choose_rangesr() pointer imgl2r() errchk smark, salloc, sfree, imgl2r errchk isinit, islfit, islrefit, issolve errchk prl_nextlineno, prl_eqlines, prl_get_ranges errchk is_choose_rangesr begin ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) max_nranges = ncols # Initialize the surface fit. call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), CROSS_TERMS(imfit), ncols, nlines) # Allocate temporary space for fitting. call smark (sp) call salloc (colsfit, ncols, TY_INT) call salloc (lines, nlines, TY_INT) call salloc (fbuf, ncols, TY_REAL) call salloc (wgt, ncols, TY_REAL) call salloc (ranges, 3 * max_nranges + 1, TY_INT) call amovkr (1., Memr[wgt], ncols) # Intialize counters and pointers. lp = 0 lineno = 0 prevlineno = 0 # Loop over those lines to be fit. while (prl_nextlineno (gl, lineno) != EOF) { # Read in the image line. buf = imgl2r (im, lineno) if (buf == EOF) call error (0, "GOOD_PIXELS: Error reading image.") # Get the ranges for that image line. nranges = prl_get_ranges (gl, lineno, Memi[ranges], max_nranges) if (nranges == 0) next # If ranges are not equal to previous line fit else refit. if (lp == 0 || prl_eqlines (gl, lineno, prevlineno) == NO) { npts = is_expand_ranges (Memi[ranges], Memi[colsfit], ncols) ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], npts, 1, ncols) call islfit (sf, Memi[colsfit], lineno, Memr[fbuf], Memr[wgt], npts, SF_USER, ier) } else { ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], npts, 1, ncols) call islrefit (sf, Memi[colsfit], lineno, Memr[fbuf], Memr[wgt]) } # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call eprintf ("Warning: Too few columns to fit line: %d\n") call pargi (lineno) case SINGULAR: call eprintf ("Warning: Solution singular for line: %d\n") call pargi (lineno) Memi[lines+lp] = lineno lp = lp + 1 default: Memi[lines+lp] = lineno lp = lp + 1 } prevlineno = lineno } # Solve the surface. call issolve (sf, Memi[lines], lp, ier) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call error (0, "GOOD_PIXELS: Cannot fit surface.") case SINGULAR: call eprintf ("Warning: Solution singular for surface.\n") default: # everything OK } # Free space. call sfree (sp) end # ALL_MEDIANS -- Get surface when median processor on and all # pixels good. procedure all_medians (im, imfit, sf) pointer im # input image pointer imfit # pointer to the imsurfit header structure pointer sf # pointer to the surface descriptor int i, lp, cp, op, lineno, x1, x2, y1, y2, ier int nimcols, nimlines, ncols, nlines, npts pointer sp, cols, lines, wgt, z, med, sbuf, lbuf, buf pointer imgs2r() real asokr() errchk salloc, sfree, smark errchk isinit, islfit, islrefit, issolve begin # Determine the number of lines and columns for a median processed # image. nimcols = IM_LEN(im,1) if (mod (int (IM_LEN(im,1)), XMEDIAN(imfit)) != 0) ncols = IM_LEN(im,1) / XMEDIAN(imfit) + 1 else ncols = IM_LEN(im,1) / XMEDIAN(imfit) nimlines = IM_LEN(im,2) if (mod (int (IM_LEN(im,2)), YMEDIAN(imfit)) != 0) nlines = IM_LEN(im,2) / YMEDIAN(imfit) + 1 else nlines = IM_LEN(im,2) / YMEDIAN(imfit) # Initialize the surface fitting. call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), CROSS_TERMS(imfit), ncols, nlines) # Allocate workin memory. call smark (sp) call salloc (cols, ncols, TY_INT) call salloc (wgt, ncols, TY_REAL) call salloc (lines, nlines, TY_INT) call salloc (z, ncols, TY_REAL) call salloc (med, XMEDIAN(imfit) * YMEDIAN(imfit), TY_REAL) # Intialize the x and weight arrays. do i = 1, ncols Memi[cols - 1 + i] = i call amovkr (1.0, Memr[wgt], ncols) # Loop over image sections. lp = 0 lineno = 1 for (y1 = 1; y1 <= nimlines; y1 = y1 + YMEDIAN(imfit)) { # Get image section. y2 = min (y1 + YMEDIAN(imfit) - 1, nimlines) sbuf = imgs2r (im, 1, nimcols, y1, y2) if (sbuf == EOF) call error (0, "Error reading image section.") # Loop over median boxes. cp = 0 for (x1 = 1; x1 <= nimcols; x1 = x1 + XMEDIAN(imfit)) { x2 = min (x1 + XMEDIAN(imfit) - 1, nimcols) npts = x2 - x1 + 1 lbuf = sbuf - 1 + x1 # Loop over lines in the median box. op = 0 buf = lbuf for (i = 1; i <= y2 - y1 + 1; i = i + 1) { call amovr (Memr[buf], Memr[med+op], npts) op = op + npts buf = buf + nimcols } # Calculate the median. Memr[z+cp] = asokr (Memr[med], op, (op + 1) / 2) cp = cp + 1 } # Fit each image "line". if (y1 == 1) call islfit (sf, Memi[cols], lineno, Memr[z], Memr[wgt], ncols, SF_USER, ier) else call islrefit (sf, Memi[cols], lineno, Memr[z], Memr[wgt]) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call eprintf ("Warning: Too few columns to fit line: %d\n") call pargi (lineno) case SINGULAR: call eprintf ("Warning: Solution singular for line: %d\n") call pargi (lineno) Memi[lines + lp] = lineno lp = lp + 1 default: Memi[lines + lp] = lineno lp = lp + 1 } lineno = lineno + 1 } # Solve th surface. call issolve (sf, Memi[lines], lp, ier) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call error (0, "ALL_MEDIANS: Cannot fit surface.") case SINGULAR: call eprintf ("Warning: Solution singular for surface.\n") default: # everything OK } # Free space call sfree (sp) end # GOOD_MEDIANS -- Procedure to fetch medians when the good regions # list is defined. procedure good_medians (im, imfit, gl, sf) pointer im # input image pointer imfit # pointer to surface descriptor structure pointer gl # pointer to good regions list pointer sf # pointer the surface descriptor int i, cp, lp, x1, x2, y1, y2, ier, ntemp int nimcols, nimlines, ncols, nlines, nranges, nbox, nxpts int lineno, current_line, lines_per_box, max_nranges pointer sp, colsfit, cols, lines, wgt, npts, lbuf, med, mbuf, z, ranges int prl_get_ranges(), prl_nextlineno(), is_expand_ranges() int is_choose_rangesr() pointer imgl2r() real asokr() errchk smark, salloc, sfree, imgl2r errchk isinit, islfit, issolve errchk prl_get_ranges, prl_nextlineno, is_choose_rangesr() begin # Determine the number of lines and columns for a median processed # image. nimcols = IM_LEN(im,1) if (mod (int (IM_LEN(im,1)), XMEDIAN(imfit)) != 0) ncols = IM_LEN(im,1) / XMEDIAN(imfit) + 1 else ncols = IM_LEN(im,1) / XMEDIAN(imfit) nimlines = IM_LEN(im,2) if (mod (int (IM_LEN(im,2)), YMEDIAN(imfit)) != 0) nlines = IM_LEN(im,2) / YMEDIAN(imfit) + 1 else nlines = IM_LEN(im,2) / YMEDIAN(imfit) nbox = XMEDIAN(imfit) * YMEDIAN(imfit) max_nranges = nimcols # Initialize the surface fitting. call isinit (sf, SURFACE_TYPE(imfit), XORDER(imfit), YORDER(imfit), CROSS_TERMS(imfit), ncols, nlines) # Allocate working memory. call smark (sp) call salloc (colsfit, nimcols, TY_INT) call salloc (cols, ncols, TY_INT) call salloc (npts, ncols, TY_INT) call salloc (lines, nlines, TY_INT) call salloc (wgt, ncols, TY_REAL) call salloc (med, nbox * ncols, TY_REAL) call salloc (z, ncols, TY_REAL) call salloc (ranges, 3 * max_nranges + 1, TY_INT) call amovkr (1., Memr[wgt], ncols) # Loop over median boxes in y. lp = 0 lineno = 0 for (y1 = 1; y1 <= nimlines; y1 = y1 + YMEDIAN(imfit)) { lineno = lineno + 1 current_line = y1 - 1 y2 = min (y1 + YMEDIAN(imfit) - 1, nimlines) # If lines not in range, next image section. lines_per_box = 0 while (prl_nextlineno (gl, current_line) != EOF) { if (current_line > y2) break lines_per_box = lines_per_box + 1 } if (lines_per_box < (YMEDIAN(imfit) * (MEDIAN_PERCENT(imfit)/100.))) next # Loop over the image lines. call aclri (Memi[npts], ncols) do i = y1, y2 { # Get image line, and check the good regions list. lbuf = imgl2r (im, i) nranges = prl_get_ranges (gl, i, Memi[ranges], max_nranges) if (nranges == 0) next nxpts = is_expand_ranges (Memi[ranges], Memi[colsfit], nimcols) # Loop over the median boxes in x. cp= 0 mbuf = med for (x1 = 1; x1 <= nimcols; x1 = x1 + XMEDIAN(imfit)) { x2 = min (x1 + XMEDIAN(imfit) - 1, nimcols) ntemp = is_choose_rangesr (Memi[colsfit], Memr[lbuf], Memr[mbuf+Memi[npts+cp]], nxpts, x1, x2) Memi[npts+cp] = Memi[npts+cp] + ntemp mbuf = mbuf + nbox cp = cp + 1 } } # Calculate the medians. nxpts = 0 mbuf = med do i = 1, ncols { if (Memi[npts+i-1] > ((MEDIAN_PERCENT(imfit) / 100.) * nbox)) { Memr[z+nxpts] = asokr (Memr[mbuf], Memi[npts+i-1], (Memi[npts+i-1] + 1) / 2) Memi[cols+nxpts] = i nxpts = nxpts + 1 } mbuf = mbuf + nbox } # Fit the line. call islfit (sf, Memi[cols], lineno, Memr[z], Memr[wgt], nxpts, SF_USER, ier) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call eprintf ("Warning: Too few columns to fit line: %d\n") call pargi (lineno) case SINGULAR: call eprintf ("Warning: Solution singular for line: %d\n") call pargi (lineno) Memi[lines+lp] = lineno lp = lp + 1 default: Memi[lines+lp] = lineno lp = lp + 1 } } # Solve the surface. call issolve (sf, Memi[lines], lp, ier) # Handle fitting errors. switch (ier) { case NO_DEG_FREEDOM: call error (0, "GOOD_MEDIANS: Cannot fit surface.") case SINGULAR: call eprintf ("Warning: Solution singular for surface.") default: # everyting OK } # Free space. call sfree (sp) end # SET_OUTIMAGE -- Procedure to write an output image of the desired type. procedure set_outimage (imin, imout, imfit, sf, rl) pointer imin # input image pointer imout # output image pointer imfit # pointer to the imsurfut header structure pointer sf # pointer to the surface descriptor pointer rl # pointer to the rejected pixel list regions list int i, k, ncols, nlines, max_nranges long u[IM_MAXDIM], v[IM_MAXDIM] real b1x, b2x, b1y, b2y, mean pointer sp, x, y, fit, inbuf, outbuf, ranges int impnlr(), imgnlr() real ims_divzero(), asumr() extern ims_divzero errchk malloc, mfree, imgnlr, impnlr begin ncols = IM_LEN(imin,1) nlines = IM_LEN(imin,2) max_nranges = ncols # Calculate transformation constants from real coordinates to # median coordinates if median processing specified. if (MEDIAN(imfit) == YES) { b1x = (1. + XMEDIAN(imfit)) / (2. * XMEDIAN(imfit)) b2x = (2. * ncols + XMEDIAN(imfit) - 1.) / (2. * XMEDIAN(imfit)) b1y = (1. + YMEDIAN(imfit)) / (2. * YMEDIAN(imfit)) b2y = (2. * nlines + YMEDIAN(imfit) - 1.) / (2. * YMEDIAN(imfit)) } # Allocate space for x coordinates, initialize to image coordinates # and transform to median coordinates. call smark (sp) call salloc (x, ncols, TY_REAL) call salloc (y, ncols, TY_REAL) call salloc (fit, ncols, TY_REAL) call salloc (ranges, 3 * max_nranges + 1, TY_INT) # Intialize the x array. do i = 1, ncols Memr[x - 1 + i] = i if (MEDIAN(imfit) == YES) call amapr (Memr[x], Memr[x], ncols, 1., real (ncols), b1x, b2x) # Compute mean for residual output. if (TYPE_OUTPUT(imfit) == RESID) { mean = 0. do i = 1, nlines { if (MEDIAN(imfit) == YES) { Memr[y] = real (i) call amapr (Memr[y], Memr[y], 1, 1., real (nlines), b1y, b2y) call amovkr (Memr[y], Memr[y+1], (ncols-1)) } else call amovkr (real (i), Memr[y], ncols) call isvector (sf, Memr[x], Memr[y], Memr[fit], ncols) mean = mean + asumr (Memr[fit], ncols) / ncols } mean = mean / nlines call imaddr (imout, "skymean", mean) } # loop over the images lines call amovkl (long (1), v, IM_MAXDIM) call amovkl (long (1), u, IM_MAXDIM) do i = 1, nlines { # Get input and output image buffers. if (TYPE_OUTPUT(imfit) != FIT) { if (imgnlr (imin, inbuf, v) == EOF) call error (0, "Error reading input image.") } if (impnlr (imout, outbuf, u) == EOF) call error (0, "Error writing output image.") # Intialize y coordinates to image coordinates, and # transform to median coordinates. if (MEDIAN(imfit) == YES) { Memr[y] = real (i) call amapr (Memr[y], Memr[y], 1, 1., real (nlines), b1y, b2y) call amovkr (Memr[y], Memr[y+1], (ncols-1)) } else call amovkr (real (i), Memr[y], ncols) # Write output image. switch (TYPE_OUTPUT(imfit)) { case FIT: call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) case CLEAN: call clean_line (Memr[x], Memr[y], Memr[inbuf], ncols, nlines, rl, sf, i, NGROW(imfit)) call amovr (Memr[inbuf], Memr[outbuf], ncols) case RESID: call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) call asubr (Memr[inbuf], Memr[outbuf], Memr[outbuf], ncols) call aaddkr (Memr[outbuf], mean, Memr[outbuf], ncols) case RESP: call isvector (sf, Memr[x], Memr[y], Memr[outbuf], ncols) if (IS_INDEF(DIV_MIN(imfit))) { iferr (call adivr (Memr[inbuf], Memr[outbuf], Memr[outbuf], ncols)) call advzr (Memr[inbuf], Memr[outbuf], Memr[outbuf], ncols, ims_divzero) } else { do k = 1, ncols { if (Memr[outbuf-1+k] < DIV_MIN(imfit)) Memr[outbuf-1+k] = 1. else Memr[outbuf-1+k] = Memr[inbuf-1+k] / Memr[outbuf-1+k] } } default: call error (0, "SET_OUTIMAGE: Unknown output type.") } } # Free space call sfree (sp) end # CLEAN_LINE -- Procedure to set weights of rejected points to zero procedure clean_line (x, y, z, ncols, nlines, rl, sf, line, ngrow) real x[ARB] # array of weights set to 1 real y # y value of line real z[ARB] # line of data int ncols # number of image columns int nlines # number of image lines pointer rl # pointer to reject pixel list pointer sf # surface fitting int line # line number int ngrow # radius for region growing int cp, j, k, nranges, dist, yreg_min, yreg_max, xreg_min, xreg_max pointer sp, branges real r2 int prl_get_ranges(), is_next_number() real iseval() begin call smark (sp) call salloc (branges, 3 * ncols + 1, TY_INT) r2 = ngrow ** 2 yreg_min = max (1, line - ngrow) yreg_max = min (nlines, line + ngrow) do j = yreg_min, yreg_max { nranges = prl_get_ranges (rl, j, Memi[branges], ncols) if (nranges == 0) next dist = int (sqrt (r2 - (j - line) ** 2)) cp = 0 while (is_next_number (Memi[branges], cp) != EOF) { xreg_min = max (1, cp - dist) xreg_max = min (ncols, cp + dist) do k = xreg_min, xreg_max z[k] = iseval (sf, x[k], y) cp = xreg_max } } call sfree (sp) end # DO_REJECT -- Procedure to detect rejected pixels in an image. procedure do_reject (im, imfit, gl, sf, rl) pointer im # pointer to in put image pointer imfit # pointer to image fitting structure pointer gl # pointer to good regions list pointer sf # pointer to surface descriptor pointer rl # pointer to rejected pixel list int niter, nrejects real sigma int detect_rejects() real get_sigma() errchk prl_init, detect_rejects, get_sigma, refit_surface begin # Initialize rejected pixel list. call prl_init (rl, int(IM_LEN(im,1)), int(IM_LEN(im,2))) # Do an iterative rejection cycle on the image. niter = 0 repeat { # Get the sigma of the fit. sigma = get_sigma (im, gl, sf, rl) # Detect rejected pixels. nrejects = detect_rejects (im, imfit, gl, sf, rl, sigma) # If no rejected pixels quit, else refit surface. if (nrejects == 0 || NITER(imfit) == 0) break call refit_surface (im, imfit, gl, sf, rl) niter = niter + 1 } until (niter == NITER(imfit)) end # REFIT_SURFACE -- Procedure tp refit the surface. procedure refit_surface (im, imfit, gl, sf, rl) pointer im # pointer to image pointer imfit # pointer to surface fitting structure pointer gl # pointer to good regions list pointer sf # pointer to surface descriptor pointer rl # pointer to rejected pixels list int i, ijunk, lp, ier, max_nranges int ncols, nlines, npts, nfree, nrejects, nranges, ncoeff pointer sp, cols, colsfit, lines, buf, fbuf, wgt, granges int prl_get_ranges(), grow_regions(), is_expand_ranges() int is_choose_rangesr() pointer imgl2r() errchk smark, salloc, sfree, imgl2r errchk iscoeff, islfit, issolve errchk prl_get_ranges, grow_regions errchk is_choose_rangesr begin ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) max_nranges = ncols # Allocate up temporary storage. call smark (sp) call salloc (cols, ncols, TY_INT) call salloc (colsfit, ncols, TY_INT) call salloc (lines, nlines, TY_INT) call salloc (fbuf, ncols, TY_INT) call salloc (wgt, ncols, TY_REAL) call salloc (granges, 3 * max_nranges + 1, TY_INT) # Initialize columns. do i = 1, ncols Memi[cols+i-1] = i call amovi (Memi[cols], Memi[colsfit], ncols) # Get number of coefficients. switch (SURFACE_TYPE(imfit)) { case SF_LEGENDRE, SF_CHEBYSHEV: ncoeff = XORDER(imfit) case SF_SPLINE3: ncoeff = XORDER(imfit) + 3 case SF_SPLINE1: ncoeff = XORDER(imfit) + 1 } # Refit affected lines and solve for surface. lp = 0 do i = 1, nlines { # Determine whether image line is good. if (gl != NULL) { nranges = prl_get_ranges (gl, i, Memi[granges], max_nranges) if (nranges == 0) next } # Define rejected points with region growing. call amovkr (1., Memr[wgt], ncols) nrejects = grow_regions (Memr[wgt], ncols, nlines, rl, i, NGROW(imfit)) # Get number of data points. if (gl == NULL) npts = ncols else npts = is_expand_ranges (Memi[granges], Memi[colsfit], ncols) nfree = npts - nrejects # If no rejected pixels skip to next line. if (nrejects == 0) { if (nfree >= ncoeff ) { Memi[lines+lp] = i lp = lp + 1 } next } # Read in image line. buf = imgl2r (im, i) if (buf == EOF) call error (0, "REFIT_SURFACE: Error reading image.") # Select the data. if (gl == NULL) { npts = ncols if (nfree >= ncoeff) call islfit (sf, Memi[colsfit], i, Memr[buf], Memr[wgt], npts, SF_USER, ier) else ier = NO_DEG_FREEDOM } else { ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], npts, 1, ncols) ijunk = is_choose_rangesr (Memi[colsfit], Memr[wgt], Memr[wgt], npts, 1, ncols) if (nfree >= ncoeff) call islfit (sf, Memi[colsfit], i, Memr[fbuf], Memr[wgt], npts, SF_USER, ier) else ier = NO_DEG_FREEDOM } # Evaluate fitting errors. switch (ier) { case NO_DEG_FREEDOM: call eprintf ("REFIT_SURFACE: Too few points to fit line: %d\n") call pargi (i) case SINGULAR: call eprintf ("REFIT_SURFACE: Solution singular for line: %d\n") call pargi (i) Memi[lines+lp] = i lp = lp + 1 default: Memi[lines+lp] = i lp = lp + 1 } } # Resolve surface. call issolve (sf, Memi[lines], lp, ier) # Evaluate fitting errors for surface. switch (ier) { case NO_DEG_FREEDOM: call error (0, "REFIT_SURFACE: Too few points to fit surface\n") case SINGULAR: call eprintf ("REFIT_SURFACE: Solution singular for surface\n") default: # everything OK } call sfree (sp) end # GROW_REGIONS -- Procedure to set weights of rejected points to zero. int procedure grow_regions (wgt, ncols, nlines, rl, line, ngrow) real wgt[ARB] # array of weights set to 1 int ncols # number of image columnspoints int nlines # number of images lines pointer rl # pointer to reject pixel list int line # line number int ngrow # radius for region growing int cp, j, k, nrejects, nranges, max_nranges int dist, yreg_min, yreg_max, xreg_min, xreg_max pointer sp, branges real r2 int prl_get_ranges(), is_next_number() errchk smark, salloc, sfree errchk prl_get_ranges, is_next_number begin max_nranges = ncols call smark (sp) call salloc (branges, 3 * max_nranges + 1, TY_INT) r2 = ngrow ** 2 nrejects = 0 yreg_min = max (1, line - ngrow) yreg_max = min (nlines, line + ngrow) do j = yreg_min, yreg_max { nranges = prl_get_ranges (rl, j, Memi[branges], max_nranges) if (nranges == 0) next dist = int (sqrt (r2 - (j - line) ** 2)) cp = 0 while (is_next_number (Memi[branges], cp) != EOF) { xreg_min = max (1, cp - dist) xreg_max = min (ncols, cp + dist) do k = xreg_min, xreg_max { if (wgt[k] > 0.) { wgt[k] = 0. nrejects = nrejects + 1 } } cp = xreg_max } } call sfree (sp) return (nrejects) end # GET_SIGMA -- Procedure to calculate the sigma of the surface fit real procedure get_sigma (im, gl, sf, rl) pointer im # pointer to image pointer gl # pointer to good pixel list pointer sf # pointer to surface deascriptor pointer rl # pointer to rejected pixel list int i, ijunk, cp, nranges, npts, ntpts, ncols, nlines, max_nranges pointer sp, colsfit, x, xfit, y, zfit, buf, fbuf, wgt, granges, branges real sum, sigma int prl_get_ranges(), is_next_number(), is_expand_ranges() int is_choose_rangesr() pointer imgl2r() real asumr(), awssqr() errchk smark, salloc, sfree, imgl2r begin ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) max_nranges = ncols # Allocate working space. call smark (sp) call salloc (colsfit, ncols, TY_REAL) call salloc (x, ncols, TY_REAL) call salloc (xfit, ncols, TY_REAL) call salloc (y, ncols, TY_REAL) call salloc (fbuf, ncols, TY_REAL) call salloc (zfit, ncols, TY_REAL) call salloc (wgt, ncols, TY_REAL) call salloc (granges, 3 * max_nranges + 1, TY_INT) call salloc (branges, 3 * max_nranges + 1, TY_INT) # Intialize the x array. do i = 1, ncols Memr[x+i-1] = i call amovr (Memr[x], Memr[xfit], ncols) sum = 0. sigma = 0. ntpts = 0 # Loop over the image. do i = 1, nlines { # Check that line is in range. if (gl != NULL) { nranges = prl_get_ranges (gl, i, Memi[granges], max_nranges) if (nranges == 0) next npts = is_expand_ranges (Memi[granges], Memi[colsfit], ncols) } # Read in image. buf = imgl2r (im, i) if (buf == EOF) call error (0, "GET_SIGMA: Error reading image.") # Select appropriate data and fit. call amovkr (real (i), Memr[y], ncols) if (gl == NULL) { npts = ncols call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) call asubr (Memr[buf], Memr[zfit], Memr[zfit], npts) } else { ijunk = is_choose_rangesr (Memi[colsfit], Memr[x], Memr[xfit], npts, 1, ncols) ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], npts, 1, ncols) call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) call asubr (Memr[fbuf], Memr[zfit], Memr[zfit], npts) } # Get ranges of rejected pixels for the line and set weights. call amovkr (1., Memr[wgt], ncols) nranges = prl_get_ranges (rl, i, Memi[branges], max_nranges) if (nranges > 0) { cp = 0 while (is_next_number (Memi[branges], cp) != EOF) Memr[wgt+cp-1] = 0. if (gl != NULL) ijunk = is_choose_rangesr (Memi[colsfit], Memr[wgt], Memr[wgt], npts, 1, ncols) } # Calculate sigma. sigma = sigma + awssqr (Memr[zfit], Memr[wgt], npts) ntpts = ntpts + asumr (Memr[wgt], npts) } call sfree (sp) return (sqrt (sigma / (ntpts - 1))) end # DETECT_REJECTS - Procedure to detect rejected pixels. int procedure detect_rejects (im, imfit, gl, sf, rl, sigma) pointer im # pointer to image pointer imfit # pointer to surface fitting structure pointer gl # pointer to good pixel list pointer sf # pointer to surface descriptor pointer rl # pointer to rejected pixel list real sigma # standard deviation of fit int i, j, ijunk, cp, ncols, nlines, npts, nranges, nlrejects, ntrejects int norejects, max_nranges pointer sp, granges, branges, x, xfit, cols, colsfit, y, zfit, buf, fbuf pointer wgt, list real upper, lower int prl_get_ranges(), is_next_number(), is_make_ranges(), is_expand_ranges() int is_choose_rangesr() pointer imgl2r() begin ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) max_nranges = ncols # Allocate temporary space. call smark (sp) call salloc (x, ncols, TY_REAL) call salloc (xfit, ncols, TY_REAL) call salloc (cols, ncols, TY_INT) call salloc (colsfit, ncols, TY_INT) call salloc (y, ncols, TY_REAL) call salloc (fbuf, ncols, TY_REAL) call salloc (zfit, ncols, TY_REAL) call salloc (wgt, ncols, TY_REAL) call salloc (granges, 3 * max_nranges + 1, TY_INT) call salloc (branges, 3 * max_nranges + 1, TY_INT) call salloc (list, ncols, TY_INT) # Intialize x and column values. do i = 1, ncols { Memi[cols+i-1] = i Memr[x+i-1] = i } call amovr (Memr[x], Memr[xfit], ncols) call amovi (Memi[cols], Memi[colsfit], ncols) ntrejects = 0 if (LOWER(imfit) <= 0.0) lower = -MAX_REAL else lower = -sigma * LOWER(imfit) if (UPPER(imfit) <= 0.0) upper = MAX_REAL else upper = sigma * UPPER(imfit) # Loop over the image. do i = 1, nlines { # Get ranges if appropriate. if (gl != NULL) { nranges = prl_get_ranges (gl, i, Memi[granges], max_nranges) if (nranges == 0) next npts = is_expand_ranges (Memi[granges], Memi[colsfit], ncols) } # Read in image. buf = imgl2r (im, i) if (buf == EOF) call error (0, "GET_SIGMA: Error reading image.") # Select appropriate data and fit. call amovkr (real (i), Memr[y], ncols) if (gl == NULL) { npts = ncols call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) call asubr (Memr[buf], Memr[zfit], Memr[zfit], npts) } else { ijunk = is_choose_rangesr (Memi[colsfit], Memr[x], Memr[xfit], npts, 1, ncols) ijunk = is_choose_rangesr (Memi[colsfit], Memr[buf], Memr[fbuf], npts, 1, ncols) call isvector (sf, Memr[xfit], Memr[y], Memr[zfit], npts) call asubr (Memr[fbuf], Memr[zfit], Memr[zfit], npts) } # Get ranges of rejected pixels for the line and set weights. call amovkr (1., Memr[wgt], ncols) nranges = prl_get_ranges (rl, i, Memi[branges], max_nranges) norejects = 0 if (nranges > 0) { cp = 0 while (is_next_number (Memi[branges], cp) != EOF) { Memi[list+norejects] = cp norejects = norejects + 1 Memr[wgt+cp-1] = 0. } if (gl != NULL) ijunk = is_choose_rangesr (Memi[colsfit], Memr[wgt], Memr[wgt], npts, 1, ncols) } # Detect deviant pixels. nlrejects = 0 do j = 1, npts { if ((Memr[zfit+j-1] < lower || Memr[zfit+j-1] > upper) && Memr[wgt+j-1] != 0.) { Memi[list+norejects+nlrejects] = Memi[colsfit+j-1] nlrejects = nlrejects + 1 } } # Add to rejected pixel list. if (nlrejects > 0) { call asrti (Memi[list], Memi[list], norejects + nlrejects) nranges = is_make_ranges (Memi[list], norejects + nlrejects, Memi[granges], max_nranges) call prl_put_ranges (rl, i, i, Memi[granges]) } ntrejects = ntrejects + nlrejects } call sfree (sp) return (ntrejects) end # AWSSQR -- Procedure to calculate the weighted sum of the squares real procedure awssqr (a, w, npts) real a[npts] # array of data real w[npts] # array of points int npts # number of data points int i real sum begin sum = 0. do i = 1, npts sum = sum + w[i] * a[i] ** 2 return (sum) end # IMS_DIVZER0 -- Return 1. on a divide by zero real procedure ims_divzero (x) real x begin return (1.) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/imsurfit/mkpkg�����������������������������������������������������������0000664�0000000�0000000�00000000507�13321663143�0017455�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Library for the IMAGES IMFIT Subpackage Tasks $checkout libmscred.a mscbin$ $update libmscred.a $checkin libmscred.a mscbin$ $exit libmscred.a: imsurfit.x imsurfit.h pixlist.x pixlist.h ranges.x t_imsurfit.x imsurfit.h ; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/imsurfit/pixlist.h�������������������������������������������������������0000664�0000000�0000000�00000000574�13321663143�0020272�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# PIXEL LIST descriptor structure define LEN_PLSTRUCT 10 define PRL_NCOLS Memi[$1] # number of columns define PRL_NLINES Memi[$1+1] # number of lines define PRL_LINES Memi[$1+2] # pointer to the line offsets define PRL_LIST Memi[$1+3] # pointer to list of ranges define PRL_SZLIST Memi[$1+4] # size of list in INTS define PRL_LP Memi[$1+5] # offset to next space in list ������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/imsurfit/pixlist.x�������������������������������������������������������0000664�0000000�0000000�00000023114�13321663143�0020305�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include "pixlist.h" .help pixels xtools "Pixel List Handling Tools" .nf ________________________________________________________________________ .fi .ih PURPOSE These routines provide simple pixel list handling facilities and are intended as a temporary facility pending full scale completion of image masking. The list is stored in the form of ranges as a function of line number. Each image line has a offset which may be NULL for no entry or an offset into the list itself. The actual list is a set of ranges with the ranges for each line delimited by a NULL. Routines exist to fetch the ranges for a given line, add or append ranges to a given line, fetch the next or previous line number with a non-NULL range and specify whether two lines have the same ranges. At present the list can grow indefinitely, with additional memory being added as necessary. No attempt is made to clean up redundant entries though such a faclity could easily be added. The ranges arguments conform with the design of the ranges routinesr, with each range consisting of and intitial and final entry and a step size. A list of ranges is terminated with a NULL .ih PROCEDURE .nf prl_init (pl, ncols, nlines) pointer pl # pointer to list descriptor int ncols # number of image columns int nlines # number of image lines nranges = prl_get_ranges (pl, lineno, ranges, max_nranges) pointer pl # pointer to list descriptor int lineno # line number of ranges to be fetched int ranges[ARB] # ranges to be output int max_nranges # the maximum number of ranges to be output prl_put_ranges (pl, linemin, linemax, ranges) pointer pl # pointer to list descriptor int linemin # minimum line number int linemax # maximum line number int ranges[ARB] # ranges to be added to list prl_append_ranges (pl, linemin, linemax, ranges) pointer pl # pointer to list descriptor int linemin # minimum line number int linemax # maximum line number int ranges[ARB] # ranges to be added to list next_lineno/EOF = prl_nextlineno (pl, current_lineno) pointer pl # pointer to list descriptor int current_lineno # current line number prev_lineno/EOF = prl_prevlineno (pl, current_lineno) pointer pl # pointer to the list descriptor int current_lineno # current line number YES/NO = prl_eqlines (pl, line1, line2) pointer pl # pointer to the list descriptor int line1 # first line number int line2 # second line number prl_free (pl) pointer pl # pointer to list descriptor .fi .endhelp ________________________________________________________________ # PRL_ADD_RANGES -- Procedure to add the ranges for a given range of # line numbers to the pixel list. The new ranges will be appended to any # previously existing ranges for the specified line numbers. procedure prl_add_ranges (pl, linemin, linemax, ranges) pointer pl # pointer to the list descriptor int linemin # minimum line number int linemax # maximum line number int ranges[ARB] # ranges int i, j, lc int olp, lp, lnull, lold int nr, nnewr, noldr begin # check conditions if ((linemin < 1) || (linemax > PRL_NLINES(pl)) || linemin > linemax) return # calculate the length of the range to be appended minus the null nr = 0 while (ranges[nr+1] != NULL) nr = nr + 1 lc = 1 olp = -1 do i = linemin, linemax { # get offset for line i lp = Memi[PRL_LINES(pl)+i-1] # if line pointer is undefined if (lp == NULL) { if (lc == 1) { # set line pointer and store Memi[PRL_LINES(pl)+i-1] = PRL_LP(pl) lnull = PRL_LP(pl) # check the size of the list if (PRL_SZLIST(pl) < (nr + PRL_LP(pl))) { PRL_SZLIST(pl) = PRL_SZLIST(pl) + nr + 1 call realloc (PRL_LIST(pl), PRL_SZLIST(pl), TY_INT) } # move ranges and reset pointers call amovi (ranges, Memi[PRL_LIST(pl)+PRL_LP(pl)-1], nr) PRL_LP(pl) = PRL_LP(pl) + nr + 1 Memi[PRL_LIST(pl)+PRL_LP(pl)-2] = NULL lc = lc + 1 } else # set line pointer Memi[PRL_LINES(pl)+i-1] = lnull } else { if (lp != olp) { # set line pointer and store Memi[PRL_LINES(pl)+i-1] = PRL_LP(pl) lold = PRL_LP(pl) # find length of previously defined range and calculate # length of new ranges for (j = lp; Memi[PRL_LIST(pl)+j-1] != NULL; j = j + 1) ; noldr = j - lp nnewr = noldr + nr # check size of list if (PRL_SZLIST(pl) < (nnewr + PRL_LP(pl))) { PRL_SZLIST(pl) = PRL_SZLIST(pl) + nnewr + 1 call realloc (PRL_LIST(pl), PRL_SZLIST(pl), TY_INT) } # add ranges to list and update pointers call amovi (Memi[PRL_LIST(pl)+lp-1], Memi[PRL_LIST(pl)+PRL_LP(pl)-1], noldr) PRL_LP(pl) = PRL_LP(pl) + noldr call amovi (ranges, Memi[PRL_LIST(pl)+PRL_LP(pl)-1], nr) PRL_LP(pl) = PRL_LP(pl) + nr + 1 Memi[PRL_LIST(pl)+PRL_LP(pl)-2] = NULL } else # set line pointers Memi[PRL_LINES(pl)+i-1] = lold olp = lp } } end # PRL_EQLINES -- Routine to test whether two lines have equal ranges. # The routine returns YES or NO. int procedure prl_eqlines (pl, line1, line2) pointer pl # pointer to the list int line1 # line numbers int line2 begin if (Memi[PRL_LINES(pl)+line1-1] == Memi[PRL_LINES(pl)+line2-1]) return (YES) else return (NO) end # PRL_GET_RANGES -- Procedure to fetch the ranges for the specified lineno. # Zero is returned if there are no ranges otherwise the number of ranges # are returned. The ranges are stored in an integer array. Three positive # numbers are used to define a range a minimum, maximum and a step size. # The ranges are delimited by a NULL. int procedure prl_get_ranges (pl, lineno, ranges, max_nranges) pointer pl # pointer to the pixel list descriptor int lineno # line number int ranges[ARB] # array of ranges int max_nranges # the maximum number of ranges int lp, ip int nranges begin # check for existence of ranges if (Memi[PRL_LINES(pl)+lineno-1] == NULL) { ranges[1] = NULL return (0) } # set pointer to the first element in list for line lineno lp = PRL_LIST(pl) + Memi[PRL_LINES(pl)+lineno-1] - 1 # get ranges nranges = 0 ip = 1 while (Memi[lp+ip-1] != NULL && nranges <= 3 * max_nranges) { ranges[ip] = Memi[lp+ip-1] ip = ip + 1 nranges = nranges + 1 } ranges[ip] = NULL # return nranges if (nranges == 0) return (nranges) else return (nranges / 3) end # PRL_NEXTLINENO -- Procedure to fetch the next line number with a set of # defined ranges given the current line number. Note that the current # line number is updated. int procedure prl_nextlineno (pl, current_lineno) pointer pl # pointer to the pixel list descriptor int current_lineno # current line number int findex, lp begin findex = max (1, current_lineno + 1) do lp = findex, PRL_NLINES(pl) { if (Memi[PRL_LINES(pl)+lp-1] != NULL) { current_lineno = lp return (lp) } } return (EOF) end # PRL_PREVLINENO -- Procedure to fetch the first previous line number # with a set of defined ranges given the current line number. # Note that the current line number is updated. int procedure prl_prevlineno (pl, current_lineno) pointer pl # pointer to the pixel list descriptor int current_lineno # current line number int findex, lp begin findex = min (current_lineno - 1, PRL_NLINES(pl)) do lp = findex, 1, -1 { if (Memi[PRL_LINES(pl)+lp-1] != NULL) { current_lineno = lp return (lp) } } return (EOF) end # PRL_PUT_RANGES -- Procedure to add the ranges for a given range of # lines to the pixel list. Note that any previously defined ranges are # lost. procedure prl_put_ranges (pl, linemin, linemax, ranges) pointer pl # pointer to the list int linemin # minimum line int linemax # maximum line int ranges[ARB] # list of ranges int i int len_range begin # check boundary conditions if ((linemin < 1) || (linemax > PRL_NLINES(pl)) || (linemin > linemax)) return # determine length of range string minus the NULL len_range = 0 while (ranges[len_range+1] != NULL) len_range = len_range + 1 # check space allocation if (PRL_SZLIST(pl) < (len_range + PRL_LP(pl))) { PRL_SZLIST(pl) = PRL_SZLIST(pl) + len_range + 1 call realloc (PRL_LIST(pl), PRL_SZLIST(pl), TY_INT) } # set the line pointers do i = linemin, linemax Memi[PRL_LINES(pl)+i-1] = PRL_LP(pl) # add ranges call amovi (ranges, Memi[PRL_LIST(pl)+PRL_LP(pl)-1], len_range) PRL_LP(pl) = PRL_LP(pl) + len_range + 1 Memi[PRL_LIST(pl)+PRL_LP(pl)-2] = NULL end # PLR_FREE -- Procedure to free the pixel list descriptor procedure prl_free (pl) pointer pl # pointer to pixel list descriptor begin if (pl == NULL) return if (PRL_LIST(pl) != NULL) call mfree (PRL_LIST(pl), TY_INT) if (PRL_LINES(pl) != NULL) call mfree (PRL_LINES(pl), TY_INT) call mfree (pl, TY_STRUCT) end # PRL_INIT -- Procedure to initialize the pixel list. Ncols and nlines are # the number of columns and lines respectively in the associated IRAF # image. procedure prl_init (pl, ncols, nlines) pointer pl # pixel list descriptor int ncols # number of image columns int nlines # number of image lines begin # allocate space for a pixel list descriptor call malloc (pl, LEN_PLSTRUCT, TY_STRUCT) # initialize PRL_NCOLS(pl) = ncols PRL_NLINES(pl) = nlines # allocate space for the line pointers call malloc (PRL_LINES(pl), PRL_NLINES(pl), TY_INT) call amovki (NULL, Memi[PRL_LINES(pl)], PRL_NLINES(pl)) # set pointer to next free element PRL_LP(pl) = 1 # allocate space for the actual list call malloc (PRL_LIST(pl), PRL_NLINES(pl), TY_INT) PRL_SZLIST(pl) = PRL_NLINES(pl) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/imsurfit/ranges.x��������������������������������������������������������0000664�0000000�0000000�00000032553�13321663143�0020077�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include .help ranges xtools "Range Parsing Tools" .ih PURPOSE These tools parse a string using a syntax to represent integer values, ranges, and steps. The parsed string is used to generate a list of integers for various purposes such as specifying lines or columns in an image or tape file numbers. .ih SYNTAX The syntax for the range string consists of positive integers, '-' (minus), 'x', ',' (comma), and whitespace. The commas and whitespace are ignored and may be freely used for clarity. The remainder of the string consists of sequences of five fields. The first field is the beginning of a range, the second is a '-', the third is the end of the range, the fourth is a 'x', and the fifth is a step size. Any of the five fields may be missing causing various default actions. The defaults are illustrated in the following table. .nf -3x1 A missing starting value defaults to 1. 2-x1 A missing ending value defaults to MAX_INT. 2x1 A missing ending value defaults to MAX_INT. 2-4 A missing step defaults to 1. 4 A missing ending value and step defaults to an ending value equal to the starting value and a step of 1. x2 Missing starting and ending values defaults to the range 1 to MAX_INT with the specified step. "" The null string is equivalent to "1 - MAX_INT x 1", i.e all positive integers. .fi The specification of several ranges yields the union of the ranges. .ih EXAMPLES The following examples further illustrate the range syntax. .nf - All positive integers. 1,5,9 A list of integers equivalent to 1-1x1,5-5x1,9-9x1. x2 Every second positive integer starting with 1. 2x3 Every third positive integer starting with 2. -10 All integers between 1 and 10. 5- All integers greater than or equal to 5. 9-3x1 The integers 3,6,9. .fi .ih PROCEDURES .ls 4 is_decode_ranges .nf int procedure is_decode_ranges (range_string, ranges, max_ranges, minimum, maximum, nvalues) char range_string[ARB] # Range string to be decoded int ranges[3, max_ranges] # Range array int max_ranges # Maximum number of ranges int minimum, maximum # Minimum and maximum range values allowed int nvalues # The number of values in the ranges .fi The range string is decoded into an integer array of maximum dimension 3 * max_ranges. Each range consists of three consecutive integers corresponding to the starting and ending points of the range and the step size. The number of integers covered by the ranges is returned as nvalue. The end of the set of ranges is marked by a NULL. The returned status is either ERR or OK. .le .ls 4 is_next_number, is_previous_number .nf int procedure is_next_number (ranges, number) int procedure is_previous_number (ranges, number) int ranges[ARB] # Range array int number # Both input and output parameter .fi Given a value for number the procedures find the next (previous) number in increasing (decreasing) value within the set of ranges. The next (previous) number is returned in the number argument. A returned status is either OK or EOF. EOF indicates that there are no greater values. The usual usage would be in a loop of the form: .nf number = 0 while (is_next_number (ranges, number) != EOF) { } .fi .le .ls 4 is_in_rangelist .nf bool procedure is_in_rangelist (ranges, number) int ranges[ARB] # Ranges array int number # Number to check againts ranges .fi A boolean value is returned indicating whether number is covered by the ranges. .endhelp # IS_DECODE_RANGES -- Parse a string containing a list of integer numbers or # ranges, delimited by either spaces or commas. Return as output a list # of ranges defining a list of numbers, and the count of list numbers. # Range limits must be positive nonnegative integers. ERR is returned as # the function value if a conversion error occurs. The list of ranges is # delimited by a single NULL. int procedure is_decode_ranges (range_string, ranges, max_ranges, minimum, maximum, nvalues) char range_string[ARB] # Range string to be decoded int ranges[3, max_ranges] # Range array int max_ranges # Maximum number of ranges int minimum, maximum # Minimum and maximum range values allowed int nvalues # The number of values in the ranges int ip, nrange, out_of_range, a, b, first, last, step, ctoi() begin ip = 1 nrange = 1 nvalues = 0 out_of_range = 0 while (nrange < max_ranges) { # Default values a = minimum b = maximum step = 1 # Skip delimiters while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') ip = ip + 1 # Get first limit. # Must be a number, '*', '-', 'x', or EOS. If not return ERR. if (range_string[ip] == EOS) { # end of list if (nrange == 1) { if (out_of_range == 0) { # Null string defaults ranges[1, 1] = a ranges[2, 1] = b ranges[3, 1] = step ranges[1, 2] = NULL nvalues = (b - a) / step + 1 return (OK) } else { # Only out of range data return (ERR) } } else { ranges[1, nrange] = NULL return (OK) } } else if (range_string[ip] == '-') ; else if (range_string[ip] == '*') ; else if (range_string[ip] == 'x') ; else if (IS_DIGIT(range_string[ip])) { # ,n.. if (ctoi (range_string, ip, a) == 0) return (ERR) } else return (ERR) # Skip delimiters while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') ip = ip + 1 # Get last limit # Must be '-', '*', or 'x' otherwise b = a. if (range_string[ip] == 'x') ; else if ((range_string[ip] == '-') || (range_string[ip] == '*')) { ip = ip + 1 while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') ip = ip + 1 if (range_string[ip] == EOS) ; else if (IS_DIGIT(range_string[ip])) { if (ctoi (range_string, ip, b) == 0) return (ERR) } else if (range_string[ip] == 'x') ; else return (ERR) } else b = a # Skip delimiters while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') ip = ip + 1 # Get step. # Must be 'x' or assume default step. if (range_string[ip] == 'x') { ip = ip + 1 while (IS_WHITE(range_string[ip]) || range_string[ip] == ',') ip = ip + 1 if (range_string[ip] == EOS) ; else if (IS_DIGIT(range_string[ip])) { if (ctoi (range_string, ip, step) == 0) ; } else if (range_string[ip] == '-') ; else if (range_string[ip] == '*') ; else return (ERR) } # Output the range triple. first = min (a, b) last = max (a, b) if (first < minimum) first = minimum + mod (step - mod (minimum - first, step), step) if (last > maximum) last = maximum - mod (last - maximum, step) if (first <= last) { ranges[1, nrange] = first ranges[2, nrange] = last ranges[3, nrange] = step nvalues = nvalues + (last - first) / step + 1 nrange = nrange + 1 } else out_of_range = out_of_range + 1 } return (ERR) # ran out of space end # IS_NEXT_NUMBER -- Given a list of ranges and the current file number, # find and return the next file number. Selection is done in such a way # that list numbers are always returned in monotonically increasing order, # regardless of the order in which the ranges are given. Duplicate entries # are ignored. EOF is returned at the end of the list. int procedure is_next_number (ranges, number) int ranges[ARB] # Range array int number # Both input and output parameter int ip, first, last, step, next_number, remainder begin # If number+1 is anywhere in the list, that is the next number, # otherwise the next number is the smallest number in the list which # is greater than number+1. number = number + 1 next_number = MAX_INT for (ip=1; ranges[ip] != NULL; ip=ip+3) { first = ranges[ip] last = ranges[ip+1] step = ranges[ip+2] if (number >= first && number <= last) { remainder = mod (number - first, step) if (remainder == 0) return (number) if (number - remainder + step <= last) next_number = number - remainder + step } else if (first > number) next_number = min (next_number, first) } if (next_number == MAX_INT) return (EOF) else { number = next_number return (number) } end # IS_PREVIOUS_NUMBER -- Given a list of ranges and the current file number, # find and return the previous file number. Selection is done in such a way # that list numbers are always returned in monotonically decreasing order, # regardless of the order in which the ranges are given. Duplicate entries # are ignored. EOF is returned at the end of the list. int procedure is_previous_number (ranges, number) int ranges[ARB] # Range array int number # Both input and output parameter int ip, first, last, step, next_number, remainder begin # If number-1 is anywhere in the list, that is the previous number, # otherwise the previous number is the largest number in the list which # is less than number-1. number = number - 1 next_number = 0 for (ip=1; ranges[ip] != NULL; ip=ip+3) { first = ranges[ip] last = ranges[ip+1] step = ranges[ip+2] if (number >= first && number <= last) { remainder = mod (number - first, step) if (remainder == 0) return (number) if (number - remainder >= first) next_number = number - remainder } else if (last < number) { remainder = mod (last - first, step) if (remainder == 0) next_number = max (next_number, last) else if (last - remainder >= first) next_number = max (next_number, last - remainder) } } if (next_number == 0) return (EOF) else { number = next_number return (number) } end # IS_IN_RANGELLIST -- Test number to see if it is in range. bool procedure is_in_rangelist (ranges, number) int ranges[ARB] # Range array int number # Number to be tested against ranges int ip, first, last, step begin for (ip=1; ranges[ip] != NULL; ip=ip+3) { first = ranges[ip] last = ranges[ip+1] step = ranges[ip+2] if (number >= first && number <= last) if (mod (number - first, step) == 0) return (TRUE) } return (FALSE) end # IS_EXPAND_RANGES -- Expand a range string into a array of values. int procedure is_expand_ranges (ranges, array, max_nvalues) int ranges[ARB] # Range array int array[max_nvalues] # Array of values int max_nvalues # Maximum number of values int n, value int is_next_number() begin n = 0 value = 0 while ((n < max_nvalues) && (is_next_number (ranges, value) != EOF)) { n = n + 1 array[n] = value } return (n) end # IS_SELECT_RANGES -- Select array values in the ranges. # The input and output arrays may be the same. procedure is_select_ranges (a, b, ranges) real a[ARB] # Input array real b[ARB] # Output array int ranges[3, ARB] # Ranges int i, j, npts, nmove begin npts = 0 for (i = 1; ranges[1, i] != NULL; i = i + 1) { if (ranges[3, i] == 1) { nmove = ranges[2, i] - ranges[1, i] + 1 call amovr (a[ranges[1, i]], b[npts + 1], nmove) npts = npts + nmove } else { do j = ranges[1, i], ranges[2, i], ranges[3, i] { npts = npts + 1 b[npts] = a[j] } } } end # IS_CHOOSE_RANGESI -- Copy the selected values from array a to b. int procedure is_choose_rangesi (indices, a, b, npts, ifirst, ilast) int indices[ARB] # array of indices int a[ARB] # input array int b[ARB] # output array int npts # number of points int ifirst # first index int ilast # last index int i, element begin element = 1 do i = 1, npts { if (indices[i] < ifirst || indices[i] > ilast) next b[element] = a[indices[i]] element = element + 1 } return (element - 1) end # IS_CHOOSE_RANGESR -- Copy the selected values from array a to b. int procedure is_choose_rangesr (indices, a, b, npts, ifirst, ilast) int indices[ARB] # array of indices real a[ARB] # input array real b[ARB] # output array int npts # number of points int ifirst # first element to be extracted int ilast # last element to be extracted int i, element begin element = 1 do i = 1, npts { if (indices[i] < ifirst || indices[i] > ilast) next b[element] = a[indices[i]] element = element + 1 } return (element - 1) end # IS_MAKE_RANGES -- Procedure to make a set of ranges from an ordered list # of column numbers. Only a step size of 1 is checked for. int procedure is_make_ranges (list, npts, ranges, max_nranges) int list[ARB] # list of column numbers in increasing order int npts # number of list elements int ranges[ARB] # output ranges int max_nranges # the maximum number of ranges bool next_range int ip, op, nranges begin # If zero list elements return if (npts == 0) { ranges[1] = NULL return (0) } # Initialize nranges = 0 ranges[1] = list[1] op = 2 next_range = false # Loop over column list for (ip = 2; ip <= npts && nranges < max_nranges; ip = ip + 1) { if ((list[ip] != (list[ip-1] + 1))) { ranges[op] = list[ip-1] op = op + 1 ranges[op] = 1 op = op + 1 nranges = nranges + 1 ranges[op] = list[ip] op = op + 1 } } # finish off if (npts == 1) { ranges[op] = list[npts] ranges[op+1] = 1 ranges[op+2] = NULL nranges = 1 } else if (nranges == max_nranges) { ranges[op-1] = NULL } else { ranges[op] = list[npts] ranges[op+1] = 1 ranges[op+2] = NULL nranges = nranges + 1 } return (nranges) end �����������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/imsurfit/t_imsurfit.x����������������������������������������������������0000664�0000000�0000000�00000030445�13321663143�0021003�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include "imsurfit.h" # T_IMSURFIT -- Fit a surface function to an image # # 1. A user selected function is fit to each surface. # 2. Only the selected regions of the image are fit. # 3. Deviant pixels may be rejected from the fit. # 4. The user selects the type of output image. The choices are: # a. the fitted image. # b. the input image with deviant pixels replaced by # the fitted values # c. the input image minus the fitted image. # d. the ratio of the input image and the fit where # pixels less than div_min are set to a ratio of 1. procedure t_imsurfit () char imtlist1[SZ_LINE] # Input image list char imtlist2[SZ_LINE] # Output image list char image1[SZ_FNAME] # Input image char image2[SZ_FNAME] # Output image char str[SZ_LINE], region_str[SZ_LINE], original[SZ_FNAME] int list1, list2, region_type pointer im1, im2, imfit, gl, sp bool clgetb() int imtopen(), imtgetim(), imtlen(), btoi(), clgeti(), clgwrd() pointer immap() real clgetr() begin # Allocate space for imfit structure. call smark (sp) call salloc (imfit, LEN_IMSFSTRUCT, TY_STRUCT) # Get task parameters. call clgstr ("input", imtlist1, SZ_FNAME) call clgstr ("output", imtlist2, SZ_FNAME) TYPE_OUTPUT(imfit) = clgwrd ("type_output", str, SZ_LINE, ",fit,clean,residual,response,") DIV_MIN(imfit) = clgetr ("div_min") # Get surface ftting parameters. SURFACE_TYPE(imfit) = clgwrd ("function", str, SZ_LINE, ",legendre,chebyshev,spline3,spline1,") XORDER(imfit) = clgeti ("xorder") YORDER(imfit) = clgeti ("yorder") CROSS_TERMS(imfit) = btoi (clgetb ("cross_terms")) # Get median processing parameters. XMEDIAN(imfit) = clgeti ("xmedian") YMEDIAN(imfit) = clgeti ("ymedian") MEDIAN_PERCENT(imfit) = clgetr ("median_percent") if (XMEDIAN(imfit) > 1 || YMEDIAN(imfit) > 1) MEDIAN(imfit) = YES else MEDIAN(imfit) = NO # Get rejection cycle parameters. NITER(imfit) = clgeti ("niter") LOWER(imfit) = clgetr ("lower") UPPER(imfit) = clgetr ("upper") NGROW(imfit) = clgeti ("ngrow") if (MEDIAN(IMFIT) == YES) { REJECT(imfit) = NO NITER(imfit) = 0 } else if (NITER(imfit) > 0 && (LOWER(imfit) > 0. || UPPER(imfit) > 0.)) REJECT(imfit) = YES else { REJECT(imfit) = NO NITER(imfit) = 0 } # Checking sigmas for cleaning. if (TYPE_OUTPUT(imfit) == CLEAN && MEDIAN(imfit) == YES) call error (0, "T_IMSURFIT: Clean option and median processing are exclusive.") if (TYPE_OUTPUT(imfit) == CLEAN && NITER(imfit) <= 0) call error (0, "T_IMSURFIT: Clean option requires non-zero niter.") if (TYPE_OUTPUT(imfit) == CLEAN && LOWER(imfit) <= 0. && UPPER(imfit) <= 0.) call error (0, "T_IMSURFIT: Clean option requires non-zero sigma.") # Get regions to be fit. gl = NULL region_type = clgwrd ("regions", str, SZ_LINE, REGIONS) switch (region_type) { case ALL: ; case BORDER: call clgstr ("border", region_str, SZ_LINE) case SECTIONS: call clgstr ("sections", region_str, SZ_LINE) case COLUMNS: call clgstr ("columns", region_str, SZ_LINE) case ROWS: call clgstr ("rows", region_str, SZ_LINE) case CIRCLE, INVCIRCLE: call clgstr ("circle", region_str, SZ_LINE) case MASK: call clgstr ("mask", region_str, SZ_LINE) } # Expand the input and output image lists. list1 = imtopen (imtlist1) list2 = imtopen (imtlist2) if (imtlen (list1) != imtlen (list2)) { call imtclose (list1) call imtclose (list2) call error (0, "Number of input and output images not the same.") } # Do each set of input and output images. while ((imtgetim (list1, image1, SZ_FNAME) != EOF) && (imtgetim (list2, image2, SZ_FNAME) != EOF)) { call xt_mkimtemp (image1, image2, original, SZ_FNAME) im1 = immap (image1, READ_ONLY, 0) im2 = immap (image2, NEW_COPY, im1) iferr { if (region_type != ALL) call make_good_list (im1, gl, region_type, region_str) call imsurfit (im1, im2, imfit, gl) } then call erract (EA_WARN) call imunmap (im1) call imunmap (im2) call xt_delimtemp (image2, original) call prl_free (gl) } # Cleanup. call sfree (sp) call imtclose (list1) call imtclose (list2) end # MAKE_GOOD_LIST -- Procedure to make a list of good regions. The program # returns an error message if no good regions are defined. The good # list parameter is set to NULL if the whole image is to be fit. This routine # uses both the ranges and pixlist package which will be replaced by image # masking. procedure make_good_list (im, gl, region_type, region_string) pointer im # pointer to the image pointer gl # good pixel list descriptor int region_type # type of good region char region_string[ARB] # region parameters int i, ip, zero, nvals, range_min, r2, xdist, max_nranges int x1, x2, y1, y2, temp, border, xcenter, ycenter, radius int columns[7] long v[PL_MAXDIM] pointer sp, ranges, mname, list, pm, pl, buf bool is_in_rangelist(), pm_linenotempty() int is_next_number(), is_decode_ranges(), imstati() int open(), fscan(), nscan(), ctoi() pointer xt_pmmap() errchk open, close, xt_pmmap begin # Determine the maximum number of images. max_nranges = IM_LEN(im,1) # Allocate working space. call smark (sp) call salloc (ranges, 3 * max_nranges + 1, TY_INT) call salloc (mname, SZ_FNAME, TY_CHAR) # Compute the good pixel list. switch (region_type) { case ROWS: # Decode the row ranges. if (is_decode_ranges (region_string, Memi[ranges], max_nranges, 1, int (IM_LEN(im,2)), nvals) == ERR) call error (0, "MAKE_GOOD_LIST: Error decoding row string.") if (nvals == 0) call error (0, "MAKE_GOOD_LIST: no good rows.") if (nvals == IM_LEN(im,2)) { call sfree (sp) return } # Intialize the good pixel list. call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) # Set column limits using the ranges format. columns[1] = 1 columns[2] = IM_LEN(im,1) columns[3] = 1 columns[4] = NULL # Set column limits for the specied lines. zero = 0 range_min = is_next_number (Memi[ranges], zero) while (range_min != EOF) { for (i = range_min; i <= IM_LEN(im,2) + 1; i = i + 1) { if (!is_in_rangelist (Memi[ranges], i) || i == IM_LEN(im,2)+1) { call prl_put_ranges (gl, range_min, i-1, columns) break } } range_min = is_next_number (Memi[ranges], i) } case COLUMNS: # Set the specified columns. if (is_decode_ranges (region_string, Memi[ranges], max_nranges, 1, int (IM_LEN(im,1)), nvals) == ERR) call error (0, "MAKE_GOOD_LIST: Error decoding column string.") if (nvals == 0) call error (0, "MAKE_GOOD_LIST: No good columns.") if (nvals == IM_LEN(im,1)) { call sfree (sp) return } # Make the good pixel list. call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) call prl_add_ranges (gl, 1, int (IM_LEN(im,2)), Memi[ranges]) case CIRCLE, INVCIRCLE: # Get the parameters of the circle. ip = 1 if (ctoi (region_string, ip, xcenter) <= 0) call error (0, "MAKE_GOOD_LIST: Error decoding xcenter.") if (ctoi (region_string, ip, ycenter) <= 0) call error (0, "MAKE_GOOD_LIST: Error decoding ycenter.") if (ctoi (region_string, ip, radius) <= 0) call error (0, "MAKE_GOOD_LIST: Error decoding radius.") y1 = max (1, ycenter - radius) y2 = min (int (IM_LEN(im,2)), ycenter + radius) x1 = max (1, xcenter - radius) x2 = min (int (IM_LEN(im,1)), xcenter + radius) if (region_type == CIRCLE) { if (y1 > IM_LEN(im,2) || y2 < 1 || x1 > IM_LEN(im,1) || x2 < 1) call error (0, "MAKE_GOOD_LIST: No good regions.") } # Create the good pixel list. call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) r2 = radius ** 2 if (region_type == CIRCLE) { do i = y1, y2 { xdist = sqrt (real (r2 - (ycenter - i) ** 2)) x1 = max (1, xcenter - xdist) x2 = min (IM_LEN(im,1), xcenter + xdist) columns[1] = x1 columns[2] = x2 columns[3] = 1 columns[4] = NULL call prl_put_ranges (gl, i, i, columns) } } else if (region_type == INVCIRCLE) { do i = 1, y1 - 1 { columns[1] = 1 columns[2] = IM_LEN(im,1) columns[3] = 1 columns[4] = NULL call prl_put_ranges (gl, i, i, columns) } do i = y2 + 1, IM_LEN(im,2) { columns[1] = 1 columns[2] = IM_LEN(im,1) columns[3] = 1 columns[4] = NULL call prl_put_ranges (gl, i, i, columns) } do i = y1, y2 { xdist = sqrt (real (r2 - (ycenter - i) ** 2)) x1 = max (1, xcenter - xdist) x2 = min (IM_LEN(im,1), xcenter + xdist) if (x1 > 1) { columns[1] = 1 columns[2] = x1 - 1 columns[3] = 1 if (x2 < IM_LEN(im,1)) { columns[4] = x2 + 1 columns[5] = IM_LEN(im,1) columns[6] = 1 columns[7] = NULL } else columns[4] = NULL } else if (x2 < IM_LEN(im,1)) { columns[1] = x2 + 1 columns[2] = IM_LEN(im,1) columns[3] = 1 columns[4] = NULL } else columns[1] = NULL call prl_put_ranges (gl, i, i, columns) } } case SECTIONS: # Open file of sections. list = open (region_string, READ_ONLY, TEXT_FILE) call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) # Scan the list. while (fscan (list) != EOF) { # Fetch parameters from list. call gargi (x1) call gargi (x2) call gargi (y1) call gargi (y2) if (nscan() != 4) next # Check and correct for out of bounds limits. x1 = max (1, min (IM_LEN(im,1), x1)) x2 = min (IM_LEN(im,1), max (1, x2)) y1 = max (1, min (IM_LEN(im,2), y1)) y2 = min (IM_LEN(im,2), max (1, y2)) # Check the order. if (x2 < x1) { temp = x1 x1 = x2 x2 = temp } if (y2 < y1) { temp = y1 y1 = y2 y2 = temp } # If entire image return. if ((x1 == 1) && (x2 == IM_LEN(im,1)) && (y1 == 1) && (y2 == IM_LEN(im,2))) { call prl_free (gl) gl = NULL break } # Set ranges. columns[1] = x1 columns[2] = x2 columns[3] = 1 columns[4] = NULL call prl_add_ranges (gl, y1, y2, columns) } call close (list) case BORDER: # Decode border parameter. ip = 1 if (ctoi (region_string, ip, border) == ERR) call error (0, "MAKE_GOOD_LIST: Error decoding border string.") if (border < 1) call error (0, "MAKE_GOOD_LIST: No border.") if ((border > IM_LEN(im,1)/2) && (border > IM_LEN(im,2)/2)) { call sfree (sp) return } # Intialize list. call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) y1 = 1 + border - 1 y2 = IM_LEN(im,2) - border + 1 columns[1] = 1 columns[2] = IM_LEN(im,1) columns[3] = 1 columns[4] = NULL # Set ranges for top and bottom edges of image. call prl_put_ranges (gl, 1, y1, columns) call prl_put_ranges (gl, y2, int (IM_LEN(im,2)), columns) columns[1] = 1 columns[2] = y1 columns[3] = 1 columns[4] = NULL call prl_put_ranges (gl, y1 + 1, y2 - 1, columns) columns[1] = IM_LEN(im,1) - border + 1 columns[2] = IM_LEN(im,1) columns[3] = 1 columns[4] = NULL call prl_add_ranges (gl, y1 + 1, y2 - 1, columns) case MASK: # Open mask. pm = xt_pmmap (region_string, im, Memc[mname], SZ_FNAME) if (pm == NULL) { call sfree (sp) gl = NULL return } pl = imstati (pm, IM_PLDES) call prl_init (gl, int (IM_LEN(im,1)), int (IM_LEN(im,2))) call salloc (buf, 3*IM_LEN(im,1), TY_INT) # Scan the mask and set range list representation. columns[3] = 1 columns[4] = NULL v[1] = 1 do y1 = 1, IM_LEN(im,2) { v[2] = y1 if (!pm_linenotempty (pl, v)) { columns[1] = 1 columns[2] = IM_LEN(im,1) call prl_add_ranges (gl, y1, y1, columns) } else { call plglri (pl, v, Memi[buf], 0, IM_LEN(im,1), 0) columns[1] = 1 do i = 1, Memi[buf]-1 { columns[2] = Memi[buf+3*i] - 1 if (columns[1] <= columns[2]) call prl_add_ranges (gl, y1, y1, columns) columns[1] = columns[2] + Memi[buf+3*i+1] + 1 } columns[2] = IM_LEN(im,1) if (columns[1] <= columns[2]) call prl_add_ranges (gl, y1, y1, columns) } } call imunmap (pm) } call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/irmfringe.cl�������������������������������������������������������������0000664�0000000�0000000�00000016716�13321663143�0017072�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# RMFRINGE -- Remove fringe template. procedure rmfringe (input, output, template) string input {prompt="List of input mosaic exposures"} string output {prompt="List of output mosaic exposures"} file template {prompt="Template mosaic exposure"} string extname = "" {prompt="Extensions for fit"} int blkavg = 4 {prompt="Block average factor"} real scale = 0.5 {prompt="Scale"} bool interactive = yes {prompt="Interactive?"} bool mscexam = no {prompt="Examine corrections with MSCEXAM?"} bool verbose = yes {prompt="Verbose output?"} real newscale = 1. {prompt="Scale (0=done, -1=abort, -2=new blkavg)", mode="q"} int newblk {prompt="New block average factor", mode="q"} struct *fd1, *fd2, *fd3 begin bool mef file in, out, tmplt file tmpout, im1, im2, im3, im4, im5 file meflist, alllist, inlist, temp, temp2, inblk, outblk, tblk string masks int blk, nsum, nextn real s, s2, sbest, psky1, psum1, psky2, psum2, pmax2 real xc, yc, rin, drin, rout, drout struct pupilpar, logstr cache mscextensions # Define temporary files and images. meflist = mktemp ("tmp$iraf") alllist = mktemp ("tmp$iraf") inlist = mktemp ("tmp$iraf") temp = mktemp ("tmp$iraf") temp2 = mktemp ("tmp$iraf") tmpout = mktemp ("tmp") # Expand lists. sections (input, option="fullname", > inlist) nsum = sections.nimages sections (output, option="fullname", > temp) tmplt = template joinlines (inlist, temp, output=meflist, delim=" ", missing="", maxchars=161, shortest-, verbose-) delete (inlist, verify-) delete (temp, verify-) if (sections.nimages != 0 && nsum != sections.nimages) { delete (meflist, verify-) error (1, "Input and output lists do not match") } if (!imaccess (tmplt//"[1]")) { delete (meflist, verify-) error (1, "Can't access template image ("//tmplt//")") } if (verbose) { printf ("RMFRINGE: ") time } fd3 = meflist while (fscan (fd3, in, out) != EOF) { if (nscan() == 1) out = in # Check images. if (!imaccess (in//"[1]")) { print (" WARNING: Can't access input image ("//in//")") next } logstr = "" hselect (in//"[1]", "FRINGCOR", yes) | scan (logstr) if (logstr != "") { print (" WARNING: Data already corrected ("//in//")") next } if (out == in) out = tmpout else if (imaccess (out//"[1]")) { print (" WARNING: Output image already exists ("//out//")") next } # Expand extensions. mscextensions (in, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) mef = mscextensions.imext mscextensions (tmplt, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=alllist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) nextn = mscextensions.nimages # Initial scale. s = scale # Block average to make things go faster. if (interactive) blk = blkavg else blk = 1 newblk: mscextensions (in, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) if (mscextensions.nimages == 0) { printf ("WARNING: ") printf ("No extensions in list, using all extensions\n") extname = "" delete (temp, verify-) mscextensions (in, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) } mscextensions (tmplt, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) if (blk > 1) { printf ("Block averaging %s and %s by a factor of %d ...\n", in, tmplt, blk) inblk = mktemp ("tmp") tblk = mktemp ("tmp") outblk = mktemp ("tmp") fd1 = inlist if (mef) { imcopy (in//"[0]", inblk, verbose-) imcopy (tmplt//"[0]", tblk, verbose-) while (fscan (fd1, im1, im2) != EOF) { blkavg (im1, inblk//"[append,inherit]", blk, blk, option = "average") blkavg (im2, tblk//"[append,inherit]", blk, blk, option = "average") } } else { while (fscan (fd1, im1, im2) != EOF) { blkavg (im1, inblk, blk, blk, option = "average") blkavg (im2, tblk, blk, blk, option = "average") } } fd1 = "" } else { inblk = in tblk = tmplt outblk = out } # Expand block average extensions. rename (inlist, temp, field="all") mscextensions (inblk, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) rename (inlist, temp, field="all") mscextensions (tblk, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) sbest = s # Scale loop. if (interactive) { printf ("Displaying %s ...\n", in) mscdisplay (inblk, 1, extname=extname, >> "dev$null") sbest = INDEF while (s > 0.) { printf ("Scaling %s by %.3g and subtracting from %s ...\n", tmplt, s, in) imdelete (outblk, verify-, >& "dev$null") if (mef) imcopy (inblk//"[0]", outblk, verbose-) fd1 = inlist while (fscan (fd1, im1, im2, im3, im4) != EOF) { imexpr ("a-(c*b)", outblk//"[append,inherit]", im3, im4, s, dims="auto", intype="auto", outtype="real", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") } fd1 = "" printf ("Displaying corrected version of %s ...\n", in) mscdisplay (outblk, 2, extname=extname, >> "dev$null") if (mscexam) { printf ("Entering MSCEXAM (quit with 'q') ...\n") mscexamine } sbest = s newscale = s s = newscale } } delete (inlist, verify-) if (inblk != in) imdelete (inblk, verify-) if (tblk != tmplt) imdelete (tblk, verify-) if (s == -1) { sbest = INDEF imdelete (outblk, verify-) } else if (s == -2) { imdelete (outblk, verify-) newblk = blk blk = newblk s = sbest goto newblk } # Create output corrected image. if (sbest!=INDEF && (!interactive || outblk!=out || mscextensions.nimages!=nextn)) { if (verbose) { if (out == tmpout) printf (" Correcting image %s with scale %.3g ...\n", in, sbest) else printf (" Creating output image %s with scale %.3g ...\n", out, sbest) } if (interactive || outblk != out) imdelete (outblk, verify-) if (mef) imcopy (in//"[0]", out, verbose-) fd1 = alllist while (fscan (fd1, im1, im2) != EOF) { imexpr ("a-(c*b)", out//"[append,inherit]", im1, im2, sbest, dims="auto", intype="auto", outtype="real", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") } fd1 = "" printf ("hedit $input fringcor \"[%s]-(%.4g*[%s])\" add+ del- ver- upd+ show-\n", in, sbest, tmplt) | scan (logstr) msccmd (logstr, out, extname="", alist-, flist-, verbose-, exec+) if (out == tmpout) { imdelete (in, verify-) imrename (out, in, verbose-) } } delete (alllist, verify-) } fd3 = ""; delete (meflist, verify-) end ��������������������������������������������������mscred-5.05-2018.07.09/src/irmpupil.cl��������������������������������������������������������������0000664�0000000�0000000�00000023506�13321663143�0016744�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# RMPUPIL -- Remove pupil template. procedure rmpupil (input, output, template) string input {prompt="List of input mosaic exposures"} string output {prompt="List of output mosaic exposures"} file template {prompt="Template mosaic exposure"} string type = "difference" {prompt="Type of removal", enum="difference|ratio"} string extname = "im[2367]" {prompt="Extensions for fit"} int blkavg = 8 {prompt="Block average factor"} real fudge = 1.6 {prompt="Fudge factor"} real scale = INDEF {prompt="Scale (INDEF for automatic estimate)"} bool interactive = yes {prompt="Interactive?"} bool mscexam = no {prompt="Examine corrections with MSCEXAM?"} bool verbose = yes {prompt="Verbose output?"} real newscale = 1. {prompt="Scale (0=done, -1=abort, -2=new blkavg)", mode="q"} int newblk {prompt="New block average factor", mode="q"} struct *fd1, *fd2, *fd3 begin bool mef file in, out, tmplt file tmpout, im1, im2, im3, im4, im5 file meflist, alllist, inlist, temp, temp2, inblk, outblk, tblk string masks int blk, blkt, nsum, nextn real s, s2, sbest, psky1, psum1, psky2, psum2, pmax2 real xc, yc, rin, drin, rout, drout struct pupilpar, logstr cache mscextensions # Define temporary files and images. meflist = mktemp ("tmp$iraf") alllist = mktemp ("tmp$iraf") inlist = mktemp ("tmp$iraf") temp = mktemp ("tmp$iraf") temp2 = mktemp ("tmp$iraf") tmpout = mktemp ("tmp") # Expand lists. sections (input, option="fullname", > inlist) nsum = sections.nimages sections (output, option="fullname", > temp) tmplt = template joinlines (inlist, temp, output=meflist, delim=" ", missing="", maxchars=161, shortest-, verbose-) delete (inlist, verify-) delete (temp, verify-) if (sections.nimages != 0 && nsum != sections.nimages) { delete (meflist, verify-) error (1, "Input and output lists do not match") } if (!imaccess (tmplt//"[1]")) { delete (meflist, verify-) error (1, "Can't access template image ("//tmplt//")") } if (verbose) { printf ("RMPUPIL: ") time } fd3 = meflist while (fscan (fd3, in, out) != EOF) { if (nscan() == 1) out = in # Check images. if (!imaccess (in//"[1]")) { print (" WARNING: Can't access input image ("//in//")") next } logstr = "" hselect (in//"[1]", "RMPUPIL", yes) | scan (logstr) if (logstr != "") { print (" WARNING: Data already corrected ("//in//")") next } if (out == in) out = tmpout else if (imaccess (out//"[1]")) { print (" WARNING: Output image already exists ("//out//")") next } # Expand extensions. mscextensions (in, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) mef = mscextensions.imext mscextensions (tmplt, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=alllist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) nextn = mscextensions.nimages # Initial scale. s = scale # Block average to make things go faster. if (interactive || s == INDEF) blk = blkavg else blk = 1 if (interactive) blkt = blkavg else blkt = 1 newblk: mscextensions (in, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) if (mscextensions.nimages == 0) { printf ("WARNING: ") printf ("No extensions in list, using all extensions\n") extname = "" delete (temp, verify-) mscextensions (in, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp) } mscextensions (tmplt, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) # Block average data. if (blk > 1) { printf ("Block averaging %s by a factor of %d ...\n", in, blk) inblk = mktemp ("tmp") fd1 = inlist if (mef) { imcopy (in//"[0]", inblk, verbose-) while (fscan (fd1, im1, im2) != EOF) blkavg (im1, inblk//"[append,inherit]", blk, blk, option = "average") } else { while (fscan (fd1, im1, im2) != EOF) blkavg (im1, inblk, blk, blk, option = "average") } fd1 = "" } else inblk = in # Block average template. if (blkt > 1) { printf ("Block averaging %s by a factor of %d ...\n", tmplt, blkt) tblk = mktemp ("tmp") outblk = mktemp ("tmp") fd1 = inlist if (mef) { imcopy (tmplt//"[0]", tblk, verbose-) while (fscan (fd1, im1, im2) != EOF) blkavg (im2, tblk//"[append,inherit]", blk, blk, option = "average") } else { while (fscan (fd1, im1, im2) != EOF) blkavg (im2, tblk, blk, blk, option = "average") } fd1 = "" } else { tblk = tmplt outblk = out } # Expand block average extensions. rename (inlist, temp, field="all") mscextensions (inblk, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) rename (inlist, temp, field="all") mscextensions (tblk, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="") | joinlines (temp, "STDIN", output=inlist, delim=" ", missing="Missing", maxchars=161, shortest+, verbose-) delete (temp, verify-) # Automatic estimate. if (verbose) printf (" Estimating scale factor for %s ...\n", in) if (s == INDEF) { sbest = 0 nsum = 0 fd1 = inlist while (fscan (fd1, im1, im2, im3, im4) != EOF) { hselect (im4, "pupilsky,pupilsum,pupilpar", yes) | scan (psky1, psum1,pupilpar) if (nscan() != 3) next if (fscan (pupilpar, xc, yc, rin, drin, rout, drout, masks) < 6) next pupilfit (im3, "", masks=masks, type="fit", xc=xc, yc=yc, rin=rin, drin=drin, rout=rout, drout=drout, abin=360., rorder=10, verbose-) | scan (psky2, psum2, pmax2) if (nscan() != 3) next if (type == "difference") { s = psum2 / psum1 * blk**2 s = s / fudge # fudge factor } else { s = psum2 / psum1 / psky2 * blk**2 s = s / fudge # fudge factor } sbest = sbest + s nsum = nsum + 1 } if (nsum > 0) { sbest = sbest / nsum printf ("%.3g\n", sbest) | scan (sbest) } if (sbest <= 0.) { if (type == "ratio") sbest = 0.0001 else sbest = 1. } } else sbest = s s = sbest # Scale loop. if (interactive) { printf ("Displaying %s ...\n", in) mscdisplay (inblk, 1, extname=extname, >> "dev$null") sbest = INDEF while (s > 0.) { if (type == "difference") printf ("Scaling %s by %.3g and subtracting from %s ...\n", tmplt, s, in) else printf ("Scaling %s by %.3g and dividing from %s ...\n", tmplt, s, in) imdelete (outblk, verify-, >& "dev$null") if (mef) imcopy (inblk//"[0]", outblk, verbose-) fd1 = inlist while (fscan (fd1, im1, im2, im3, im4) != EOF) { if (type == "difference") imexpr ("a-(c*b)", outblk//"[append,inherit]", im3, im4, s, dims="auto", intype="auto", outtype="real", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") else imexpr ("a/(c*b+1)", outblk//"[append,inherit]", im3, im4, s, dims="auto", intype="auto", outtype="real", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") } fd1 = "" printf ("Displaying corrected version of %s ...\n", in) mscdisplay (outblk, 2, extname=extname, >> "dev$null") if (mscexam) { printf ("Entering MSCEXAM (quit with 'q') ...\n") mscexamine } sbest = s newscale = s s = newscale } } delete (inlist, verify-) if (inblk != in) imdelete (inblk, verify-) if (tblk != tmplt) imdelete (tblk, verify-) if (s == -1) { sbest = INDEF imdelete (outblk, verify-) } else if (s == -2) { imdelete (outblk, verify-) newblk = blk blk = newblk blkt = newblk s = sbest goto newblk } # Create output corrected image. if (sbest!=INDEF && (!interactive || outblk!=out || mscextensions.nimages!=nextn)) { if (verbose) { if (out == tmpout) printf (" Correcting image %s with scale %.3g ...\n", in, sbest) else printf (" Creating output image %s with scale %.3g ...\n", out, sbest) } if (interactive || outblk != out) imdelete (outblk, verify-) if (mef) imcopy (in//"[0]", out, verbose-) fd1 = alllist while (fscan (fd1, im1, im2) != EOF) { if (type == "difference") { imexpr ("a-(c*b)", out//"[append,inherit]", im1, im2, sbest, dims="auto", intype="auto", outtype="real", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") } else { imexpr ("a/(c*b+1)", out//"[append,inherit]", im1, im2, sbest, dims="auto", intype="auto", outtype="real", refim="auto", bwidth=0, btype="nearest", bpixval=0., rangecheck+, verbose-, exprdb="none") } } fd1 = "" if (type == "difference") printf ("hedit $input rmpupil \"[%s]-(%.4g*[%s])\" add+ del- ver- upd+ show-\n", in, sbest, tmplt) | scan (logstr) else printf ("hedit $input rmpupil \"[%s]/(%.4g*[%s]+1)\" add+ del- ver- upd+ show-\n", in, sbest, tmplt) | scan (logstr) msccmd (logstr, out, extname="", alist-, flist-, verbose-, exec+) if (out == tmpout) { imdelete (in, verify-) imrename (out, in, verbose-) } } delete (alllist, verify-) } fd3 = ""; delete (meflist, verify-) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/joinlists.par������������������������������������������������������������0000664�0000000�0000000�00000000616�13321663143�0017302�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������list1,s,a,"",,,List list2,s,a,"",,,List list3,s,a,"",,,List list4,s,a,"",,,List list5,s,a,"",,,List list6,s,a,"",,,List list7,s,a,"",,,List list8,s,a,"",,,List list9,s,a,"",,,List output,s,h,"STDOUT",,,Output file delim,s,h," ",,,Delimiter between list elements shortest,b,h,no,,,Quit at end of shortest list missing,s,h,"-",,,Marker for missing element type,s,h,"file","file|image",,Type of lists ������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/liststr.gx���������������������������������������������������������������0000664�0000000�0000000�00000017121�13321663143�0016623�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include $for (r) # LI_FIND_FIELDS -- This procedure finds the starting column for each field # in the input line. These column numbers are returned in the array # field_pos; the number of fields is also returned. procedure li_find_fields (linebuf, field_pos, max_fields, nfields) char linebuf[ARB] #I the input buffer int field_pos[max_fields] #O the output field positions int max_fields #I the maximum number of fields int nfields #O the computed number of fields bool in_field int ip, field_num begin field_num = 1 field_pos[1] = 1 in_field = false for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { if (! IS_WHITE(linebuf[ip])) in_field = true else if (in_field) { in_field = false field_num = field_num + 1 field_pos[field_num] = ip } } field_pos[field_num+1] = ip nfields = field_num end # LI_CAPPEND_LINE -- Fields are copied from the input buffer to the # output buffer. procedure li_cappend_line (inbuf, outbuf, maxch, xoffset, yoffset, xwidth, ywidth) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer int xoffset #I the offset to the x field int yoffset #I the offset to the y field int xwidth #I the width of the x field int ywidth #I the width of the y field int ip, op int gstrcpy() begin # Copy the input buffer into the output buffer minus the newline. op = 1 for (ip = 1; ip <= maxch; ip = ip + 1) { if (inbuf[ip] == '\n' || inbuf[ip] == EOS) break outbuf[op] = inbuf[ip] op = op + 1 } # Add a blank. if (op <= maxch) { outbuf[op] = ' ' op = op + 1 } # Copy the two fields. op = op + gstrcpy (inbuf[xoffset], outbuf[op], min (maxch - op + 1, xwidth)) op = op + gstrcpy (inbuf[yoffset], outbuf[op], min (maxch - op + 1, ywidth)) # Add a newline. if (op <= maxch) { outbuf[op] = '\n' op = op + 1 } outbuf[op] = EOS end $endfor $for (rd) # LT_GET_NUM -- The field entry is converted from character to real or double # in preparation for the transformation. The number of significant # digits is counted and returned as an argument; the number of chars in # the number is returned as the function value. int procedure li_get_num$t (linebuf, fval, nsdig) char linebuf[ARB] #I the input line buffer PIXEL fval #O the output floating point value int nsdig #O the number of significant digits char ch int nchar, ip int cto$t(), stridx() begin ip = 1 nsdig = 0 nchar = cto$t (linebuf, ip, fval) if (nchar == 0 || fval == $INDEF$T) return (nchar) # Skip leading white space. ip = 1 repeat { ch = linebuf[ip] if (! IS_WHITE(ch)) break ip = ip + 1 } # Count signifigant digits for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { if (stridx (ch, "eEdD") > 0) break if (IS_DIGIT (ch)) nsdig = nsdig + 1 ip = ip + 1 } return (nchar) end # LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed # fields are converted to strings; other fields are copied from # the input line to output buffer. procedure li_pack_line$t (inbuf, outbuf, maxch, field_pos, nfields, xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer int field_pos[ARB] #I starting positions for the fields int nfields #I the number of fields int xfield #I the field number of the x coordinate column int yfield #I the field number of the y coordinate column PIXEL xt #I the transformed x coordinate PIXEL yt #I the transformed y coordinate char xformat[ARB] #I the output format for the x column char yformat[ARB] #I the output format for the y column int nsdig_x #I the number of significant digits in x int nsdig_y #I the number of significant digits in y int min_sigdigits #I the minimum number of significant digits int num_field, width, op pointer sp, field int gstrcpy() begin call smark (sp) call salloc (field, SZ_LINE, TY_CHAR) # Initialize output pointer. op = 1 do num_field = 1, nfields { width = field_pos[num_field + 1] - field_pos[num_field] if (num_field == xfield) { call li_format_field$t (xt, Memc[field], maxch, xformat, nsdig_x, width, min_sigdigits) } else if (num_field == yfield) { call li_format_field$t (yt, Memc[field], maxch, yformat, nsdig_y, width, min_sigdigits) } else { # Put "width" characters from inbuf into field call strcpy (inbuf[field_pos[num_field]], Memc[field], width) } # Fields must be delimited by at least one blank. if (num_field > 1 && !IS_WHITE (Memc[field])) { outbuf[op] = ' ' op = op + 1 } # Copy "field" to output buffer. op = op + gstrcpy (Memc[field], outbuf[op], maxch) } outbuf[op] = '\n' outbuf[op+1] = EOS call sfree (sp) end # LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed # fields are converted to strings and added to the end of the input buffer. procedure li_append_line$t (inbuf, outbuf, maxch, xt, yt, xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer PIXEL xt #I the transformed x coordinate PIXEL yt #I the transformed y coordinate char xformat[ARB] #I the output format for the x column char yformat[ARB] #I the output format for the y column int nsdig_x #I the number of significant digits in x int nsdig_y #I the number of significant digits in y int min_sigdigits #I the minimum number of significant digits int ip, op pointer sp, field int gstrcpy() begin # Allocate some working space. call smark (sp) call salloc (field, SZ_LINE, TY_CHAR) # Copy the input buffer into the output buffer minus the newline. op = 1 for (ip = 1; ip <= maxch; ip = ip + 1) { if (inbuf[ip] == '\n' || inbuf[ip] == EOS) break outbuf[op] = inbuf[ip] op = op + 1 } # Add two blanks. op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) # Format and add the the two extra fields with a blank between. call li_format_field$t (xt, Memc[field], SZ_LINE, xformat, nsdig_x, 0, min_sigdigits) op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) if (op <= maxch) { outbuf[op] = ' ' op = op + 1 } call li_format_field$t (yt, Memc[field], SZ_LINE, yformat, nsdig_y, 0, min_sigdigits) op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) # Add a newline. if (op <= maxch) { outbuf[op] = '\n' op = op + 1 } outbuf[op] = EOS call sfree (sp) end # LI_FORMAT_FIELD -- A transformed coordinate is written into a string # buffer. The output field is of (at least) the same width and significance # as the input list entry. procedure li_format_field$t (fval, wordbuf, maxch, format, nsdig, width, min_sigdigits) PIXEL fval #I the input value to be formatted char wordbuf[maxch] #O the output formatted string int maxch #I the maximum length of the output string char format[ARB] #I the output format int nsdig #I the number of sig-digits in current value int width #I the width of the curent field int min_sigdigits #I the minimum number of significant digits int fdigits, fwidth begin if (format[1] == EOS) { fdigits = max (min_sigdigits, nsdig) fwidth = max (width, fdigits + 1) call sprintf (wordbuf, maxch, "%*.*g") call pargi (fwidth) call pargi (fdigits) call parg$t (fval) } else { call sprintf (wordbuf, maxch, format) call parg$t (fval) } end $endfor �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/liststr.x����������������������������������������������������������������0000664�0000000�0000000�00000032214�13321663143�0016454�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # LI_FIND_FIELDS -- This procedure finds the starting column for each field # in the input line. These column numbers are returned in the array # field_pos; the number of fields is also returned. procedure li_find_fields (linebuf, field_pos, max_fields, nfields) char linebuf[ARB] #I the input buffer int field_pos[max_fields] #O the output field positions int max_fields #I the maximum number of fields int nfields #O the computed number of fields bool in_field int ip, field_num begin field_num = 1 field_pos[1] = 1 in_field = false for (ip=1; linebuf[ip] != '\n' && linebuf[ip] != EOS; ip=ip+1) { if (! IS_WHITE(linebuf[ip])) in_field = true else if (in_field) { in_field = false field_num = field_num + 1 field_pos[field_num] = ip } } field_pos[field_num+1] = ip nfields = field_num end # LI_CAPPEND_LINE -- Fields are copied from the input buffer to the # output buffer. procedure li_cappend_line (inbuf, outbuf, maxch, xoffset, yoffset, xwidth, ywidth) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer int xoffset #I the offset to the x field int yoffset #I the offset to the y field int xwidth #I the width of the x field int ywidth #I the width of the y field int ip, op int gstrcpy() begin # Copy the input buffer into the output buffer minus the newline. op = 1 for (ip = 1; ip <= maxch; ip = ip + 1) { if (inbuf[ip] == '\n' || inbuf[ip] == EOS) break outbuf[op] = inbuf[ip] op = op + 1 } # Add a blank. if (op <= maxch) { outbuf[op] = ' ' op = op + 1 } # Copy the two fields. op = op + gstrcpy (inbuf[xoffset], outbuf[op], min (maxch - op + 1, xwidth)) op = op + gstrcpy (inbuf[yoffset], outbuf[op], min (maxch - op + 1, ywidth)) # Add a newline. if (op <= maxch) { outbuf[op] = '\n' op = op + 1 } outbuf[op] = EOS end # LT_GET_NUM -- The field entry is converted from character to real or double # in preparation for the transformation. The number of significant # digits is counted and returned as an argument; the number of chars in # the number is returned as the function value. int procedure li_get_numr (linebuf, fval, nsdig) char linebuf[ARB] #I the input line buffer real fval #O the output floating point value int nsdig #O the number of significant digits char ch int nchar, ip int ctor(), stridx() begin ip = 1 nsdig = 0 nchar = ctor (linebuf, ip, fval) if (nchar == 0 || fval == INDEFR) return (nchar) # Skip leading white space. ip = 1 repeat { ch = linebuf[ip] if (! IS_WHITE(ch)) break ip = ip + 1 } # Count signifigant digits for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { if (stridx (ch, "eEdD") > 0) break if (IS_DIGIT (ch)) nsdig = nsdig + 1 ip = ip + 1 } return (nchar) end # LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed # fields are converted to strings; other fields are copied from # the input line to output buffer. procedure li_pack_liner (inbuf, outbuf, maxch, field_pos, nfields, xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer int field_pos[ARB] #I starting positions for the fields int nfields #I the number of fields int xfield #I the field number of the x coordinate column int yfield #I the field number of the y coordinate column real xt #I the transformed x coordinate real yt #I the transformed y coordinate char xformat[ARB] #I the output format for the x column char yformat[ARB] #I the output format for the y column int nsdig_x #I the number of significant digits in x int nsdig_y #I the number of significant digits in y int min_sigdigits #I the minimum number of significant digits int num_field, width, op pointer sp, field int gstrcpy() begin call smark (sp) call salloc (field, SZ_LINE, TY_CHAR) # Initialize output pointer. op = 1 do num_field = 1, nfields { width = field_pos[num_field + 1] - field_pos[num_field] if (num_field == xfield) { call li_format_fieldr (xt, Memc[field], maxch, xformat, nsdig_x, width, min_sigdigits) } else if (num_field == yfield) { call li_format_fieldr (yt, Memc[field], maxch, yformat, nsdig_y, width, min_sigdigits) } else { # Put "width" characters from inbuf into field call strcpy (inbuf[field_pos[num_field]], Memc[field], width) } # Fields must be delimited by at least one blank. if (num_field > 1 && !IS_WHITE (Memc[field])) { outbuf[op] = ' ' op = op + 1 } # Copy "field" to output buffer. op = op + gstrcpy (Memc[field], outbuf[op], maxch) } outbuf[op] = '\n' outbuf[op+1] = EOS call sfree (sp) end # LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed # fields are converted to strings and added to the end of the input buffer. procedure li_append_liner (inbuf, outbuf, maxch, xt, yt, xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer real xt #I the transformed x coordinate real yt #I the transformed y coordinate char xformat[ARB] #I the output format for the x column char yformat[ARB] #I the output format for the y column int nsdig_x #I the number of significant digits in x int nsdig_y #I the number of significant digits in y int min_sigdigits #I the minimum number of significant digits int ip, op pointer sp, field int gstrcpy() begin # Allocate some working space. call smark (sp) call salloc (field, SZ_LINE, TY_CHAR) # Copy the input buffer into the output buffer minus the newline. op = 1 for (ip = 1; ip <= maxch; ip = ip + 1) { if (inbuf[ip] == '\n' || inbuf[ip] == EOS) break outbuf[op] = inbuf[ip] op = op + 1 } # Add two blanks. op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) # Format and add the the two extra fields with a blank between. call li_format_fieldr (xt, Memc[field], SZ_LINE, xformat, nsdig_x, 0, min_sigdigits) op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) if (op <= maxch) { outbuf[op] = ' ' op = op + 1 } call li_format_fieldr (yt, Memc[field], SZ_LINE, yformat, nsdig_y, 0, min_sigdigits) op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) # Add a newline. if (op <= maxch) { outbuf[op] = '\n' op = op + 1 } outbuf[op] = EOS call sfree (sp) end # LI_FORMAT_FIELD -- A transformed coordinate is written into a string # buffer. The output field is of (at least) the same width and significance # as the input list entry. procedure li_format_fieldr (fval, wordbuf, maxch, format, nsdig, width, min_sigdigits) real fval #I the input value to be formatted char wordbuf[maxch] #O the output formatted string int maxch #I the maximum length of the output string char format[ARB] #I the output format int nsdig #I the number of sig-digits in current value int width #I the width of the curent field int min_sigdigits #I the minimum number of significant digits int fdigits, fwidth begin if (format[1] == EOS) { fdigits = max (min_sigdigits, nsdig) fwidth = max (width, fdigits + 1) call sprintf (wordbuf, maxch, "%*.*g") call pargi (fwidth) call pargi (fdigits) call pargr (fval) } else { call sprintf (wordbuf, maxch, format) call pargr (fval) } end # LT_GET_NUM -- The field entry is converted from character to real or double # in preparation for the transformation. The number of significant # digits is counted and returned as an argument; the number of chars in # the number is returned as the function value. int procedure li_get_numd (linebuf, fval, nsdig) char linebuf[ARB] #I the input line buffer double fval #O the output floating point value int nsdig #O the number of significant digits char ch int nchar, ip int ctod(), stridx() begin ip = 1 nsdig = 0 nchar = ctod (linebuf, ip, fval) if (nchar == 0 || fval == INDEFD) return (nchar) # Skip leading white space. ip = 1 repeat { ch = linebuf[ip] if (! IS_WHITE(ch)) break ip = ip + 1 } # Count signifigant digits for (; ! IS_WHITE(ch) && ch != '\n' && ch != EOS; ch=linebuf[ip]) { if (stridx (ch, "eEdD") > 0) break if (IS_DIGIT (ch)) nsdig = nsdig + 1 ip = ip + 1 } return (nchar) end # LI_PACK_LINE -- Fields are packed into the outbuf buffer. Transformed # fields are converted to strings; other fields are copied from # the input line to output buffer. procedure li_pack_lined (inbuf, outbuf, maxch, field_pos, nfields, xfield, yfield, xt, yt, xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer int field_pos[ARB] #I starting positions for the fields int nfields #I the number of fields int xfield #I the field number of the x coordinate column int yfield #I the field number of the y coordinate column double xt #I the transformed x coordinate double yt #I the transformed y coordinate char xformat[ARB] #I the output format for the x column char yformat[ARB] #I the output format for the y column int nsdig_x #I the number of significant digits in x int nsdig_y #I the number of significant digits in y int min_sigdigits #I the minimum number of significant digits int num_field, width, op pointer sp, field int gstrcpy() begin call smark (sp) call salloc (field, SZ_LINE, TY_CHAR) # Initialize output pointer. op = 1 do num_field = 1, nfields { width = field_pos[num_field + 1] - field_pos[num_field] if (num_field == xfield) { call li_format_fieldd (xt, Memc[field], maxch, xformat, nsdig_x, width, min_sigdigits) } else if (num_field == yfield) { call li_format_fieldd (yt, Memc[field], maxch, yformat, nsdig_y, width, min_sigdigits) } else { # Put "width" characters from inbuf into field call strcpy (inbuf[field_pos[num_field]], Memc[field], width) } # Fields must be delimited by at least one blank. if (num_field > 1 && !IS_WHITE (Memc[field])) { outbuf[op] = ' ' op = op + 1 } # Copy "field" to output buffer. op = op + gstrcpy (Memc[field], outbuf[op], maxch) } outbuf[op] = '\n' outbuf[op+1] = EOS call sfree (sp) end # LI_APPEND_LINE -- Fields are appened to the input buffer. Transformed # fields are converted to strings and added to the end of the input buffer. procedure li_append_lined (inbuf, outbuf, maxch, xt, yt, xformat, yformat, nsdig_x, nsdig_y, min_sigdigits) char inbuf[ARB] #I the input string buffer char outbuf[maxch] #O the output string buffer int maxch #I the maximum size of the output buffer double xt #I the transformed x coordinate double yt #I the transformed y coordinate char xformat[ARB] #I the output format for the x column char yformat[ARB] #I the output format for the y column int nsdig_x #I the number of significant digits in x int nsdig_y #I the number of significant digits in y int min_sigdigits #I the minimum number of significant digits int ip, op pointer sp, field int gstrcpy() begin # Allocate some working space. call smark (sp) call salloc (field, SZ_LINE, TY_CHAR) # Copy the input buffer into the output buffer minus the newline. op = 1 for (ip = 1; ip <= maxch; ip = ip + 1) { if (inbuf[ip] == '\n' || inbuf[ip] == EOS) break outbuf[op] = inbuf[ip] op = op + 1 } # Add two blanks. op = op + gstrcpy (" ", outbuf[op], maxch - op + 1) # Format and add the the two extra fields with a blank between. call li_format_fieldd (xt, Memc[field], SZ_LINE, xformat, nsdig_x, 0, min_sigdigits) op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) if (op <= maxch) { outbuf[op] = ' ' op = op + 1 } call li_format_fieldd (yt, Memc[field], SZ_LINE, yformat, nsdig_y, 0, min_sigdigits) op = op + gstrcpy (Memc[field], outbuf[op], maxch - op + 1) # Add a newline. if (op <= maxch) { outbuf[op] = '\n' op = op + 1 } outbuf[op] = EOS call sfree (sp) end # LI_FORMAT_FIELD -- A transformed coordinate is written into a string # buffer. The output field is of (at least) the same width and significance # as the input list entry. procedure li_format_fieldd (fval, wordbuf, maxch, format, nsdig, width, min_sigdigits) double fval #I the input value to be formatted char wordbuf[maxch] #O the output formatted string int maxch #I the maximum length of the output string char format[ARB] #I the output format int nsdig #I the number of sig-digits in current value int width #I the width of the curent field int min_sigdigits #I the minimum number of significant digits int fdigits, fwidth begin if (format[1] == EOS) { fdigits = max (min_sigdigits, nsdig) fwidth = max (width, fdigits + 1) call sprintf (wordbuf, maxch, "%*.*g") call pargi (fwidth) call pargi (fdigits) call pargd (fval) } else { call sprintf (wordbuf, maxch, format) call pargd (fval) } end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mapio.x������������������������������������������������������������������0000664�0000000�0000000�00000022240�13321663143�0016053�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include define MAP_LENSTR 99 # Length of strings # Map data structure. define MAP_LEN 64 # Length of map structure define MAP_NAME Memc[P2C($1)] # Name of map define MAP_TYPE Memi[$1+51] # Type of map define MAP_MAP Memi[$1+52] # Structure pointer define MAP_COPY Memi[$1+53] # Data buffer for copy define MAP_NC Memi[$1+54] # Number of columns define MAP_NL Memi[$1+55] # Number of columns define MAP_SAMPLE Memi[$1+56] # Sample size for lines define MAP_BUF Memi[$1+57] # Data buffer for constant or sampling define MAP_BUF1 Memi[$1+58] # Data buffer for sampling define MAP_BUF2 Memi[$1+59] # Data buffer for sampling define MAP_LINE1 Memi[$1+60] # Sampling line number define MAP_LINE2 Memi[$1+61] # Sampling line number define MAP_LASTLINE Memi[$1+62] # Last line define MAP_LASTBUF Memi[$1+63] # Data buffer last returned # Types of maps allowed. define MAP_CONST 1 # Constant define MAP_IMAGE 2 # Image define MAP_GSURFIT 3 # GSURFIT # MAP_GLR -- Get a line of map data. pointer procedure map_glr (map, line, mode) pointer map #I Map pointer int line #I Line int mode #I Access mode (READ_ONLY, READ_WRITE) int i, nc, nl, sample, line1, line2 real a, b pointer buf, buf1, buf2, mim_glr(), mgs_glr() errchk malloc, mim_glr, mgs_glr begin # Check for repeated request. if (line == MAP_LASTLINE(map)) { buf = MAP_LASTBUF(map) if (mode == READ_WRITE) { nc = MAP_NC(map) if (MAP_COPY(map) == NULL) call malloc (MAP_COPY(map), nc, TY_REAL) call amovr (Memr[buf], Memr[MAP_COPY(map)], nc) buf = MAP_COPY(map) } return (buf) } nc = MAP_NC(map) nl = MAP_NL(map) sample = MAP_SAMPLE(map) # Check for subsampling. A constant map will never be sampled. if (sample > 1) { if (MAP_BUF1(map) == NULL) { call malloc (MAP_BUF(map), nc, TY_REAL) call malloc (MAP_BUF1(map), nc, TY_REAL) call malloc (MAP_BUF2(map), nc, TY_REAL) } line1 = (line-1) / sample * sample + 1 line2 = min (nl, line1 + sample) buf1 = MAP_BUF1(map) buf2 = MAP_BUF2(map) if (line1 == MAP_LINE2(map)) { MAP_BUF2(map) = buf1 MAP_BUF1(map) = buf2 MAP_LINE2(map) = MAP_LINE1(map) MAP_LINE1(map) = line1 buf1 = MAP_BUF1(map) buf2 = MAP_BUF2(map) } else if (line2 == MAP_LINE1(map)) { MAP_BUF1(map) = buf2 MAP_BUF2(map) = buf1 MAP_LINE1(map) = MAP_LINE2(map) MAP_LINE2(map) = line2 buf1 = MAP_BUF1(map) buf2 = MAP_BUF2(map) } if (line1 != MAP_LINE1(map)) { switch (MAP_TYPE(map)) { case MAP_IMAGE: buf = mim_glr (MAP_MAP(map), line1) case MAP_GSURFIT: buf = mgs_glr (MAP_MAP(map), line1) } call amovr (Memr[buf], Memr[buf1], nc) MAP_LINE1(map) = line1 } if (line2 != MAP_LINE2(map)) { switch (MAP_TYPE(map)) { case MAP_IMAGE: buf = mim_glr (MAP_MAP(map), line2) case MAP_GSURFIT: buf = mgs_glr (MAP_MAP(map), line2) } call amovr (Memr[buf], Memr[buf2], nc) MAP_LINE2(map) = line2 } if (line == line1) buf = buf1 else if (line == line2) buf = buf2 else { buf = MAP_BUF(map) b = real (line - line1) / sample a = 1 - b do i = 0, nc-1 Memr[buf+i] = a * Memr[buf1+i] + b * Memr[buf2+i] } } else { switch (MAP_TYPE(map)) { case MAP_IMAGE: buf = mim_glr (MAP_MAP(map), line) case MAP_GSURFIT: buf = mgs_glr (MAP_MAP(map), line) case MAP_CONST: buf = MAP_BUF(map) } } MAP_LASTLINE(map) = line MAP_LASTBUF(map) = buf # Make a copy which might be modified by the caller. if (mode == READ_WRITE) { nc = MAP_NC(map) if (MAP_COPY(map) == NULL) call malloc (MAP_COPY(map), nc, TY_REAL) call amovr (Memr[buf], Memr[MAP_COPY(map)], nc) buf = MAP_COPY(map) } return (buf) end # MAP_OPEN -- Open map. Return NULL if no map is found. pointer procedure map_open (name, refim) char name[ARB] #I Name pointer refim #I Reference image pointer map #O Map pointer returned int i, nc, nl, nowhite(), ctor() real const pointer sp, mapstr, im, gs, immap(), mim_open(), mgs_open() errchk calloc, malloc, imgstr, mim_open, mgs_open begin call smark (sp) call salloc (mapstr, SZ_FNAME, TY_CHAR) i = 1 nc = IM_LEN(refim,1) nl = IM_LEN(refim,2) call calloc (map, MAP_LEN, TY_STRUCT) MAP_NC(map) = nc MAP_NL(map) = nl iferr { # Check for missing map name, and keyword redirection. if (nowhite (name, Memc[mapstr], SZ_FNAME) == 0) call error (1, "No map specified") if (Memc[mapstr] == '!') call imgstr (refim, Memc[mapstr+1], Memc[mapstr], SZ_FNAME) call strcpy (Memc[mapstr], MAP_NAME(map), MAP_LENSTR) ifnoerr (im = immap (MAP_NAME(map), READ_ONLY, 0)) { call imunmap (im) MAP_TYPE(map) = MAP_IMAGE MAP_MAP(map) = mim_open (MAP_NAME(map), refim) } else ifnoerr (call mgs_ggs (refim, MAP_NAME(map), gs)) { MAP_TYPE(map) = MAP_GSURFIT MAP_MAP(map) = mgs_open (MAP_NAME(map), refim, gs) } else if (ctor (MAP_NAME(map), i, const) > 0) { MAP_TYPE(map) = MAP_CONST call malloc (MAP_BUF(map), nc, TY_REAL) call amovkr (const, Memr[MAP_BUF(map)], nc) } else { call mfree (map, TY_STRUCT) call sprintf (Memc[mapstr], SZ_FNAME, "Can't open map (%s)") call pargstr (name) call error (2, Memc[mapstr]) } } then { call map_close (map) call erract (EA_ERROR) } call sfree (sp) return (map) end # MAP_OPENGS -- Open GSURFIT map given the GSURFIT pointer. pointer procedure map_opengs (gs, refim) pointer gs #I GSURFIT pointer pointer refim #I Reference image pointer map #O Map pointer returned pointer mgs_open() errchk calloc, mgs_open begin iferr { call calloc (map, MAP_LEN, TY_STRUCT) MAP_NC(map) = IM_LEN(refim,1) MAP_NL(map) = IM_LEN(refim,2) MAP_TYPE(map) = MAP_GSURFIT MAP_MAP(map) = mgs_open (MAP_NAME(map), refim, gs) } then { call map_close (map) call erract (EA_ERROR) } return (map) end # MAP_CLOSE -- Unmap map structure. procedure map_close (map) pointer map #I Map pointer begin if (map == NULL) return switch (MAP_TYPE(map)) { case MAP_IMAGE: call mim_close (MAP_MAP(map)) case MAP_GSURFIT: call mgs_close (MAP_MAP(map)) } call mfree (MAP_COPY(map), TY_REAL) call mfree (MAP_BUF(map), TY_REAL) call mfree (MAP_BUF1(map), TY_REAL) call mfree (MAP_BUF2(map), TY_REAL) call mfree (map, TY_STRUCT) end # MAP_GETS -- Get string parameter. procedure map_gets (map, param, val, maxchar) pointer map #I Map pointer char param[ARB] #I Parameter char val[ARB] #O Parameter string value int maxchar #I Maximum number of characters to return bool streq() errchk mim_gets(), mgs_gets() begin if (streq (param, "mapname")) call strcpy (MAP_NAME(map), val, maxchar) else { switch (MAP_TYPE(map)) { case MAP_IMAGE: call mim_gets (MAP_MAP(map), param, val, maxchar) case MAP_GSURFIT: call mgs_gets (MAP_MAP(map), param, val, maxchar) default: call error (1, "map_gets: unknown parameter") } } end # MAP_GETI -- Get integer parameter. procedure map_geti (map, param, val) pointer map #I Map pointer char param[ARB] #I Parameter int val #O Value errchk mim_geti(), mgs_geti() begin switch (MAP_TYPE(map)) { case MAP_IMAGE: call mim_geti (MAP_MAP(map), param, val) case MAP_GSURFIT: call mgs_geti (MAP_MAP(map), param, val) default: call error (1, "map_geti: unknown parameter") } end # MAP_GETR -- Get real parameter. procedure map_getr (map, param, val) pointer map #I Map pointer char param[ARB] #I Parameter real val #O Value bool streq() errchk mim_getr(), mgs_getr() begin if (streq (param, "constant")) { if (MAP_TYPE(map) == MAP_CONST) { val = Memr[MAP_BUF(map)] return } else call error (1, "map_getr: map is not constant") } switch (MAP_TYPE(map)) { case MAP_IMAGE: call mim_getr (MAP_MAP(map), param, val) case MAP_GSURFIT: call mgs_getr (MAP_MAP(map), param, val) default: call error (1, "map_getr: unknown parameter") } end # MAP_SETI -- Set integer parameter. procedure map_seti (map, param, val) pointer map #I Map pointer char param[ARB] #I Parameter int val #I Value bool streq() errchk mim_seti(), mgs_seti begin switch (MAP_TYPE(map)) { case MAP_CONST: ; case MAP_IMAGE: if (streq (param, "sample")) MAP_SAMPLE(map) = max (1, val) else call mim_seti (MAP_MAP(map), param, val) case MAP_GSURFIT: if (streq (param, "sample")) MAP_SAMPLE(map) = max (1, val) else call mgs_seti (MAP_MAP(map), param, val) } end # MAP_SETR -- Set real parameter. procedure map_setr (map, param, val) pointer map #I Map pointer char param[ARB] #I Parameter real val #I Value errchk mim_setr(), mgs_setr begin switch (MAP_TYPE(map)) { case MAP_IMAGE: call mim_setr (MAP_MAP(map), param, val) case MAP_GSURFIT: call mgs_setr (MAP_MAP(map), param, val) default: call error (1, "map_setr: unknown parameter") } end # MAP_SETS -- Set string parameter. procedure map_sets (map, param, val) pointer map #I Map pointer char param[ARB] #I Parameter char val[ARB] #I Value errchk mim_sets(), mgs_sets begin switch (MAP_TYPE(map)) { case MAP_IMAGE: call mim_sets (MAP_MAP(map), param, val) case MAP_GSURFIT: call mgs_sets (MAP_MAP(map), param, val) default: call error (1, "map_sets: unknown parameter") } end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mgs.x��������������������������������������������������������������������0000664�0000000�0000000�00000014325�13321663143�0015541�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include # Data structure. define MGS_SZNAME 99 # Length of mgs name string define MGS_LEN 56 # Length of structure define MGS_GS Memi[$1] # GSURFIT pointer define MGS_X Memi[$1+1] # Pointer to line of x values define MGS_Y Memi[$1+2] # Pointer to line of y values define MGS_Z Memi[$1+3] # Pointer to line of z values define MGS_NC Memi[$1+4] # Number of columns define MGS_REFIM Memi[$1+5] # Reference image pointer define MGS_NAME Memc[P2C($1+6)] # Map name # MGS_GLR -- Get a line of data. pointer procedure mgs_glr (mgs, line) pointer mgs #I Map pointer int line #I Line int nc pointer x, y, z, gs begin if (mgs == NULL) call error (1, "Map is undefined") gs = MGS_GS(mgs) x = MGS_X(mgs) y = MGS_Y(mgs) z = MGS_Z(mgs) nc = MGS_NC(mgs) call amovkr (real(line), Memr[y], nc) call gsvector (gs, Memr[x], Memr[y], Memr[z], nc) return (z) end # MGS_OPEN -- Open mgs. pointer procedure mgs_open (name, refim, gsin) char name[ARB] #I Name pointer refim #I Reference image pointer gsin #I GSURFIT pointer pointer mgs #O Map pointer returned int i, nc, nl real gsgetr() pointer gs errchk mgs_ggs begin nc = IM_LEN(refim,1) nl = IM_LEN(refim,2) call calloc (mgs, MGS_LEN, TY_STRUCT) MGS_REFIM(mgs) = refim call strcpy (name, MGS_NAME(mgs), MGS_SZNAME) MGS_NC(mgs) = nc iferr { gs = gsin if (gs == NULL) { call mgs_ggs (refim, name, gs) MGS_GS(mgs) = gs } if (1 < gsgetr (gs, GSXMIN) || nc > gsgetr (gs, GSXMAX) || 1 < gsgetr (gs, GSYMIN) || nl > gsgetr (gs, GSYMAX)) call error (2, "Map and data images have different sizes") MGS_GS(mgs) = gs call malloc (MGS_X(mgs), nc, TY_REAL) call malloc (MGS_Y(mgs), nc, TY_REAL) call malloc (MGS_Z(mgs), nc, TY_REAL) do i = 1, nc Memr[MGS_X(mgs)+i-1] = i } then { call mgs_close (mgs) call erract (EA_ERROR) } return (mgs) end # MGS_CLOSE -- Close mgs. procedure mgs_close (mgs) pointer mgs #I Map pointer begin if (mgs == NULL) return if (MGS_GS(mgs) != NULL) call gsfree (MGS_GS(mgs)) call mfree (MGS_X(mgs), TY_REAL) call mfree (MGS_Y(mgs), TY_REAL) call mfree (MGS_Z(mgs), TY_REAL) call mfree (mgs, TY_STRUCT) end # MGS_GETS -- Get string parameter. procedure mgs_gets (mgs, param, val, maxchar) pointer mgs #I Map pointer char param[ARB] #I Parameter char val[ARB] #O Parameter string value int maxchar #I Maximum number of characters to return begin call error (1, "mgs_gets: unknown parameter") end # MGS_SETS -- Set string parameter. procedure mgs_sets (mgs, param, val) pointer mgs #I Map pointer char param[ARB] #I Parameter char val[ARB] #O Parameter string value begin call error (1, "mgs_sets: unknown parameter") end # MGS_GETI -- Get integer parameter. procedure mgs_geti (mgs, param, val) pointer mgs #I Map pointer char param[ARB] #I Parameter int val #O Value bool streq() begin if (streq (param, "gsurfit")) val = MGS_GS(mgs) else call error (1, "mgs_geti: unknown parameter") end # MGS_SETI -- Set integer parameter. procedure mgs_seti (mgs, param, val) pointer mgs #I Map pointer char param[ARB] #I Parameter int val #I Value bool streq() begin if (streq (param, "gsurfit")) { call mgs_pgs (MGS_REFIM(mgs), MGS_NAME(mgs), val) call gsfree (MGS_GS(mgs)) MGS_GS(mgs) = val } else call error (1, "mgs_seti: unknown parameter") end # MGS_GETR -- Get real parameter. procedure mgs_getr (mgs, param, val) pointer mgs #I Map pointer char param[ARB] #I Parameter real val #O Value begin call error (1, "mgs_getr: unknown parameter") end # MGS_SETR -- Set real parameter. procedure mgs_setr (mgs, param, val) pointer mgs #I Map pointer char param[ARB] #I Parameter real val #I Value begin call error (1, "mgs_setr: unknown parameter") end # MAP_PGS -- Put mgs surface fit. procedure mgs_pgs (im, key, gs) pointer im #I Image pointer char key[ARB] #I Keyword root pointer gs #I Surface fit pointer int i, nc, fd, gsgeti(), stropen() pointer sp, kw, card, coeffs, strbuf, cp, cp1, cp2 begin if (IM_SECTUSED(im) == YES) return call smark (sp) call salloc (kw, 80, TY_CHAR) call salloc (card, 68, TY_CHAR) nc = gsgeti (gs, GSNSAVE) call salloc (coeffs, nc, TY_REAL) call gssave (gs, Memr[coeffs]) # Convert coeffs to a string. Last character will be space. call salloc (strbuf, 20*nc, TY_CHAR) call aclrc (Memc[strbuf], 20*nc) fd = stropen (Memc[strbuf], 20*nc, WRITE_ONLY) do i = 1, nc { call fprintf (fd, "%g ") call pargr (Memr[coeffs+i-1]) } call close (fd) i = 1 cp1 = strbuf for (cp=cp1; Memc[cp] != EOS; cp=cp+1) { if (Memc[cp] == ' ') cp2 = cp if (cp - cp1 + 1 == 68) { call sprintf (Memc[kw], 8, "%.6s%02d") call pargstr (key) call pargi (i) i = i + 1 Memc[cp2] = EOS call imastr (im, Memc[kw], Memc[cp1]) cp1 = cp2 + 1 cp = cp1 } } if (cp - cp1 + 1 > 0) { call sprintf (Memc[kw], 8, "%.6s%02d") call pargstr (key) call pargi (i) i = i + 1 Memc[cp2] = EOS call imastr (im, Memc[kw], Memc[cp1]) } repeat { call sprintf (Memc[kw], 8, "%.6s%02d") call pargstr (key) call pargi (i) i = i + 1 iferr (call imdelf (im, Memc[kw])) break } call sfree (sp) end # MAP_GGS -- Get mgs surface fit. procedure mgs_ggs (im, key, gs) pointer im #I Image pointer char key[ARB] #I Keyword root pointer gs #O Surface fit pointer int i, j, nc, ctor() pointer sp, kw, card, coeffs begin if (IM_SECTUSED(im) == YES) call error (1, "No surface fit with an image section") call smark (sp) call salloc (kw, 8, TY_CHAR) call salloc (card, 68, TY_CHAR) call malloc (coeffs, 100, TY_REAL) iferr { nc = 0 do i = 1, ARB { call sprintf (Memc[kw], 8, "%.6s%02d") call pargstr (key) call pargi (i) iferr (call imgstr (im, Memc[kw], Memc[card], 68)) break j = 1 while (ctor (Memc[card], j, Memr[coeffs+nc]) != 0) { nc = nc + 1 if (mod (nc, 100) == 0) call realloc (coeffs, nc+100, TY_REAL) } } if (nc == 0) call error (1, "Surface fit not found") call gsrestore (gs, Memr[coeffs]) call mfree (coeffs, TY_REAL) } then { call mfree (coeffs, TY_REAL) call erract (EA_ERROR) } call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mim.x��������������������������������������������������������������������0000664�0000000�0000000�00000035373�13321663143�0015543�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MIM (Match IMage) -- Match a 2D image to a 2D reference image. # # These routines provide an I/O interface to get data from a 2D image which # matches a line of a 2D reference image. The two common uses are to get a # subraster of the image which matches the reference image and to interpolate # an image which is blocked to a lower resolution than the reference image. # The matching is done in physical pixel coordinates. It is completely # general in allowing any linear transformation between the physical # coordinates. But in most cases the reference image and the input image # will be related either by an image section or some kind of blocking factor # without rotation. Any relative rotation of the two in physical pixels is # likely to be slow for large images (either the reference image or the mim # image). Interpolation (if any is required) is done with the MSI library. # Extrapolation outside of the input image uses the nearest edge value. # # mim = mim_open (input, refim) # buf = mim_glr (mim, refline) # mim_close (mim) # # Parameters may be queried and set by the following routines. # # mim_geti (mim, param, val) # mim_getr (mim, param, val) # mim_gets (mim, param, str, maxchar) # mim_seti (mim, param, val) # mim_setr (mim, param, val) # mim_sets (mim, param, str) # # The parameters are specified by strings as given below. The default values # are in parentheses. Currently there are only integer parameters. # # msitype - interpolation type defined by the MSI library # (II_BISPLINE3) # msiedge - number of additional lines at each edge to include # in interpolation (3) # msimax - maximum number of pixels to allow in MSIFIT calls (500000) include include include include # Data structure. define MIM_LEN 18 define MIM_INTERP Memi[$1] # Use interpolation? define MIM_ROTATE Memi[$1+1] # Is there any rotation? define MIM_IM Memi[$1+2] # IMIO mim pointer define MIM_MSI Memi[$1+3] # MSI interpolation pointer define MIM_NCREF Memi[$1+4] # Number of columns in ref image define MIM_NC Memi[$1+5] # Number of columns in input image define MIM_NL Memi[$1+6] # Number of lines in input image define MIM_LINE1 Memi[$1+7] # First line in msi fit define MIM_LINE2 Memi[$1+8] # Last line in msi fit define MIM_X Memi[$1+9] # Pointer to line of x values define MIM_Y Memi[$1+10] # Pointer to line of y values define MIM_Z Memi[$1+11] # Pointer to line of z values define MIM_MW Memi[$1+12] # MWCS pointer define MIM_CT Memi[$1+13] # CT from ref logical to input logical define MIM_MSITYPE Memi[$1+14] # MSI interpolation type define MIM_MSIEDGE Memi[$1+15] # Number of edge pixels to reserve define MIM_MSIMAX Memi[$1+16] # Maximum number of pixels in msi fit define MIM_DELETE Memi[$1+17] # Delete image after closing? # Defaults define MIM_MSITYPEDEF II_BISPLINE3 define MIM_MSIEDGEDEF 3 define MIM_MSIMAXDEF 500000 # MIM_GL -- Get a line of data matching a line of the reference image. # A pointer to the data is returned. The data buffer is assumed to be # read-only and not to be modified by the calling routine. pointer procedure mim_glr (mim, line) pointer mim #I Map pointer int line #I Reference image line int i, j, nc, nl, ncref, line1, line2, nlines pointer msi, ct, x, y, z, imname, ptr real rnl, val real mw_c1tranr() pointer imgl2r(), imgs2r() errchk imgl2r, msiinit, msifit, imdelete begin if (mim == NULL) call error (1, "Map is undefined") # If interpolation is not needed return the IMIO buffer. if (MIM_INTERP(mim) == NO) { ptr = imgl2r (MIM_IM(mim), line) return (ptr) } nc = MIM_NC(mim) nl = MIM_NL(mim) ncref = MIM_NCREF(mim) rnl = nl msi = MIM_MSI(mim) ct = MIM_CT(mim) x = MIM_X(mim) y = MIM_Y(mim) z = MIM_Z(mim) # Set the interpolation coordinates in the input image logical pixels. # This is limited to be within the input image. Therefore, requests # outside the input image will use the nearest edge value. # Also set the minimum range of input lines required. if (MIM_ROTATE(mim) == NO) { val = mw_c1tranr (ct, real(line)) val = max (1., min (rnl, val)) call amovkr (val, Memr[y], ncref) line1 = max (1., val - 1) line2 = min (rnl, val + 1) } else { call amovkr (real(line), Memr[y], ncref) call mw_v2tranr (ct, Memr[x], Memr[y], Memr[z], Memr[y], ncref) x = z # Limit the x range to within the input image. ptr = x val = nc do i = 1, ncref { Memr[ptr] = max (1., min (val, Memr[ptr])) ptr = ptr + 1 } # Limit the y range to within the input image and find the range # of lines required. j = nint (Memr[y]) line1 = max (1, min (nl, j)) line2 = line1 ptr = y rnl = nl do i = 1, ncref { val = max (1., min (rnl, Memr[ptr])) j = nint (val) line1 = min (j, line1) line2 = max (j, line2) Memr[ptr] = val ptr = ptr + 1 } line1 = max (1, line1 - 1) line2 = min (nl, line2 + 1) } # Set or reset image interpolator. For small input interpolation # images read the entire image, fit the interpolator, and free the # image. For larger input images determine the range of lines # required including edge space and fit the interpolator to those # lines. Providing the reference lines are requested sequentially # this is about as efficient as we can make it. if (line1 < MIM_LINE1(mim) || line2 > MIM_LINE2(mim)) { if (msi != NULL) call msifree (MIM_MSI(mim)) if (min (nc, nl) > 3) call msiinit (MIM_MSI(mim), MIM_MSITYPE(mim)) else if (min (nc, nl) > 1) call msiinit (MIM_MSI(mim), II_BILINEAR) else call msiinit (MIM_MSI(mim), II_BINEAREST) msi = MIM_MSI(mim) if (nc * nl <= MIM_MSIMAX(mim)) { nlines = nl line1 = 1 line2 = nlines ptr = imgs2r (MIM_IM(mim), 1, nc, line1, line2) call msifit (msi, Memr[ptr], nc, nlines, nc) if (MIM_DELETE(mim) == YES) { call malloc (imname, SZ_FNAME, TY_CHAR) call imstats (MIM_IM(mim), IM_IMAGENAME, Memc[imname], SZ_FNAME) call imgimage (Memc[imname], Memc[imname], SZ_FNAME) call imunmap (MIM_IM(mim)) call imdelete (Memc[imname]) call mfree (imname, TY_CHAR) } else call imunmap (MIM_IM(mim)) } else { nlines = max (2*MIM_MSIEDGE(mim)+(line2-line1+1), MIM_MSIMAX(mim) / nc) line1 = max (1, min (nl, line1 - MIM_MSIEDGE(mim))) line2 = max (1, min (nl, line1 + nlines - 1)) line1 = max (1, min (nl, line2 - nlines + 1)) nlines = line2 - line1 + 1 ptr = imgs2r (MIM_IM(mim), 1, nc, line1, line2) call msifit (msi, Memr[ptr], nc, nlines, nc) } MIM_LINE1(mim) = line1 MIM_LINE2(mim) = line2 } # Interpolate input image to a line in the reference image. call msivector (msi, Memr[x], Memr[y], Memr[z], ncref) return (z) end # MIM_OPEN -- Open an image matched to a reference image. # # Fitting of any interpolator is later. This allows calls to reset # the interpolation type, edge buffer, and maximum size to fit. pointer procedure mim_open (input, refim) char input[ARB] #I Input image name pointer refim #I Reference image pointer mim #O Map pointer returned bool interp, rotate int i, nc, nl, ncref, nlref, ilt[6] double lt[6], ltref[6], ltin[6] pointer sp, section, im, mw, ct, x, ptr int strlen(), btoi() pointer immap(), mw_openim(), mw_sctran() errchk calloc, malloc errchk immap errchk mw_openim, mw_invertd, mw_sctran begin call smark (sp) call salloc (section, SZ_FNAME, TY_CHAR) iferr { mim = NULL; im = NULL; mw = NULL call calloc (mim, MIM_LEN, TY_STRUCT) MIM_DELETE(mim) = NO call imgimage (input, Memc[section], SZ_FNAME) ptr = immap (Memc[section], READ_ONLY, 0); im = ptr nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncref = IM_LEN(refim,1) nlref = IM_LEN(refim,2) # Check relationship between reference and input images in physical # coordinates. ptr = mw_openim (refim); mw = ptr call mw_gltermd (mw, lt, lt[5], 2) call mw_close (mw) mw = mw_openim (im) call mw_gltermd (mw, ltin, ltin[5], 2) # Combine lterms. call mw_invertd (lt, ltref, 2) call mw_mmuld (ltref, ltin, lt, 2) call mw_vmuld (lt, lt[5], lt[5], 2) lt[5] = ltin[5] - lt[5] lt[6] = ltin[6] - lt[6] do i = 1, 6 lt[i] = nint (1D6 * lt[i]) / 1D6 # Check if interpolation is required. interp = false do i = 1, 6 { ilt[i] = nint (lt[i]) if (lt[i] - ilt[i] > 1D-3) { interp = true break } } if (lt[2] != 0. || lt[3] != 0.) rotate = true else rotate = false if (!interp && rotate) interp = true if (interp) { # Use IMIO to extract a smaller section if possible to # minimize the requirements for the interpolation. # This could be more general if we deal with a section # of a rotated image. if (!rotate) { ilt[1] = lt[1] + lt[5] ilt[2] = lt[1] * ncref + lt[5] + 0.999 ilt[3] = lt[3] + lt[4] + lt[6] ilt[4] = lt[4] * nlref + lt[6] + 0.999 ilt[1] = max (1, min (nc, ilt[1])) ilt[2] = max (1, min (nc, ilt[2])) ilt[3] = max (1, min (nl, ilt[3])) ilt[4] = max (1, min (nl, ilt[4])) if (ilt[1]!=1 || ilt[2]!=nc ||ilt[1]!=1 || ilt[2]!=nl) { i = strlen(Memc[section]) + 1 call sprintf (Memc[section+i-1], SZ_FNAME-i, "[%d:%d,%d:%d]") call pargi (ilt[1]) call pargi (ilt[2]) call pargi (ilt[3]) call pargi (ilt[4]) call imunmap (im) im = immap (Memc[section], READ_ONLY, 0) nc = IM_LEN(im,1) nl = IM_LEN(im,2) lt[5] = lt[5] - ilt[1] + 1 lt[6] = lt[6] - ilt[3] + 1 } } # Set reference logical to input logical transformation. # The reference logical coordinates are the physical # coordinates of the transformation. call mw_sltermd (mw, lt, lt[5], 2) # If there are cross terms set the x array to the reference # logical coordinates (physical transformation coordinates). # Otherwise we only need to evalute x array once in the # input logical coordinates to be interpolated. call malloc (x, ncref, TY_REAL) do i = 1, ncref Memr[x+i-1] = i if (rotate) ct = mw_sctran (mw, "physical", "logical", 3B) else { ct = mw_sctran (mw, "physical", "logical", 1B) call mw_v1tranr (ct, Memr[x], Memr[x], ncref) ptr = x do i = 1, ncref { Memr[ptr] = max (1., min (real(nc), Memr[ptr])) ptr = ptr + 1 } call mw_ctfree (ct) ct = mw_sctran (mw, "physical", "logical", 2B) } MIM_X(mim) = x call malloc (MIM_Y(mim), ncref, TY_REAL) call malloc (MIM_Z(mim), ncref, TY_REAL) MIM_MW(mim) = mw MIM_CT(mim) = ct MIM_MSITYPE(mim) = MIM_MSITYPEDEF MIM_MSIEDGE(mim) = MIM_MSIEDGEDEF MIM_MSIMAX(mim) = MIM_MSIMAXDEF } else { # If ref is a subraster of the input use IMIO section to match. if (ilt[1]!=1 || ilt[4]!=1 || ilt[5]!=0 || ilt[6]!=0) { i = strlen(Memc[section]) + 1 call sprintf (Memc[section+i-1], SZ_FNAME-i, "[%d:%d:%d,%d:%d:%d]") call pargi (ilt[1]+ilt[5]) call pargi (ilt[1]*ncref+ilt[5]) call pargi (ilt[1]) call pargi (ilt[4]+ilt[6]) call pargi (ilt[4]*nlref+ilt[6]) call pargi (ilt[4]) call imunmap (im) im = immap (Memc[section], READ_ONLY, 0) nc = IM_LEN(im,1) nl = IM_LEN(im,2) } call mw_close (mw) } MIM_IM(mim) = im MIM_INTERP(mim) = btoi (interp) MIM_ROTATE(mim) = btoi (rotate) MIM_NC(mim) = nc MIM_NL(mim) = nl MIM_NCREF(mim) = ncref } then { if (mw != NULL) call mw_close (mw) if (im != NULL) call imunmap (im) call mim_close (mim) call sfree (sp) call erract (EA_ERROR) } call sfree (sp) return (mim) end # MIM_CLOSE -- Close mim structure. procedure mim_close (mim) pointer mim #I MIM pointer pointer imname errchk imdelete begin if (mim == NULL) return if (MIM_IM(mim) != NULL) { if (MIM_DELETE(mim) == YES) { call malloc (imname, SZ_FNAME, TY_CHAR) call imstats (MIM_IM(mim), IM_IMAGENAME, Memc[imname], SZ_FNAME) call imgimage (Memc[imname], Memc[imname], SZ_FNAME) call imunmap (MIM_IM(mim)) call imdelete (Memc[imname]) call mfree (imname, TY_CHAR) } else call imunmap (MIM_IM(mim)) } if (MIM_MSI(mim) != NULL) call msifree (MIM_MSI(mim)) if (MIM_MW(mim) != NULL) call mw_close (MIM_MW(mim)) call mfree (MIM_X(mim), TY_REAL) call mfree (MIM_Y(mim), TY_REAL) call mfree (MIM_Z(mim), TY_REAL) call mfree (mim, TY_STRUCT) end # MIM_GETS -- Get string parameter. procedure mim_gets (mim, param, val, maxchar) pointer mim #I MIM pointer char param[ARB] #I Parameter char val[ARB] #O Parameter string value int maxchar #I Maximum number of characters to return begin call error (1, "mim_gets: unknown parameter") end # MIM_GETI -- Get integer parameter. procedure mim_geti (mim, param, val) pointer mim #I MIM pointer char param[ARB] #I Parameter int val #O Value bool streq() begin if (streq (param, "msitype")) val = MIM_MSITYPE(mim) else if (streq (param, "msiedge")) val = MIM_MSIEDGE(mim) else if (streq (param, "msimax")) val = MIM_MSIMAX(mim) else if (streq (param, "delete")) val = MIM_DELETE(mim) else call error (1, "mim_geti: unknown parameter") end # MIM_GETR -- Get real parameter. procedure mim_getr (mim, param, val) pointer mim #I MIM pointer char param[ARB] #I Parameter real val #O Value begin call error (1, "mim_getr: unknown parameter") end # MIM_SETS -- Set string parameter. procedure mim_sets (mim, param, val) pointer mim #I MIM pointer char param[ARB] #I Parameter char val[ARB] #I Value begin call error (1, "mim_sets: unknown parameter") end # MIM_SETI -- Set integer parameter. procedure mim_seti (mim, param, val) pointer mim #I MIM pointer char param[ARB] #I Parameter int val #I Value bool streq() begin if (streq (param, "msitype")) { if (val != MIM_MSITYPE(mim)) { MIM_MSITYPE(mim) = val if (MIM_MSI(mim) != NULL) { call msifree (MIM_MSI(mim)) MIM_LINE1(mim) = 0 MIM_LINE2(mim) = 0 } } } else if (streq (param, "msiedge")) { if (val != max (3, MIM_MSIEDGE(mim))) { MIM_MSIEDGE(mim) = val if (MIM_MSI(mim) != NULL) { call msifree (MIM_MSI(mim)) MIM_LINE1(mim) = 0 MIM_LINE2(mim) = 0 } } } else if (streq (param, "msimax")) { if (val != max (64000, MIM_MSIMAX(mim))) { MIM_MSIMAX(mim) = val if (MIM_MSI(mim) != NULL) { call msifree (MIM_MSI(mim)) MIM_LINE1(mim) = 0 MIM_LINE2(mim) = 0 } } } else if (streq (param, "delete")) MIM_DELETE(mim) = val else call error (1, "mim_setr: unknown parameter") end # MIM_SETR -- Set real parameter. procedure mim_setr (mim, param, val) pointer mim #I MIM pointer char param[ARB] #I Parameter real val #I Value begin call error (1, "mim_setr: unknown parameter") end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mkfits.cl����������������������������������������������������������������0000664�0000000�0000000�00000002371�13321663143�0016375�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MKFITS -- Make Mosaic FITS file from a set of images. # # This is a template program that can be expanded as needed. # For example the header data file could contain other information. # The "imtype" variable must be set to "fits" as is the case for the # MSCRED package. procedure mkfits (images, mosaic) string images = "" {prompt="Images to be converted"} string mosaic = "" {prompt="Mosaic file to be created"} file header = "" {prompt="Header data"} bool delete = no {prompt="Delete converted images?"} struct *fd1, *fd2 begin file imlist string mos, image, ext, detsec imlist = mktemp ("tmp$iraf") # Set input. sections (images, option="root", > imlist) mos = mosaic fd2 = header # Check the mosaic does not exist. if (imaccess(mos)) error (1, "Mosaic file already exists ("//mos//")") # Read through input list appending the images. fd1 = imlist while (fscan (fd1, image) != EOF) { if (fscan (fd2, ext, detsec) != 2) error (2, "Bad format in header file "//header) imcopy (image, mos//"["//ext//",append,inherit]", verbose=verbose) hedit (mos//"["//ext//"]", "detsec", detsec, add+, del-, update+, verify-, show-) if (delete) imdelete (image, verify-) } fd1 = ""; delete (imlist, verify=no) fd2 = "" end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mkmsc.par����������������������������������������������������������������0000664�0000000�0000000�00000000257�13321663143�0016377�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,List of input images output,s,a,,,,List of output mosaic MEF files description,f,h,mscred$lib/mkmsc/quad.dat,,,Description file verbose,b,h,yes,,,Verbose output? �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mkpkg��������������������������������������������������������������������0000664�0000000�0000000�00000005236�13321663143�0015617�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Make MSCRED Package. $call lmscred $call relink $exit update: $call update@ccdred $call update@mscdisplay $call update@mscfinder $call relink $call install ; relink: $checkout x_mscred.o mscbin$ $omake x_mscred.x $link x_mscred.o -lmscred -lxtools -lcurfit \ -lgsurfit -lslalib -lsurfit -liminterp -o xx_mscred.e $checkin x_mscred.o mscbin$ ; install: $move xx_mscred.e mscbin$x_mscred.e ; lmscred: $checkout libmscred.a mscbin$ $update libmscred.a $checkin libmscred.a mscbin$ ; lccdred: $call lccdred@ccdred ; lcombine: $call lcombine@ccdred ; lmscdisp: $call lmscdisp@mscdisplay ; limexam: $call limexam@mscdisplay ; lsf: $call lsf@mscdisplay ; lfinder: $call lfinder@mscfinder ; generic: $set GEN = "$$generic -k" $ifolder (liststr.x, liststr.gx) $(GEN) liststr.gx -o liststr.x $endif $ifolder (rgstr.x, rgstr.gx) $(GEN) rgstr.gx -o rgstr.x $endif $ifolder (xtalk.x, xtalk.gx) $(GEN) xtalk.gx -o xtalk.x $endif $ifolder (patblk.x, patblk.gx) $(GEN) patblk.gx -o patblk.x $endif ; libmscred.a: @curfit @imsurfit $ifeq (USE_GENERIC, yes) $call generic $endif ccdsection.x ccsetwcs.x skywcs.h liststr.x mapio.x mgs.x mim.x mscwcs.x patblk.x rgstr.x skywcs.x skywcsdef.h\ skywcs.h t_addkey.x t_fitscopy.x t_getcatalog.x t_imext.x t_imstat.x imstat.h t_jlists.x t_mkmsc.x t_msccmatch.x t_mscctran.x \ t_mscext.x t_mscgmask.x t_mscimatch.x \ t_mscpmask.x t_msctmplt.x t_mscuniq.x t_mscwcs.x t_patfit.x t_pixarea.x t_pupilfit.x \ t_toshort.x t_xlog.x t_xtalkcor.x t_xtcoeff.x \ xtalk.x xtmaskname.x ; ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscagetcat.cl������������������������������������������������������������0000664�0000000�0000000�00000002122�13321663143�0017205�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCAGETCAT -- Interface to ASTCAT.AGETCAT. procedure mscagetcat (output, catalog, ra, dec, rawidth, decwidth) file output {prompt="Output list"} string catalog {prompt="Catalog"} string ra {prompt="RA[J2000] (hours)"} string dec {prompt="DEC[J2000] (degrees)"} real rawidth {prompt="RA width (minutes)"} real decwidth {prompt="DEC width (minutes)"} string fields = "ra,dec,mag1,mag2,mag3" {prompt="Catalog fields"} file catdb = "mscsrc$catdb.dat" {prompt="Catalog database"} begin agetcat ("pars", output, catalogs=catalog, standard=no, update=no, verbose=no, catdb=catdb, aregpars="", rcra=ra, rcdec=dec, rrawidth=rawidth, rdecwidth=decwidth, rcsystem="J2000", rcraunits="hours", rcdecunits="degrees", filter=yes, afiltpars="", fsort="", freverse=no, fexpr="yes", fields=fields, fnames="", fntypes="", fnunits="", fnformats="", fosystem="J2000", fira="ra", fidec="dec", foraunits="hours", fodecunits="degrees", foraformat="%.3h", fodecformat="%.2h", fixp="xp", fiyp="yp", fixc="xc", fiyc="yc", foxformat="%10.3f", foyformat="%10.3f") end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscarith.cl��������������������������������������������������������������0000664�0000000�0000000�00000014526�13321663143�0016717�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCARITH -- Image arithmetic on multiextension Mosaic files. procedure mcsarith (operand1, op, operand2, result) string operand1 {prompt="Operand image or numerical constant"} string op {prompt="Operator", enum="+|-|*|/|min|max"} string operand2 {prompt="Operand image or numerical constant"} string result {prompt="Resultant image"} string extname = "" {prompt="Extension names to select"} string title = "" {prompt="Title for resultant image"} real divzero = 0. {prompt="Replacement value for division by zero"} string hparams = "" {prompt="List of header parameters"} string pixtype = "" {prompt="Pixel type for resultant image"} string calctype = "" {prompt="Calculation data type"} bool verbose = no {prompt="Print operations?"} bool noact = no {prompt="Print operations without performing them?\n"} struct *fd1, *fd2, *fd3 begin bool mef1, mef2 file op1list, op2list, reslist, op1exts, op2exts, resexts file out, opval1, opval2, result1 string op1, optype, op2, hp int nop1, nop2, nresult, next1, next2, nexts, n real ccdmean cache sections, mscextensions op1list = mktemp ("tmp$iraf") op2list = mktemp ("tmp$iraf") reslist = mktemp ("tmp$iraf") op1exts = mktemp ("tmp$iraf") op2exts = mktemp ("tmp$iraf") resexts = mktemp ("tmp$iraf") ccdmean = 0. # Get input query parameters. Expand operand and result lists. sections (operand1, option="fullname", > op1list); nop1 = sections.nimages optype = op sections (operand2, option="fullname", > op2list) nop2 = sections.nimages sections (result, option="fullname", > reslist) nresult = sections.nimages # Check for correct lists. if (nresult<1 || (nop1!=nresult&&nop1!=1) || (nop2!=nresult&&nop2!=1)) goto listerr # Create each output file. fd1 = op1list fd2 = op2list fd3 = reslist while (fscan (fd3, out) != EOF) { n = strlen (out) if (substr (out, n-4, n) == ".fits") out = substr (out, 1, n-5) # Expand the operand files into a list of extensions. hp = "" next1 = INDEF n = fscan (fd1, opval1) if (imaccess (opval1)) { n = strlen (opval1) if (substr (opval1, n-4, n) == ".fits") opval1 = substr (opval1, 1, n-5) mscextensions (opval1, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > op1exts) next1 = mscextensions.nimages mef1 = mscextensions.imext if (next1 < 1) goto exterr nexts = next1 op1 = "@" // op1exts if (next1 > 1) { hselect (op1, "ccdmean", yes) | scan (ccdmean) if (nscan() > 0) { hedit (op1, "ccdmntmp", "(ccdmean)", add+, del-, verify-, show-, update+) if (hp == "") hp = "ccdmntmp,"//hparams } } } else op1 = opval1 next2 = INDEF n = fscan (fd2, opval2) if (imaccess (opval2)) { n = strlen (opval2) if (substr (opval2, n-4, n) == ".fits") opval2 = substr (opval2, 1, n-5) mscextensions (opval2, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > op2exts) next2 = mscextensions.nimages mef2 = mscextensions.imext if (next2 < 1 || (next1 != INDEF && next2 != next1)) goto exterr nexts = next2 op2 = "@" // op2exts if (next2 > 1) { hselect (op2, "ccdmean", yes) | scan (ccdmean) if (nscan() > 0) { hedit (op2, "ccdmntmp", "(ccdmean)", add+, del-, verify-, show-, update+) if (hp == "") hp = "ccdmntmp,"//hparams } } } else op2 = opval2 # Allow output to be the same as one of the input operands. if ((out == opval1 || out == opval2) && !noact) result1 = mktemp ("tmp") else result1 = out # Create the global output header. if (imaccess (opval1)) { if (!noact && mef1) imcopy (opval1//"[0]", result1, verbose-) } else if (imaccess (opval2)) { if (!noact && mef2) imcopy (opval2//"[0]", result1, verbose-) } else goto listerr if (imaccess (result1)) hedit (result1, "ccdmean,ccdmeant", add-, addonly-, del+, verify-, show-, update+) # Create the output extension list. if (imaccess (result1) || noact) { for (n=1; n<=nexts; n=n+1) print (result1//"[inherit]", >> resexts) } else print (result1, >> resexts) # Do the arithmetic. if (hp == "") imarith (op1, optype, op2, "@"//resexts, title=title, divzero=divzero, hparams=hparams, pixtype=pixtype, calctype=calctype, verbose=verbose, noact=noact) else imarith (op1, optype, op2, "@"//resexts, title=title, divzero=divzero, hparams=hp, pixtype=pixtype, calctype=calctype, verbose=verbose, noact=noact) delete (resexts, verify-, >& "dev$null") mscextensions (result1, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > resexts) if (nexts > 1) { hselect (op1, "ccdmntmp", yes) | scan (ccdmean) if (nscan() > 0) { hedit ("@"//resexts, "ccdmean", "(ccdmntmp)", add+, del-, update+, show-, verify-) hedit ("@"//resexts, "ccdmntmp,ccdmeant", add-, addonly-, del+, update+, show-, verify-) } } # Delete temporary lists. delete (op1exts, verify-, >& "dev$null") delete (op2exts, verify-, >& "dev$null") delete (resexts, verify-, >& "dev$null") # If the result is the same as an input replace the input. if (imaccess (result1)) { if (out == opval1) { imdelete (opval1, verify-) if (defvar (opval1)) imrename (result1, "./"//opval1, verbose-) else imrename (result1, opval1, verbose-) } else if (out == opval2) { imdelete (opval2, verify-) if (defvar (opval2)) imrename (result1, "./"//opval2, verbose-) else imrename (result1, opval2, verbose-) } } } fd1 = ""; delete (op1list, verify-) fd2 = ""; delete (op2list, verify-) fd3 = ""; delete (reslist, verify-) return listerr: fd1 = ""; delete (op1list, verify-) fd2 = ""; delete (op2list, verify-) fd3 = ""; delete (reslist, verify-) delete (op1exts, verify-, >& "dev$null") delete (op2exts, verify-, >& "dev$null") delete (resexts, verify-, >& "dev$null") error (1, "Error in operand and result lists") exterr: fd1 = ""; delete (op1list, verify-) fd2 = ""; delete (op2list, verify-) fd3 = ""; delete (reslist, verify-) delete (op1exts, verify-, >& "dev$null") delete (op2exts, verify-, >& "dev$null") delete (resexts, verify-, >& "dev$null") error (1, "Error in number of extensions") end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscblkavg.cl�������������������������������������������������������������0000664�0000000�0000000�00000011674�13321663143�0017057�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCBLKAVG -- Block average mosaic exposures # This task updates RDNOISE, GAIN, CCDSUM, DATASEC, BIASSEC, TRIMSEC, and # CCDSEC. It assumes the physical coordinate system corresponds to the CCD # coordinate sytem. The LTM and LTV keywords are updated by BLKAVG. This # task does not update DETSEC or AMPSEC. It excludes partial pixels at the # edges of the data, bias, and trim section. In this case CCDSEC may change # slightly and DETSEC and AMPSEC would be wrong. procedure mcsblkavg (input, output, nc, nl) string input {prompt="Input mosaic exposures"} string output {prompt="Output mosaic exposures"} int nc=2 {prompt="Column blocking factor", min=1} int nl=2 {prompt="Line blocking factor", min=1} bool verbose=no {prompt="Verbose output"} struct *fd, *fd2 begin int nim, nc1, nl1, c1, c2, l1, l2, naxis1, naxis2 real x1, x2, y1, y2, rdnoise, gain file list1, list2 string in, out, out1 struct str cache sections list1 = mktemp ("tmp$iraf") list2 = mktemp ("tmp$iraf") # Expand input and output lists. sections (input, option="fullname", > list2) nim = sections.nimages sections (output, option="fullname") | joinlines (list2, "STDIN", output=list1, delim=" ", maxchars=161, verbose-) delete (list2, verify-) if (sections.nimages != nim) { delete (list1, verify-) error (1, "Input and output lists do not match") } # Get remaining query parameters. nc1 = nc nl1 = nl # Process list of exposures. fd = list1 while (fscan (fd, in, out) != EOF) { if (in != out && imaccess (out//"[0]")) { printf ("WARNING: Output %s exists, skipping input %s\n", out, in) next } printf ("blkavg $input $output %d %d option=average\n", nc1, nl1) | scan (str) if (verbose) printf ("mscblkavg %s %s %d %d\n", in, out, nc1, nl1) # Block average. msccmd (str, in, out, verbose-) # Update header. msccmd ("hselect $input $I,rdnoise,gain, yes", out, verb-, > list2) fd2 = list2 while (fscan (fd2, out1, rdnoise, gain) != EOF) { if (nscan() != 3) next rdnoise = rdnoise / sqrt (nc1*nl1) gain = gain / (nc1*nl1) hedit (out1, "rdnoise", rdnoise, add+, del-, update+, verify-, show=verbose) hedit (out1, "gain", gain, add+, del-, update+, verify-, show=verbose) } fd2 = ""; delete (list2, verify-) msccmd ("hselect $input $I,ccdsum, yes", out, verb-, > list2) fd2 = list2 while (fscan (fd2, out1, str) != EOF) { if (nscan() != 2) next if (fscan (str, c1, l1) != 2) next c1 = nc1 * c1 l1 = nl1 * l1 printf ("%d %d\n", c1, l1) | scan (str) hedit (out1, "ccdsum", str, add+, del-, update+, verify-, show=verbose) } fd2 = ""; delete (list2, verify-) msccmd ("hselect $input $I,naxis1,naxis2,datasec, yes", out, verb-, > list2) fd2 = list2 while (fscan (fd2, out1, naxis1, naxis2, str) != EOF) { if (nscan() != 4) next if (fscanf (str, "[%d:%d,%d:%d]", c1, c2, l1, l2) != 4) { c1 = 1 l1 = 1 c2 = naxis1 l2 = naxis2 } else { c1 = (c1 + nc1 - 2) / nc1 + 1 c2 = (c2 - nc1) / nc1 + 1 l1 = (l1 + nl1 - 2) / nl1 + 1 l2 = (l2 - nl1) / nl1 + 1 printf ("[%d:%d,%d:%d]\n", c1, c2, l1, l2) | scan (str) hedit (out1, "datasec", str, add+, del-, update+, verify-, show=verbose) } x1 = c1 - 0.499 x2 = c2 + 0.499 y1 = l1 - 0.499 y2 = l2 + 0.499 print (x1, y1) | mscctran ("STDIN", "STDOUT", out1, "logical", "physical", formats="", min=7, verbose-) | scan (x1, y1) c1 = nint (x1) l1 = nint (y1) print (x2, y2) | mscctran ("STDIN", "STDOUT", out1, "logical", "physical", formats="", min=7, verbose-) | scan (x2, y2) c2 = nint (x2) l2 = nint (y2) printf ("[%d:%d,%d:%d]\n", c1, c2, l1, l2) | scan (str) hedit (out1, "ccdsec", str, add+, del-, update+, verify-, show=verbose) } fd2 = ""; delete (list2, verify-) msccmd ("hselect $input $I,biassec, yes", out, verb-, > list2) fd2 = list2 while (fscan (fd2, out1, str) != EOF) { if (nscan() != 2) next if (fscanf (str, "[%d:%d,%d:%d]", c1, c2, l1, l2) != 4) next c1 = (c1 + nc1 - 2) / nc1 + 1 c2 = (c2 - nc1) / nc1 + 1 l1 = (l1 + nl1 - 2) / nl1 + 1 l2 = (l2 - nl1) / nl1 + 1 printf ("[%d:%d,%d:%d]\n", c1, c2, l1, l2) | scan (str) hedit (out1, "biassec", str, add+, del-, update+, verify-, show=verbose) } fd2 = ""; delete (list2, verify-) msccmd ("hselect $input $I,trimsec, yes", out, verb-, > list2) fd2 = list2 while (fscan (fd2, out1, str) != EOF) { if (nscan() != 2) next if (fscanf (str, "[%d:%d,%d:%d]", c1, c2, l1, l2) != 4) next c1 = (c1 + nc1 - 2) / nc1 + 1 c2 = (c2 - nc1) / nc1 + 1 l1 = (l1 + nl1 - 2) / nl1 + 1 l2 = (l2 - nl1) / nl1 + 1 printf ("[%d:%d,%d:%d]\n", c1, c2, l1, l2) | scan (str) hedit (out1, "trimsec", str, add+, del-, update+, verify-, show=verbose) } fd2 = ""; delete (list2, verify-) } fd = ""; delete (list1, verify-) end ��������������������������������������������������������������������mscred-5.05-2018.07.09/src/msccmatch.par������������������������������������������������������������0000664�0000000�0000000�00000002225�13321663143�0017224�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,List of input mosaic exposures coords,s,a,"",,,Coordinate file (ra/dec) outcoords,f,h,"",,,List of updated coordinate files usebpm,b,h,yes,,,Use bad pixel masks? verbose,b,h,yes,,,"Verbose? # Coarse Search" nsearch,i,h,50,,,Maximum number of positions to use in search search,r,h,0.,0.,,Translation search radius (arcsec) rsearch,r,h,0.,0.,,"Rotation search radius (deg) # Fine Centroiding" cbox,i,h,11,5,,Centering box (pixels) maxshift,r,h,5,,,Maximum centering shift to accept (arcsec) csig,r,h,0.1,,,Maximum centering uncertainty to accept (arcsec) cfrac,r,h,0.5,0.,1.,Minimum fraction of accepted centers listcoords,b,h,yes,,,"List centered coordinates in verbose mode? # WCS Fitting" nfit,i,h,4,,,Min for fit (>0) or max not found (<=0) rms,r,h,2.,0.,,Maximum fit RMS to accept (arcsec) fitgeometry,s,h,"general","shift|xyscale|rotate|rscale|rxyscale|general",,Fitting geometry reject,r,h,3.,,,Fitting rejection limit (sigma) update,b,h,yes,,,Update coordinate systems? interactive,b,h,yes,,,Interactive? fit,b,h,yes,,,Interactive fitting? graphics,s,h,"stdgraph",,,Graphics device cursor,s,h,"",,,"Graphics cursor " accept,b,q,yes,,,Accept solution? ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/msccmd.cl����������������������������������������������������������������0000664�0000000�0000000�00000013277�13321663143�0016355�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCCMD -- Execute commands on each image extension of a multiextension file. procedure msccmd (command, input, output) string command {prompt="Command"} string input {prompt="Input files"} string in2 = "" {prompt="Second list of input files", mode="q"} string output {prompt="Output files"} string extname = "" {prompt="Extension names"} string ikparams = "" {prompt="Image kernel parameters\n"} bool alist = no {prompt="Do all extensions as one list?"} bool flist = yes {prompt="Do all extensions in one file as one list?"} bool dataless = no {prompt="Include dataless image headers?"} bool verbose = no {prompt="List commands to be executed?"} bool exec = yes {prompt="Execute commands?\n"} string prompt {prompt="msccmd", mode="q"} struct *fd1, *fd2, *fd3, *fd4, *fd5, *fd6, *fd7 begin bool mef, doinput file temp1, temp2, temp3, temp4, temp5, temp6, temp7, temp8 file infile, outfile, in, out, infile2, op2, dummy string cmd, cmd1 int idx1, idx2, idx3 cache mscextensions temp1 = mktemp ("tmp$iraf") temp2 = mktemp ("tmp$iraf") temp3 = mktemp ("tmp$iraf") temp4 = mktemp ("tmp$iraf") temp5 = mktemp ("tmp$iraf") temp6 = mktemp ("tmp$iraf") temp7 = mktemp ("tmp$iraf") temp8 = mktemp ("tmp$iraf") if ($nargs == 0) { if (mode == "h") cmd = command else { prompt = "" cmd = prompt } } else cmd = command while (!(cmd=="q" || cmd=="quit")) { if (fscan (cmd, cmd1) == 0) goto newcmd if (!deftask (cmd1)) { printf ("WARNING: Unknown task name `%s'\n", cmd1) goto newcmd } doinput = no idx1 = 1 idx2 = idx1 + stridx ("$", cmd) - 1 idx3 = strlen (cmd) while (idx2 >= idx1) { if (substr (cmd, idx2, idx2+5) == "$input") { doinput = yes break } idx1 = idx2 + 1 if (idx1 < idx3) { cmd1 = substr (cmd, idx1, idx3) idx2 = idx1 + stridx ("$", cmd1) - 1 } } if (!doinput) { print (cmd) | cl goto newcmd } if (alist) print (input, > temp1) else sections (input, option="fullname", > temp1) fd1 = temp1 while (fscan (fd1, infile) != EOF) { infile2 = "" out = "" if (alist || flist) { mscextensions (infile, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, dataless=dataless, ikparams=ikparams, > temp4) print ("@"//temp4, > temp3) } else mscextensions (infile, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, dataless=dataless, ikparams=ikparams, > temp3) mef = mscextensions.imext fd3 = temp3 while (fscan (fd3, in) != EOF) { cmd1 = "" idx1 = 1 idx2 = idx1 + stridx ("$", cmd) - 1 idx3 = strlen (cmd) while (idx2 >= idx1) { cmd1 = cmd1 // substr (cmd, idx1, idx2-1) if (substr (cmd, idx2, idx2+5) == "$input") { cmd1 = cmd1 // in idx1 = idx2 + 6 } else if (substr (cmd, idx2, idx2+6) == "$output") { if (!access (temp2)) { sections (output, option="fullname", > temp2) fd2 = temp2 } if (out == "") { if (fscan (fd2, outfile) == EOF) error (1, "Error in output list") if (outfile == infile) out = mktemp ("tmp") else out = outfile } if (!imaccess (out) && mef) imcopy (infile//"[0]", out, verbose-) if (alist || flist) { fd7 = temp4; touch (temp8) while (fscan (fd7, dummy) != EOF) print (out//"[inherit]", >> temp8) fd7 = "" cmd1 = cmd1 // "@" // temp8 } else cmd1 = cmd1 // out // "[inherit]" idx1 = idx2 + 7 } else if (substr (cmd, idx2, idx2+3) == "$in2") { if (!access (temp5)) { if (alist) print (in2, > temp5) else sections (in2, option="fullname", > temp5) fd4 = temp5 } if (infile2 == "") { if (fscan (fd4, infile2) == EOF) error (1, "Error in in2 list") if (alist || flist) { mscextensions (infile2, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, dataless=dataless, ikparams=ikparams, > temp7) print ("@"//temp7, > temp6) } else mscextensions (infile2, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, dataless=dataless, ikparams=ikparams, > temp6) fd5 = temp6 } if (fscan (fd5, op2) == EOF) error (1, "Error in operand2 list") cmd1 = cmd1 // op2 idx1 = idx2 + 4 } else { cmd1 = cmd1 // "$" idx1 = idx2 + 1 } idx2 = idx1 + stridx ("$", substr (cmd, idx1, idx3)) - 1 } cmd1 = cmd1 // substr (cmd, idx1, idx3) if (verbose) { print (cmd1) if (access (temp4)) { printf ("%s:\n", temp4) type (temp4) } if (access (temp7)) { printf ("%s:\n", temp7) type (temp7) } if (access (temp8)) { printf ("%s:\n", temp8) type (temp8) } } if (exec) print (cmd1) | cl } if (access (temp3)) { fd3 = ""; delete (temp3, verify-) if (access (temp4)) delete (temp4, verify-) } if (access (temp6)) { fd5 = ""; delete (temp6, verify-) if (access (temp7)) delete (temp7, verify-) } if (access (temp8)) delete (temp8, verify-) if (out != "" && outfile == infile && imaccess (out)) { imdelete (infile, verify-) if (defvar (outfile)) imrename (out, "./"//outfile, verbose-) else imrename (out, outfile, verbose-) } } if (access (temp5)) {fd4 = ""; delete (temp5, verify-)} if (access (temp2)) {fd2 = ""; delete (temp2, verify-)} if (access (temp1)) {fd1 = ""; delete (temp1, verify-)} newcmd: if ($nargs > 0 || mode == "h") break prompt = "" cmd = prompt } end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/msccntr.cl���������������������������������������������������������������0000664�0000000�0000000�00000002701�13321663143�0016546�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCCNTR -- Use apphot.center to centroid. # # The coords parameter is both the input initial coordinates and the output # centered coordinates. procedure msccntr (image, coords) file image {prompt="Input image"} file coords {prompt="Coordinates"} int cbox = 11 {prompt="Centering box (pixels)"} real maxshift = 2 {prompt="Maximum center shift (pixels)"} string noise = "poisson" {prompt="Noise model"} string ccdread = "" {prompt="Read noise keyword"} string gain = "" {prompt="Gain keyword"} real readnoise = 0. {prompt="Read noise value"} real epadu = 1. {prompt="Gain value"} begin file im, crds, tmp im = image crds = coords tmp = mktemp ("tmp$iraf") # Center the input coordinates to the temporary database file. apphot.center (im, coords=crds, output=tmp, datapars="", centerpars="", cbox=cbox, maxshift=maxshift, plotfile="", interactive-, verify-, verbose-, calgorithm="centroid", cthreshold=0., minsnratio=0., cmaxiter=10, clean=no, mkcenter=no, scale=1., emission=yes, sigma=INDEF, datamin=INDEF, datamax=INDEF, noise=noise, ccdread=ccdread, gain=gain, readnoise=readnoise, epadu=epadu, exposure="", airmass="", filter="", obstime="", itime=1., xairmass=INDEF, ifilter="INDEF", otime="INDEF") # Extract the centered coordinates from the database. delete (crds, verify-) txdump (tmp, "xcenter,ycenter,xshift,yshift,xerr,yerr,cier,cerror", yes, headers-, parameters-, > crds) delete (tmp, verify-) end ���������������������������������������������������������������mscred-5.05-2018.07.09/src/msccpars.par�������������������������������������������������������������0000664�0000000�0000000�00000001234�13321663143�0017074�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCCPARS calgorithm,s,h,"centroid","|centroid|gauss|none|ofilter|",,Centering algorithm cbox,r,h,3.0,,,Centering box width in scale units cthreshold,r,h,0.0,,,Centering threshold in sigma above background minsnratio,r,h,1.0,0.0,,Minimum signal-to-noise ratio for centering algorithm cmaxiter,i,h,10,,,Maximum number of iterations for centering algorithm maxshift,r,h,1.0,,,Maximum center shift in scale units clean,b,h,no,,,Symmetry clean before centering ? rclean,r,h,1.0,,,Cleaning radius in scale units rclip,r,h,2.0,,,Clipping radius in scale units kclean,r,h,3.0,,,Rejection limit in sigma mkcenter,b,h,no,,,Mark the computed center on display ? mode,s,h,'ql' ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscctran.cl��������������������������������������������������������������0000664�0000000�0000000�00000007560�13321663143�0016717�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCCTRAN -- Coordinate transformations using plate solution but using # reference coordinate from the image. The plate solution is specified by # the header keyword WCSSOL giving the database filename and the record # name. The plate solution is assumed to be in the physical coordinate # system of the image. Input and output pixel coordinates are in logical # coordinates which are converted to physical coordinates for transformation # by the plate solution. Input and output celestial coordinates are ra in # hours on axis 1 and dec in degrees on axis 2. procedure mscctran (input, output, image, forward) file input {prompt="Input coordinate file"} file output {prompt="Output coordinate file"} file image {prompt="Input image"} bool forward = yes {prompt="Logical to world?"} int xcolumn = 1 {prompt="Input column for ra/longitude/x coordinates"} int ycolumn = 2 {prompt="Input column for dec/latitude/y coordinates"} string lngformat = "" {prompt="Output format of ra/longitude/x coordinates"} string latformat = "" {prompt="Output format of dec/latitude/x coordinates"} int min_sigdigit = 7 {prompt="Minimum precision of the output coordinates"} bool wcssol = yes {prompt="Use WCS plate solution?"} struct *fd begin file in, out, im, database, db bool fwd struct wcsstruct string cols, fmts, sol, key, value, wcs real crval1, crval2 int n in = input out = output im = image fwd = forward db = mktemp ("tmp$iraf") # Columns and formats for WCSCTRAN cols = xcolumn // " " // ycolumn fmts = lngformat // " " // latformat # Set the plate solution if requested. database = "" if (wcssol) { hselect (im, "wcssol", yes) | scan (wcsstruct) if (fscan (wcsstruct, database, sol) == 2) { if (access (database) == NO) { printf ("Warning: WCS database `%s' not found.", database) printf (" Using header WCS.\n") database = "" } } else database = "" } # Coordinate transform without a plate solution. if (database == "") { if (fwd) { wcsctran (in, "STDOUT", im, "logical", "world", columns=cols, units="", formats="%.4H %.3h", min_sigdigit=min_sigdigit, verbose=no) | wcsctran ("STDIN", out, im, "world", "world", columns=cols, units="native native", formats=fmts, min_sigdigit=min_sigdigit, verbose=no) } else { wcsctran (in, out, im, "world", "logical", columns=cols, units="hours native", formats=fmts, min_sigdigit=min_sigdigit, verbose=no) } return } # Coordinate transform with a plate solution. fd = database while (fscan (fd, key, value) != EOF) { if (key != "begin") next if (value != sol) next printf ("%s\t%s\n", key, value, > db) break } if (access (db) == NO) error (1, "plate solution not found") # Copy and modify the plate solution. hselect (im, "crval1,crval2", yes) | scan (crval1, crval2) crval1 = crval1 / 15. while (fscan (fd, key, value) != EOF) { if (key == "begin") break else if (key == "lngref") printf ("%s\t%g\n", key, crval1, >> db) else if (key == "latref") printf ("%s\t%g\n", key, crval2, >> db) else printf ("%s\t%s\n", key, value, >> db) } fd = "" # Transform the coordinates. wcs = "physical" if (fwd) { wcsctran (in, "STDOUT", im, "logical", wcs, columns=cols, units="", formats="", min_sigdigit=min_sigdigit, verbose=no) | cctran ("STDIN", out, db, sol, geometry="geometric", forward=yes, xcolumn=xcolumn, ycolumn=ycolumn, lngunits="", latunits="", lngformat=lngformat, latformat=latformat, min_sigdigit=min_sigdigit) } else { cctran (in, "STDOUT", db, sol, geometry="geometric", forward=no, xcolumn=xcolumn, ycolumn=ycolumn, lngunits="", latunits="", lngformat="", latformat="", min_sigdigit=min_sigdigit) | wcsctran ("STDIN", out, im, wcs, "logical", columns=cols, units="", formats=fmts, min_sigdigit=min_sigdigit, verbose=no) } delete (db, verify-) end ������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscctran.par�������������������������������������������������������������0000664�0000000�0000000�00000001140�13321663143�0017067�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parameter file for the MSCTRAN task. input,s,a,"",,,The input coordinate files output,s,a,"",,,The output coordinate files image,f,a,"",,,The input images inwcs,s,a,"logical","|logical|tv|physical|world|astrometry|",,The input coordinate system outwcs,s,a,"world","|logical|tv|physical|world|astrometry|",,The output coordinate system columns,s,h,"1 2 3 4 5 6 7",,,List of input file columns units,s,h,"",,,List of input coordinate units formats,s,h,"",,,List of output coordinate formats min_sigdigits,i,h,7,,,Minimum precision of output coordinates verbose,b,h,yes,,,Write comments to the output file ? ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/��������������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0016725�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/ampinfo.par���������������������������������������������������0000664�0000000�0000000�00000000375�13321663143�0021067�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������amplist,s,h,"11 12 21 22",,,List of amplifier names or keyword containing this offset,s,h,"",,,List of Zero offset values (ADU) or keyword gain,s,h,"",,,List of gain values (e-/ADU) or keyword dark,s,h,"",,,List of dark count rates (ADU/sec) or keyword �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/evvexpr.com���������������������������������������������������0000664�0000000�0000000�00000000633�13321663143�0021126�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# EVVEXPR common. pointer ev_oval # pointer to expr value operand int ev_st # symbol table int ev_getop # user supplied get operand procedure int ev_getop_data # client data for above int ev_ufcn # user supplied function call procedure int ev_ufcn_data # client data for above int ev_flags # flag bits common /xvvcom/ ev_oval, ev_st, ev_getop, ev_getop_data, ev_ufcn, ev_ufcn_data, ev_flags �����������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/evvexpr.x�����������������������������������������������������0000664�0000000�0000000�00000374272�13321663143�0020634�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include .help evvexpr .nf -------------------------------------------------------------------------- EVVEXPR.GY -- Generic XYacc source for a general vector expression evaluator. o = evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) evvfree (o) Client callbacks: getop (client_data, opname, out) ufcn (client_data, fcn, args, nargs, out) here "out" is the output operand returned to EVVEXPR. Client_data is any arbitrary integer or pointer value passed in to EVVEXPR when by the client when the callback was registered. "args" is an array of operand structs, the arguments for the user function being called. If the operand or function call cannot be completed normally an error exit may be made (call error) or an invalid operand may be returned (O_TYPE set to 0). The client should not free the "args" input operands, this will be handled by EVVEXPR. Operand struct (lib$evvexpr.h): struct operand { int O_TYPE # operand type (bcsilrd) int O_LEN # operand length (0=scalar) int O_FLAGS # O_FREEVAL, O_FREEOP union { char* O_VALC # string short O_VALS int O_VALI # int or bool long O_VALL real O_VALR double O_VALD pointer O_VALP # vector data } } The macro O_VALC references the string value of a TY_CHAR operand. The flags are O_FREEVAL and O_FREEOP, which tell EVVEXPR and EVVFREE whether or not to free any vector operand array or the operand struct when the operand is freed. The client should set these flags on operands returned to EVVEXPR if it wants EVVEXPR to free any operand storage. Supported types are bool, char (string), and SILRD. Bool is indicated as TY_BOOL in the O_TYPE field of the operand struct, but is stored internally as an integer and the value field of a boolean operand is given by O_VALI. Operands may be either scalars or vectors. A vector is indicated by a O_LEN value greater than zero. For vector operands O_VALP points to the data array. A special case is TY_CHAR (string), in which case O_LEN is the allocated length of the EOS-terminated string. A string is logically a scalar value even though it is physically stored in the operand as a character vector. The trig functions operate upon angles in units of radians. The intrinsic functions RAD and DEG are available for converting between radians and degrees. A string can be coerced to a binary value and vice versa, using the INT, STR, etc. intrinsic functions. This is a generalization of the older EVEXPR routine, adding additional datatypes, support for vector operands, and numerous minor enhancements. .endhelp --------------------------------------------------------------------- define YYMAXDEPTH 64 # parser stack length define MAX_ARGS 17 # max args in a function call define yyparse xvv_parse # Arglist structure. define LEN_ARGSTRUCT (1+MAX_ARGS+(MAX_ARGS*LEN_OPERAND)) define A_NARGS Memi[$1] # number of arguments define A_ARGP Memi[$1+$2] # array of pointers to operand structs define A_OPS ($1+MAX_ARGS+1) # offset to operand storage area # Intrinsic functions. define LEN_STAB 300 # for symbol table define LEN_SBUF 256 define LEN_INDEX 97 define LEN_SYM 1 # symbol data define SYM_CODE Memi[$1] define KEYWORDS "|abs|acos|asin|atan|atan2|bool|cos|cosh|deg|double|\ |exp|hiv|int|len|log|log10|long|lov|max|mean|median|\ |min|mod|nint|rad|real|repl|stddev|shift|short|sin|\ |sinh|sort|sqrt|str|sum|tan|tanh|" define F_ABS 01 # function codes define F_ACOS 02 define F_ASIN 03 define F_ATAN 04 define F_ATAN2 05 define F_BOOL 06 define F_COS 07 define F_COSH 08 define F_DEG 09 # radians to degrees define F_DOUBLE 10 # newline 11 define F_EXP 12 define F_HIV 13 # high value define F_INT 14 define F_LEN 15 # vector length define F_LOG 16 define F_LOG10 17 define F_LONG 18 define F_LOV 19 # low value define F_MAX 20 define F_MEAN 21 define F_MEDIAN 22 # newline 23 define F_MIN 24 define F_MOD 25 define F_NINT 26 define F_RAD 27 # degrees to radians define F_REAL 28 define F_REPL 29 # replicate define F_STDDEV 30 # standard deviation define F_SHIFT 31 define F_SHORT 32 define F_SIN 33 # newline 34 define F_SINH 35 define F_SORT 36 # sort define F_SQRT 37 # square root define F_STR 38 define F_SUM 39 define F_TAN 40 define F_TANH 41 define T_B TY_BOOL define T_C TY_CHAR define T_S TY_SHORT define T_I TY_INT define T_L TY_LONG define T_R TY_REAL define T_D TY_DOUBLE # EVVEXPR -- Evaluate a general mixed type vector expression. Input consists # of the expression to be evaluated (a string) and, optionally, user # procedures for fetching external operands and executing external functions. # Output is a pointer to an operand structure containing the computed value of # the expression. The output operand structure is dynamically allocated by # EVVEXPR and must be freed by the user. # # NOTE: this is not intended to be an especially efficient procedure. Rather, # this is a high level, easy to use procedure, intended to provide greater # flexibility in the parameterization of applications programs. The main # inefficiency is that, since compilation and execution are not broken out as # separate steps, when the routine is repeatedly called to evaluate the same # expression with different data, all the compile time computation (parsing # etc.) has to be repeated. pointer procedure evvexpr (expr, getop, getop_data, ufcn, ufcn_data, flags) char expr[ARB] #I expression to be evaluated int getop #I user supplied get operand procedure int getop_data #I client data for above function int ufcn #I user supplied function call procedure int ufcn_data #I client data for above function int flags #I flag bits int junk pointer sp, ip bool debug, first_time int strlen(), xvv_parse() pointer xvv_loadsymbols() extern xvv_gettok() errchk xvv_parse, calloc include "evvexpr.com" data debug /false/ data first_time /true/ begin call smark (sp) if (first_time) { # This creates data which remains for the life of the process. ev_st = xvv_loadsymbols (KEYWORDS) first_time = false } # Set user function entry point addresses. ev_getop = getop ev_getop_data = getop_data ev_ufcn = ufcn ev_ufcn_data = ufcn_data ev_flags = flags # Allocate an operand struct for the expression value. call calloc (ev_oval, LEN_OPERAND, TY_STRUCT) # Make a local copy of the input string. call salloc (ip, strlen(expr), TY_CHAR) call strcpy (expr, Memc[ip], ARB) # Evaluate the expression. The expression value is copied into the # output operand structure by XVV_PARSE, given the operand pointer # passed in common. A common must be used since the standard parser # subroutine has a fixed calling sequence. junk = xvv_parse (ip, debug, xvv_gettok) O_FLAGS(ev_oval) = or (O_FLAGS(ev_oval), O_FREEOP) call sfree (sp) return (ev_oval) end # EVVFREE -- Free an operand struct such as is returned by EVVEXPR. procedure evvfree (o) pointer o # operand struct begin call xvv_freeop (o) end define CONSTANT 257 define IDENTIFIER 258 define NEWLINE 259 define YYEOS 260 define PLUS 261 define MINUS 262 define STAR 263 define SLASH 264 define EXPON 265 define CONCAT 266 define QUEST 267 define COLON 268 define LT 269 define GT 270 define LE 271 define EQ 272 define NE 273 define SE 274 define LAND 275 define LOR 276 define LNOT 277 define BAND 278 define BOR 279 define BXOR 280 define BNOT 281 define AT 282 define GE 283 define UMINUS 284 define yyclearin yychar = -1 define yyerrok yyerrflag = 0 define YYMOVE call amovi (Memi[$1], Memi[$2], YYOPLEN) define YYERRCODE 256 # line 454 "evvexpr.y" # End generic preprocessor escape. # XVV_UNOP -- Unary operation. Perform the indicated unary operation on the # input operand, returning the result as the output operand. procedure xvv_unop (opcode, in, out) int opcode #I operation to be performed pointer in #I input operand pointer out #I output operand short val_s long val_l int val_i, nelem errchk xvv_error, xvv_initop string s_badswitch "unop: bad switch" begin nelem = O_LEN(in) switch (opcode) { case MINUS: # Unary negation. call xvv_initop (out, nelem, O_TYPE(in)) switch (O_TYPE(in)) { case TY_BOOL, TY_CHAR: call xvv_error ("negation of a nonarithmetic operand") case TY_SHORT: if (nelem > 0) call anegs (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem) else O_VALS(out) = -O_VALS(in) case TY_INT: if (nelem > 0) call anegi (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem) else O_VALI(out) = -O_VALI(in) case TY_LONG: if (nelem > 0) call anegl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem) else O_VALL(out) = -O_VALL(in) case TY_REAL: if (nelem > 0) call anegr (Memr[O_VALP(in)], Memr[O_VALP(out)], nelem) else O_VALR(out) = -O_VALR(in) case TY_DOUBLE: if (nelem > 0) call anegd (Memd[O_VALP(in)], Memd[O_VALP(out)], nelem) else O_VALD(out) = -O_VALD(in) default: call xvv_error (s_badswitch) } case LNOT: # Logical NOT. call xvv_initop (out, nelem, TY_BOOL) switch (O_TYPE(in)) { case TY_BOOL: if (nelem > 0) call abeqki (Memi[O_VALP(in)], NO, Memi[O_VALP(out)], nelem) else { if (O_VALI(in) == NO) O_VALI(out) = YES else O_VALI(out) = NO } case TY_SHORT: if (nelem > 0) { val_s = NO call abeqks (Mems[O_VALP(in)], val_s, Memi[O_VALP(out)], nelem) } else { if (O_VALS(in) == NO) O_VALS(out) = YES else O_VALS(out) = NO } case TY_INT: if (nelem > 0) { val_i = NO call abeqki (Memi[O_VALP(in)], val_i, Memi[O_VALP(out)], nelem) } else { if (O_VALI(in) == NO) O_VALI(out) = YES else O_VALI(out) = NO } case TY_LONG: if (nelem > 0) { val_l = NO call abeqkl (Meml[O_VALP(in)], val_l, Memi[O_VALP(out)], nelem) } else { if (O_VALL(in) == NO) O_VALL(out) = YES else O_VALL(out) = NO } case TY_CHAR, TY_REAL, TY_DOUBLE: call xvv_error ("not of a nonlogical") default: call xvv_error (s_badswitch) } case BNOT: # Bitwise boolean NOT. call xvv_initop (out, nelem, O_TYPE(in)) switch (O_TYPE(in)) { case TY_BOOL, TY_CHAR, TY_REAL, TY_DOUBLE: call xvv_error ("boolean not of a noninteger operand") case TY_SHORT: if (nelem > 0) call anots (Mems[O_VALP(in)], Mems[O_VALP(out)], nelem) else O_VALS(out) = not(O_VALS(in)) case TY_INT: if (nelem > 0) call anoti (Memi[O_VALP(in)], Memi[O_VALP(out)], nelem) else O_VALI(out) = not(O_VALI(in)) case TY_LONG: if (nelem > 0) call anotl (Meml[O_VALP(in)], Meml[O_VALP(out)], nelem) else O_VALL(out) = not(O_VALL(in)) default: call xvv_error (s_badswitch) } default: call xvv_error (s_badswitch) } call xvv_freeop (in) end # XVV_BINOP -- Binary operation. Perform the indicated arithmetic binary # operation on the two input operands, returning the result as the output # operand. procedure xvv_binop (opcode, in1, in2, out) int opcode #I operation to be performed pointer in1, in2 #I input operands pointer out #I output operand short v_s short xvv_nulls() extern xvv_nulls() int v_i int xvv_nulli() extern xvv_nulli() long v_l long xvv_nulll() extern xvv_nulll() real v_r real xvv_nullr() extern xvv_nullr() double v_d double xvv_nulld() extern xvv_nulld() pointer sp, otemp, p1, p2, po int dtype, nelem, len1, len2 include "evvexpr.com" int xvv_newtype(), strlen() errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error string s_badswitch "binop: bad case in switch" string s_boolop "binop: bitwise boolean operands must be an integer type" define done_ 91 begin # Set the datatype of the output operand, taking an error action if # the operands have incompatible datatypes. dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) # Compute the size of the output operand. If both input operands are # vectors the length of the output vector is the shorter of the two. switch (dtype) { case TY_BOOL: call xvv_error ("binop: operation illegal for boolean operands") case TY_CHAR: nelem = strlen (O_VALC(in1)) + strlen (O_VALC(in2)) default: if (opcode == CONCAT) nelem = max (1, O_LEN(in1)) + max (1, O_LEN(in2)) else { if (O_LEN(in1) > 0 && O_LEN(in2) > 0) nelem = min (O_LEN(in1), O_LEN(in2)) else if (O_LEN(in1) > 0) nelem = O_LEN(in1) else if (O_LEN(in2) > 0) nelem = O_LEN(in2) else nelem = 0 } } # Convert input operands to desired type. if (O_TYPE(in1) != dtype) call xvv_chtype (in1, in1, dtype) if (O_TYPE(in2) != dtype) call xvv_chtype (in2, in2, dtype) # If this is a scalar/vector operation make sure the vector is the # first operand. len1 = O_LEN(in1) len2 = O_LEN(in2) if (len1 == 0 && len2 > 0) { switch (opcode) { case PLUS: # Swap operands. call smark (sp) call salloc (otemp, LEN_OPERAND, TY_STRUCT) YYMOVE (in1, otemp) YYMOVE (in2, in1) YYMOVE (otemp, in2) call sfree (sp) case CONCAT: ; # Do nothing default: # Promote operand to a constant vector. Inefficient, but # better than aborting. switch (dtype) { case TY_SHORT: v_s = O_VALS(in1) call xvv_initop (in1, nelem, dtype) call amovks (v_s, Mems[O_VALP(in1)], nelem) case TY_INT: v_i = O_VALI(in1) call xvv_initop (in1, nelem, dtype) call amovki (v_i, Memi[O_VALP(in1)], nelem) case TY_LONG: v_l = O_VALL(in1) call xvv_initop (in1, nelem, dtype) call amovkl (v_l, Meml[O_VALP(in1)], nelem) case TY_REAL: v_r = O_VALR(in1) call xvv_initop (in1, nelem, dtype) call amovkr (v_r, Memr[O_VALP(in1)], nelem) case TY_DOUBLE: v_d = O_VALD(in1) call xvv_initop (in1, nelem, dtype) call amovkd (v_d, Memd[O_VALP(in1)], nelem) } } len1 = O_LEN(in1) len2 = O_LEN(in2) } # Initialize the output operand. call xvv_initop (out, nelem, dtype) p1 = O_VALP(in1) p2 = O_VALP(in2) po = O_VALP(out) # The bitwise boolean binary operators a special case since only the # integer datatypes are permitted. Otherwise the bitwise booleans # are just like arithmetic booleans. if (opcode == BAND || opcode == BOR || opcode == BXOR) { switch (dtype) { case TY_SHORT: switch (opcode) { case BAND: if (len1 <= 0) { O_VALS(out) = and (O_VALS(in1), O_VALS(in2)) } else if (len2 <= 0) { call aandks (Mems[p1], O_VALS(in2), Mems[po], nelem) } else { call aands (Mems[p1], Mems[p2], Mems[po], nelem) } case BOR: if (len1 <= 0) { O_VALS(out) = or (O_VALS(in1), O_VALS(in2)) } else if (len2 <= 0) { call aborks (Mems[p1], O_VALS(in2), Mems[po], nelem) } else { call abors (Mems[p1], Mems[p2], Mems[po], nelem) } case BXOR: if (len1 <= 0) { O_VALS(out) = xor (O_VALS(in1), O_VALS(in2)) } else if (len2 <= 0) { call axorks (Mems[p1], O_VALS(in2), Mems[po], nelem) } else { call axors (Mems[p1], Mems[p2], Mems[po], nelem) } } case TY_INT: switch (opcode) { case BAND: if (len1 <= 0) { O_VALI(out) = and (O_VALI(in1), O_VALI(in2)) } else if (len2 <= 0) { call aandki (Memi[p1], O_VALI(in2), Memi[po], nelem) } else { call aandi (Memi[p1], Memi[p2], Memi[po], nelem) } case BOR: if (len1 <= 0) { O_VALI(out) = or (O_VALI(in1), O_VALI(in2)) } else if (len2 <= 0) { call aborki (Memi[p1], O_VALI(in2), Memi[po], nelem) } else { call abori (Memi[p1], Memi[p2], Memi[po], nelem) } case BXOR: if (len1 <= 0) { O_VALI(out) = xor (O_VALI(in1), O_VALI(in2)) } else if (len2 <= 0) { call axorki (Memi[p1], O_VALI(in2), Memi[po], nelem) } else { call axori (Memi[p1], Memi[p2], Memi[po], nelem) } } case TY_LONG: switch (opcode) { case BAND: if (len1 <= 0) { O_VALL(out) = and (O_VALL(in1), O_VALL(in2)) } else if (len2 <= 0) { call aandkl (Meml[p1], O_VALL(in2), Meml[po], nelem) } else { call aandl (Meml[p1], Meml[p2], Meml[po], nelem) } case BOR: if (len1 <= 0) { O_VALL(out) = or (O_VALL(in1), O_VALL(in2)) } else if (len2 <= 0) { call aborkl (Meml[p1], O_VALL(in2), Meml[po], nelem) } else { call aborl (Meml[p1], Meml[p2], Meml[po], nelem) } case BXOR: if (len1 <= 0) { O_VALL(out) = xor (O_VALL(in1), O_VALL(in2)) } else if (len2 <= 0) { call axorkl (Meml[p1], O_VALL(in2), Meml[po], nelem) } else { call axorl (Meml[p1], Meml[p2], Meml[po], nelem) } } default: call xvv_error (s_boolop) } goto done_ } # Perform an arithmetic binary operation. switch (dtype) { case TY_CHAR: switch (opcode) { case CONCAT: call strcpy (O_VALC(in1), O_VALC(out), ARB) call strcat (O_VALC(in2), O_VALC(out), ARB) default: call xvv_error ("binop: operation illegal for string operands") } case TY_SHORT: switch (opcode) { case PLUS: if (len1 <= 0) { O_VALS(out) = O_VALS(in1) + O_VALS(in2) } else if (len2 <= 0) { call aaddks (Mems[p1], O_VALS(in2), Mems[po], nelem) } else { call aadds (Mems[p1], Mems[p2], Mems[po], nelem) } case MINUS: if (len1 <= 0) O_VALS(out) = O_VALS(in1) - O_VALS(in2) else if (len2 <= 0) call asubks (Mems[p1], O_VALS(in2), Mems[po], nelem) else call asubs (Mems[p1], Mems[p2], Mems[po], nelem) case STAR: if (len1 <= 0) O_VALS(out) = O_VALS(in1) * O_VALS(in2) else if (len2 <= 0) call amulks (Mems[p1], O_VALS(in2), Mems[po], nelem) else call amuls (Mems[p1], Mems[p2], Mems[po], nelem) case SLASH: if (and (ev_flags, EV_RNGCHK) == 0) { # No range checking. if (len1 <= 0) O_VALS(out) = O_VALS(in1) / O_VALS(in2) else if (len2 <= 0) call adivks (Mems[p1], O_VALS(in2), Mems[po], nelem) else call adivs (Mems[p1], Mems[p2], Mems[po], nelem) } else { # Check for divide by zero. if (len1 <= 0) { if (O_VALS(in2) == 0) O_VALS(out) = xvv_nulls(0) else O_VALS(out) = O_VALS(in1) / O_VALS(in2) } else if (len2 <= 0) { if (O_VALS(in2) == 0) call amovks (xvv_nulls(0), Mems[po], nelem) else { call adivks (Mems[p1], O_VALS(in2), Mems[po], nelem) } } else { call advzs (Mems[p1], Mems[p2], Mems[po], nelem, xvv_nulls) } } case EXPON: if (len1 <= 0) O_VALS(out) = O_VALS(in1) ** O_VALS(in2) else if (len2 <= 0) call aexpks (Mems[p1], O_VALS(in2), Mems[po], nelem) else call aexps (Mems[p1], Mems[p2], Mems[po], nelem) case CONCAT: # Concatenate two numeric operands. if (len1 <= 0) { Mems[po] = O_VALS(in1) po = po + 1 } else { call amovs (Mems[p1], Mems[po], len1) po = po + len1 } if (len2 <= 0) Mems[po] = O_VALS(in2) else call amovs (Mems[p2], Mems[po], len2) default: call xvv_error (s_badswitch) } case TY_INT: switch (opcode) { case PLUS: if (len1 <= 0) { O_VALI(out) = O_VALI(in1) + O_VALI(in2) } else if (len2 <= 0) { call aaddki (Memi[p1], O_VALI(in2), Memi[po], nelem) } else { call aaddi (Memi[p1], Memi[p2], Memi[po], nelem) } case MINUS: if (len1 <= 0) O_VALI(out) = O_VALI(in1) - O_VALI(in2) else if (len2 <= 0) call asubki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call asubi (Memi[p1], Memi[p2], Memi[po], nelem) case STAR: if (len1 <= 0) O_VALI(out) = O_VALI(in1) * O_VALI(in2) else if (len2 <= 0) call amulki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call amuli (Memi[p1], Memi[p2], Memi[po], nelem) case SLASH: if (and (ev_flags, EV_RNGCHK) == 0) { # No range checking. if (len1 <= 0) O_VALI(out) = O_VALI(in1) / O_VALI(in2) else if (len2 <= 0) call adivki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call adivi (Memi[p1], Memi[p2], Memi[po], nelem) } else { # Check for divide by zero. if (len1 <= 0) { if (O_VALI(in2) == 0) O_VALI(out) = xvv_nulli(0) else O_VALI(out) = O_VALI(in1) / O_VALI(in2) } else if (len2 <= 0) { if (O_VALI(in2) == 0) call amovki (xvv_nulli(0), Memi[po], nelem) else { call adivki (Memi[p1], O_VALI(in2), Memi[po], nelem) } } else { call advzi (Memi[p1], Memi[p2], Memi[po], nelem, xvv_nulli) } } case EXPON: if (len1 <= 0) O_VALI(out) = O_VALI(in1) ** O_VALI(in2) else if (len2 <= 0) call aexpki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call aexpi (Memi[p1], Memi[p2], Memi[po], nelem) case CONCAT: # Concatenate two numeric operands. if (len1 <= 0) { Memi[po] = O_VALI(in1) po = po + 1 } else { call amovi (Memi[p1], Memi[po], len1) po = po + len1 } if (len2 <= 0) Memi[po] = O_VALI(in2) else call amovi (Memi[p2], Memi[po], len2) default: call xvv_error (s_badswitch) } case TY_LONG: switch (opcode) { case PLUS: if (len1 <= 0) { O_VALL(out) = O_VALL(in1) + O_VALL(in2) } else if (len2 <= 0) { call aaddkl (Meml[p1], O_VALL(in2), Meml[po], nelem) } else { call aaddl (Meml[p1], Meml[p2], Meml[po], nelem) } case MINUS: if (len1 <= 0) O_VALL(out) = O_VALL(in1) - O_VALL(in2) else if (len2 <= 0) call asubkl (Meml[p1], O_VALL(in2), Meml[po], nelem) else call asubl (Meml[p1], Meml[p2], Meml[po], nelem) case STAR: if (len1 <= 0) O_VALL(out) = O_VALL(in1) * O_VALL(in2) else if (len2 <= 0) call amulkl (Meml[p1], O_VALL(in2), Meml[po], nelem) else call amull (Meml[p1], Meml[p2], Meml[po], nelem) case SLASH: if (and (ev_flags, EV_RNGCHK) == 0) { # No range checking. if (len1 <= 0) O_VALL(out) = O_VALL(in1) / O_VALL(in2) else if (len2 <= 0) call adivkl (Meml[p1], O_VALL(in2), Meml[po], nelem) else call adivl (Meml[p1], Meml[p2], Meml[po], nelem) } else { # Check for divide by zero. if (len1 <= 0) { if (O_VALL(in2) == 0) O_VALL(out) = xvv_nulll(0) else O_VALL(out) = O_VALL(in1) / O_VALL(in2) } else if (len2 <= 0) { if (O_VALL(in2) == 0) call amovkl (xvv_nulll(0), Meml[po], nelem) else { call adivkl (Meml[p1], O_VALL(in2), Meml[po], nelem) } } else { call advzl (Meml[p1], Meml[p2], Meml[po], nelem, xvv_nulll) } } case EXPON: if (len1 <= 0) O_VALL(out) = O_VALL(in1) ** O_VALL(in2) else if (len2 <= 0) call aexpkl (Meml[p1], O_VALL(in2), Meml[po], nelem) else call aexpl (Meml[p1], Meml[p2], Meml[po], nelem) case CONCAT: # Concatenate two numeric operands. if (len1 <= 0) { Meml[po] = O_VALL(in1) po = po + 1 } else { call amovl (Meml[p1], Meml[po], len1) po = po + len1 } if (len2 <= 0) Meml[po] = O_VALL(in2) else call amovl (Meml[p2], Meml[po], len2) default: call xvv_error (s_badswitch) } case TY_REAL: switch (opcode) { case PLUS: if (len1 <= 0) { O_VALR(out) = O_VALR(in1) + O_VALR(in2) } else if (len2 <= 0) { call aaddkr (Memr[p1], O_VALR(in2), Memr[po], nelem) } else { call aaddr (Memr[p1], Memr[p2], Memr[po], nelem) } case MINUS: if (len1 <= 0) O_VALR(out) = O_VALR(in1) - O_VALR(in2) else if (len2 <= 0) call asubkr (Memr[p1], O_VALR(in2), Memr[po], nelem) else call asubr (Memr[p1], Memr[p2], Memr[po], nelem) case STAR: if (len1 <= 0) O_VALR(out) = O_VALR(in1) * O_VALR(in2) else if (len2 <= 0) call amulkr (Memr[p1], O_VALR(in2), Memr[po], nelem) else call amulr (Memr[p1], Memr[p2], Memr[po], nelem) case SLASH: if (and (ev_flags, EV_RNGCHK) == 0) { # No range checking. if (len1 <= 0) O_VALR(out) = O_VALR(in1) / O_VALR(in2) else if (len2 <= 0) call adivkr (Memr[p1], O_VALR(in2), Memr[po], nelem) else call adivr (Memr[p1], Memr[p2], Memr[po], nelem) } else { # Check for divide by zero. if (len1 <= 0) { if (O_VALR(in2) == 0.0) O_VALR(out) = xvv_nullr(0.0) else O_VALR(out) = O_VALR(in1) / O_VALR(in2) } else if (len2 <= 0) { if (O_VALR(in2) == 0.0) call amovkr (xvv_nullr(0.0), Memr[po], nelem) else { call adivkr (Memr[p1], O_VALR(in2), Memr[po], nelem) } } else { call advzr (Memr[p1], Memr[p2], Memr[po], nelem, xvv_nullr) } } case EXPON: if (len1 <= 0) O_VALR(out) = O_VALR(in1) ** O_VALR(in2) else if (len2 <= 0) call aexpkr (Memr[p1], O_VALR(in2), Memr[po], nelem) else call aexpr (Memr[p1], Memr[p2], Memr[po], nelem) case CONCAT: # Concatenate two numeric operands. if (len1 <= 0) { Memr[po] = O_VALR(in1) po = po + 1 } else { call amovr (Memr[p1], Memr[po], len1) po = po + len1 } if (len2 <= 0) Memr[po] = O_VALR(in2) else call amovr (Memr[p2], Memr[po], len2) default: call xvv_error (s_badswitch) } case TY_DOUBLE: switch (opcode) { case PLUS: if (len1 <= 0) { O_VALD(out) = O_VALD(in1) + O_VALD(in2) } else if (len2 <= 0) { call aaddkd (Memd[p1], O_VALD(in2), Memd[po], nelem) } else { call aaddd (Memd[p1], Memd[p2], Memd[po], nelem) } case MINUS: if (len1 <= 0) O_VALD(out) = O_VALD(in1) - O_VALD(in2) else if (len2 <= 0) call asubkd (Memd[p1], O_VALD(in2), Memd[po], nelem) else call asubd (Memd[p1], Memd[p2], Memd[po], nelem) case STAR: if (len1 <= 0) O_VALD(out) = O_VALD(in1) * O_VALD(in2) else if (len2 <= 0) call amulkd (Memd[p1], O_VALD(in2), Memd[po], nelem) else call amuld (Memd[p1], Memd[p2], Memd[po], nelem) case SLASH: if (and (ev_flags, EV_RNGCHK) == 0) { # No range checking. if (len1 <= 0) O_VALD(out) = O_VALD(in1) / O_VALD(in2) else if (len2 <= 0) call adivkd (Memd[p1], O_VALD(in2), Memd[po], nelem) else call adivd (Memd[p1], Memd[p2], Memd[po], nelem) } else { # Check for divide by zero. if (len1 <= 0) { if (O_VALD(in2) == 0.0D0) O_VALD(out) = xvv_nulld(0.0D0) else O_VALD(out) = O_VALD(in1) / O_VALD(in2) } else if (len2 <= 0) { if (O_VALD(in2) == 0.0D0) call amovkd (xvv_nulld(0.0D0), Memd[po], nelem) else { call adivkd (Memd[p1], O_VALD(in2), Memd[po], nelem) } } else { call advzd (Memd[p1], Memd[p2], Memd[po], nelem, xvv_nulld) } } case EXPON: if (len1 <= 0) O_VALD(out) = O_VALD(in1) ** O_VALD(in2) else if (len2 <= 0) call aexpkd (Memd[p1], O_VALD(in2), Memd[po], nelem) else call aexpd (Memd[p1], Memd[p2], Memd[po], nelem) case CONCAT: # Concatenate two numeric operands. if (len1 <= 0) { Memd[po] = O_VALD(in1) po = po + 1 } else { call amovd (Memd[p1], Memd[po], len1) po = po + len1 } if (len2 <= 0) Memd[po] = O_VALD(in2) else call amovd (Memd[p2], Memd[po], len2) default: call xvv_error (s_badswitch) } default: call xvv_error (s_badswitch) } done_ # Free any storage in input operands. call xvv_freeop (in1) call xvv_freeop (in2) end # XVV_BOOLOP -- Boolean (actually logical) binary operations. Perform the # indicated logical operation on the two input operands, returning the result # as the output operand. The opcodes implemented by this routine are # characterized by the fact that they all return a logical result (YES or NO # physically expressed as an integer). procedure xvv_boolop (opcode, in1, in2, out) int opcode #I operation to be performed pointer in1, in2 #I input operands pointer out #I output operand short v_s int v_i long v_l real v_r double v_d pointer sp, otemp, p1, p2, po int dtype, nelem, len1, len2 int xvv_newtype(), xvv_patmatch(), strncmp(), btoi() errchk xvv_newtype, xvv_initop, xvv_chtype, xvv_error string s_badop "boolop: illegal operation" string s_badswitch "boolop: illegal switch" begin # Boolean operands are treated as integer within this routine. if (O_TYPE(in1) == TY_BOOL) O_TYPE(in1) = TY_INT if (O_TYPE(in2) == TY_BOOL) O_TYPE(in2) = TY_INT # Determine the computation type for the operation, i.e., the type # both input operands must have. This is not the same as the type # of the output operand, which is always boolean for the operations # implemented by this routine. dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) # Compute the size of the output operand. If both input operands are # vectors the length of the output vector is the shorter of the two. if (dtype == TY_CHAR) nelem = 0 else { if (O_LEN(in1) > 0 && O_LEN(in2) > 0) nelem = min (O_LEN(in1), O_LEN(in2)) else if (O_LEN(in1) > 0) nelem = O_LEN(in1) else if (O_LEN(in2) > 0) nelem = O_LEN(in2) else nelem = 0 } # Convert input operands to desired computation type. if (O_TYPE(in1) != dtype) call xvv_chtype (in1, in1, dtype) if (O_TYPE(in2) != dtype) call xvv_chtype (in2, in2, dtype) # If this is a scalar/vector operation make sure the vector is the # first operand. len1 = O_LEN(in1) len2 = O_LEN(in2) if (len1 == 0 && len2 > 0) { switch (opcode) { case EQ, NE: call smark (sp) call salloc (otemp, LEN_OPERAND, TY_STRUCT) YYMOVE (in1, otemp) YYMOVE (in2, in1) YYMOVE (otemp, in2) call sfree (sp) default: # Promote operand to a constant vector. Inefficient, but # better than aborting. switch (dtype) { case TY_SHORT: v_s = O_VALS(in1) call xvv_initop (in1, nelem, dtype) call amovks (v_s, Mems[O_VALP(in1)], nelem) case TY_INT: v_i = O_VALI(in1) call xvv_initop (in1, nelem, dtype) call amovki (v_i, Memi[O_VALP(in1)], nelem) case TY_LONG: v_l = O_VALL(in1) call xvv_initop (in1, nelem, dtype) call amovkl (v_l, Meml[O_VALP(in1)], nelem) case TY_REAL: v_r = O_VALR(in1) call xvv_initop (in1, nelem, dtype) call amovkr (v_r, Memr[O_VALP(in1)], nelem) case TY_DOUBLE: v_d = O_VALD(in1) call xvv_initop (in1, nelem, dtype) call amovkd (v_d, Memd[O_VALP(in1)], nelem) } } len1 = O_LEN(in1) len2 = O_LEN(in2) } # Initialize the output operand. call xvv_initop (out, nelem, TY_BOOL) p1 = O_VALP(in1) p2 = O_VALP(in2) po = O_VALP(out) # Perform the operation. if (dtype == TY_CHAR) { # Character data is a special case. switch (opcode) { case SE: O_VALI(out) = btoi(xvv_patmatch (O_VALC(in1), O_VALC(in2)) > 0) case LT: O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) < 0) case LE: O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) <= 0) case GT: O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) > 0) case GE: O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) >= 0) case EQ: O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) == 0) case NE: O_VALI(out) = btoi(strncmp (O_VALC(in1), O_VALC(in2), ARB) != 0) default: call xvv_error (s_badop) } } else if (opcode == LAND || opcode == LOR) { # Operations supporting only the integer types. switch (dtype) { case TY_SHORT: switch (opcode) { case LAND: if (len1 <= 0) { O_VALI(out) = btoi (O_VALS(in1) != 0 && O_VALS(in2) != 0) } else if (len2 <= 0) { call alanks (Mems[p1], O_VALS(in2), Memi[po], nelem) } else call alans (Mems[p1], Mems[p2], Memi[po], nelem) case LOR: if (len1 <= 0) { O_VALI(out) = btoi (O_VALS(in1) != 0 || O_VALS(in2) != 0) } else if (len2 <= 0) { call alorks (Mems[p1], O_VALS(in2), Memi[po], nelem) } else call alors (Mems[p1], Mems[p2], Memi[po], nelem) default: call xvv_error (s_badop) } case TY_INT: switch (opcode) { case LAND: if (len1 <= 0) { O_VALI(out) = btoi (O_VALI(in1) != 0 && O_VALI(in2) != 0) } else if (len2 <= 0) { call alanki (Memi[p1], O_VALI(in2), Memi[po], nelem) } else call alani (Memi[p1], Memi[p2], Memi[po], nelem) case LOR: if (len1 <= 0) { O_VALI(out) = btoi (O_VALI(in1) != 0 || O_VALI(in2) != 0) } else if (len2 <= 0) { call alorki (Memi[p1], O_VALI(in2), Memi[po], nelem) } else call alori (Memi[p1], Memi[p2], Memi[po], nelem) default: call xvv_error (s_badop) } case TY_LONG: switch (opcode) { case LAND: if (len1 <= 0) { O_VALI(out) = btoi (O_VALL(in1) != 0 && O_VALL(in2) != 0) } else if (len2 <= 0) { call alankl (Meml[p1], O_VALL(in2), Memi[po], nelem) } else call alanl (Meml[p1], Meml[p2], Memi[po], nelem) case LOR: if (len1 <= 0) { O_VALI(out) = btoi (O_VALL(in1) != 0 || O_VALL(in2) != 0) } else if (len2 <= 0) { call alorkl (Meml[p1], O_VALL(in2), Memi[po], nelem) } else call alorl (Meml[p1], Meml[p2], Memi[po], nelem) default: call xvv_error (s_badop) } default: call xvv_error (s_badswitch) } } else { # Operations supporting any arithmetic type. switch (dtype) { case TY_SHORT: switch (opcode) { case LT: if (len1 <= 0) O_VALI(out) = btoi (O_VALS(in1) < O_VALS(in2)) else if (len2 <= 0) call abltks (Mems[p1], O_VALS(in2), Memi[po], nelem) else call ablts (Mems[p1], Mems[p2], Memi[po], nelem) case LE: if (len1 <= 0) O_VALI(out) = btoi (O_VALS(in1) <= O_VALS(in2)) else if (len2 <= 0) call ableks (Mems[p1], O_VALS(in2), Memi[po], nelem) else call ables (Mems[p1], Mems[p2], Memi[po], nelem) case GT: if (len1 <= 0) O_VALI(out) = btoi (O_VALS(in1) > O_VALS(in2)) else if (len2 <= 0) call abgtks (Mems[p1], O_VALS(in2), Memi[po], nelem) else call abgts (Mems[p1], Mems[p2], Memi[po], nelem) case GE: if (len1 <= 0) O_VALI(out) = btoi (O_VALS(in1) >= O_VALS(in2)) else if (len2 <= 0) call abgeks (Mems[p1], O_VALS(in2), Memi[po], nelem) else call abges (Mems[p1], Mems[p2], Memi[po], nelem) case EQ: if (len1 <= 0) O_VALI(out) = btoi (O_VALS(in1) == O_VALS(in2)) else if (len2 <= 0) call abeqks (Mems[p1], O_VALS(in2), Memi[po], nelem) else call abeqs (Mems[p1], Mems[p2], Memi[po], nelem) case NE: if (len1 <= 0) O_VALI(out) = btoi (O_VALS(in1) != O_VALS(in2)) else if (len2 <= 0) call abneks (Mems[p1], O_VALS(in2), Memi[po], nelem) else call abnes (Mems[p1], Mems[p2], Memi[po], nelem) default: call xvv_error (s_badop) } case TY_INT: switch (opcode) { case LT: if (len1 <= 0) O_VALI(out) = btoi (O_VALI(in1) < O_VALI(in2)) else if (len2 <= 0) call abltki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call ablti (Memi[p1], Memi[p2], Memi[po], nelem) case LE: if (len1 <= 0) O_VALI(out) = btoi (O_VALI(in1) <= O_VALI(in2)) else if (len2 <= 0) call ableki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call ablei (Memi[p1], Memi[p2], Memi[po], nelem) case GT: if (len1 <= 0) O_VALI(out) = btoi (O_VALI(in1) > O_VALI(in2)) else if (len2 <= 0) call abgtki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call abgti (Memi[p1], Memi[p2], Memi[po], nelem) case GE: if (len1 <= 0) O_VALI(out) = btoi (O_VALI(in1) >= O_VALI(in2)) else if (len2 <= 0) call abgeki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call abgei (Memi[p1], Memi[p2], Memi[po], nelem) case EQ: if (len1 <= 0) O_VALI(out) = btoi (O_VALI(in1) == O_VALI(in2)) else if (len2 <= 0) call abeqki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call abeqi (Memi[p1], Memi[p2], Memi[po], nelem) case NE: if (len1 <= 0) O_VALI(out) = btoi (O_VALI(in1) != O_VALI(in2)) else if (len2 <= 0) call abneki (Memi[p1], O_VALI(in2), Memi[po], nelem) else call abnei (Memi[p1], Memi[p2], Memi[po], nelem) default: call xvv_error (s_badop) } case TY_LONG: switch (opcode) { case LT: if (len1 <= 0) O_VALI(out) = btoi (O_VALL(in1) < O_VALL(in2)) else if (len2 <= 0) call abltkl (Meml[p1], O_VALL(in2), Memi[po], nelem) else call abltl (Meml[p1], Meml[p2], Memi[po], nelem) case LE: if (len1 <= 0) O_VALI(out) = btoi (O_VALL(in1) <= O_VALL(in2)) else if (len2 <= 0) call ablekl (Meml[p1], O_VALL(in2), Memi[po], nelem) else call ablel (Meml[p1], Meml[p2], Memi[po], nelem) case GT: if (len1 <= 0) O_VALI(out) = btoi (O_VALL(in1) > O_VALL(in2)) else if (len2 <= 0) call abgtkl (Meml[p1], O_VALL(in2), Memi[po], nelem) else call abgtl (Meml[p1], Meml[p2], Memi[po], nelem) case GE: if (len1 <= 0) O_VALI(out) = btoi (O_VALL(in1) >= O_VALL(in2)) else if (len2 <= 0) call abgekl (Meml[p1], O_VALL(in2), Memi[po], nelem) else call abgel (Meml[p1], Meml[p2], Memi[po], nelem) case EQ: if (len1 <= 0) O_VALI(out) = btoi (O_VALL(in1) == O_VALL(in2)) else if (len2 <= 0) call abeqkl (Meml[p1], O_VALL(in2), Memi[po], nelem) else call abeql (Meml[p1], Meml[p2], Memi[po], nelem) case NE: if (len1 <= 0) O_VALI(out) = btoi (O_VALL(in1) != O_VALL(in2)) else if (len2 <= 0) call abnekl (Meml[p1], O_VALL(in2), Memi[po], nelem) else call abnel (Meml[p1], Meml[p2], Memi[po], nelem) default: call xvv_error (s_badop) } case TY_REAL: switch (opcode) { case LT: if (len1 <= 0) O_VALI(out) = btoi (O_VALR(in1) < O_VALR(in2)) else if (len2 <= 0) call abltkr (Memr[p1], O_VALR(in2), Memi[po], nelem) else call abltr (Memr[p1], Memr[p2], Memi[po], nelem) case LE: if (len1 <= 0) O_VALI(out) = btoi (O_VALR(in1) <= O_VALR(in2)) else if (len2 <= 0) call ablekr (Memr[p1], O_VALR(in2), Memi[po], nelem) else call abler (Memr[p1], Memr[p2], Memi[po], nelem) case GT: if (len1 <= 0) O_VALI(out) = btoi (O_VALR(in1) > O_VALR(in2)) else if (len2 <= 0) call abgtkr (Memr[p1], O_VALR(in2), Memi[po], nelem) else call abgtr (Memr[p1], Memr[p2], Memi[po], nelem) case GE: if (len1 <= 0) O_VALI(out) = btoi (O_VALR(in1) >= O_VALR(in2)) else if (len2 <= 0) call abgekr (Memr[p1], O_VALR(in2), Memi[po], nelem) else call abger (Memr[p1], Memr[p2], Memi[po], nelem) case EQ: if (len1 <= 0) O_VALI(out) = btoi (O_VALR(in1) == O_VALR(in2)) else if (len2 <= 0) call abeqkr (Memr[p1], O_VALR(in2), Memi[po], nelem) else call abeqr (Memr[p1], Memr[p2], Memi[po], nelem) case NE: if (len1 <= 0) O_VALI(out) = btoi (O_VALR(in1) != O_VALR(in2)) else if (len2 <= 0) call abnekr (Memr[p1], O_VALR(in2), Memi[po], nelem) else call abner (Memr[p1], Memr[p2], Memi[po], nelem) default: call xvv_error (s_badop) } case TY_DOUBLE: switch (opcode) { case LT: if (len1 <= 0) O_VALI(out) = btoi (O_VALD(in1) < O_VALD(in2)) else if (len2 <= 0) call abltkd (Memd[p1], O_VALD(in2), Memi[po], nelem) else call abltd (Memd[p1], Memd[p2], Memi[po], nelem) case LE: if (len1 <= 0) O_VALI(out) = btoi (O_VALD(in1) <= O_VALD(in2)) else if (len2 <= 0) call ablekd (Memd[p1], O_VALD(in2), Memi[po], nelem) else call abled (Memd[p1], Memd[p2], Memi[po], nelem) case GT: if (len1 <= 0) O_VALI(out) = btoi (O_VALD(in1) > O_VALD(in2)) else if (len2 <= 0) call abgtkd (Memd[p1], O_VALD(in2), Memi[po], nelem) else call abgtd (Memd[p1], Memd[p2], Memi[po], nelem) case GE: if (len1 <= 0) O_VALI(out) = btoi (O_VALD(in1) >= O_VALD(in2)) else if (len2 <= 0) call abgekd (Memd[p1], O_VALD(in2), Memi[po], nelem) else call abged (Memd[p1], Memd[p2], Memi[po], nelem) case EQ: if (len1 <= 0) O_VALI(out) = btoi (O_VALD(in1) == O_VALD(in2)) else if (len2 <= 0) call abeqkd (Memd[p1], O_VALD(in2), Memi[po], nelem) else call abeqd (Memd[p1], Memd[p2], Memi[po], nelem) case NE: if (len1 <= 0) O_VALI(out) = btoi (O_VALD(in1) != O_VALD(in2)) else if (len2 <= 0) call abnekd (Memd[p1], O_VALD(in2), Memi[po], nelem) else call abned (Memd[p1], Memd[p2], Memi[po], nelem) default: call xvv_error (s_badop) } default: call xvv_error (s_badswitch) } } # Free any storage in input operands. call xvv_freeop (in1) call xvv_freeop (in2) end # XVV_PATMATCH -- Match a string against a pattern, returning the patmatch # index if the string matches. The pattern may contain any of the conventional # pattern matching metacharacters. Closure (i.e., "*") is mapped to "?*". int procedure xvv_patmatch (str, pat) char str[ARB] #I operand string char pat[ARB] #I pattern int junk, ip, index pointer sp, patstr, patbuf, op int patmake(), patmatch() begin call smark (sp) call salloc (patstr, SZ_FNAME, TY_CHAR) call salloc (patbuf, SZ_LINE, TY_CHAR) call aclrc (Memc[patstr], SZ_FNAME) call aclrc (Memc[patbuf], SZ_LINE) # Map pattern, changing '*' into '?*'. op = patstr for (ip=1; pat[ip] != EOS; ip=ip+1) { if (pat[ip] == '*') { Memc[op] = '?' op = op + 1 } Memc[op] = pat[ip] op = op + 1 } # Encode pattern. junk = patmake (Memc[patstr], Memc[patbuf], SZ_LINE) # Perform the pattern matching operation. index = patmatch (str, Memc[patbuf]) call sfree (sp) return (index) end # XVV_NEWTYPE -- Get the datatype of a binary operation, given the datatypes # of the two input operands. An error action is taken if the datatypes are # incompatible, e.g., boolean and anything else or string and anything else. int procedure xvv_newtype (type1, type2) int type1 #I datatype of first operand int type2 #I datatype of second operand int newtype, p, q, i int tyindex[NTYPES], ttbl[NTYPES*NTYPES] data tyindex /T_B, T_C, T_S, T_I, T_L, T_R, T_D/ data (ttbl(i),i= 1, 7) /T_B, 0, 0, 0, 0, 0, 0/ data (ttbl(i),i= 8,14) / 0, T_C, 0, 0, 0, 0, 0/ data (ttbl(i),i=15,21) / 0, 0, T_S, T_I, T_L, T_R, T_D/ data (ttbl(i),i=22,28) / 0, 0, T_I, T_I, T_L, T_R, T_D/ data (ttbl(i),i=29,35) / 0, 0, T_L, T_L, T_L, T_R, T_D/ data (ttbl(i),i=36,42) / 0, 0, T_R, T_R, T_R, T_R, T_D/ data (ttbl(i),i=43,49) / 0, 0, T_D, T_D, T_D, T_D, T_D/ begin do i = 1, NTYPES { if (tyindex[i] == type1) p = i if (tyindex[i] == type2) q = i } newtype = ttbl[(p-1)*NTYPES+q] call eprintf ("xvv_newtype: %d %d -> %d\n") call pargi (type1) call pargi (type2) call pargi (newtype) if (newtype == 0) call xvv_error ("operands have incompatible types") else return (newtype) end # XVV_QUEST -- Conditional expression. If the condition operand is true # return the first (true) operand, else return the second (false) operand. procedure xvv_quest (cond, in1, in2, out) pointer cond #I pointer to condition operand pointer in1, in2 #I pointer to true,false operands pointer out #I pointer to output operand int dtype, nelem, i pointer sp, otemp, ip1, ip2, op, sel errchk xvv_error, xvv_newtype, xvv_initop, xvv_chtype int xvv_newtype(), btoi() begin switch (O_TYPE(cond)) { case TY_BOOL, TY_INT: ; case TY_SHORT, TY_LONG: call xvv_chtype (cond, cond, TY_BOOL) default: call xvv_error ("evvexpr: nonboolean condition operand") } if (O_LEN(cond) <= 0 && (O_LEN(in1) <= 0 || O_TYPE(in1) == TY_CHAR) && (O_LEN(in2) <= 0 || O_TYPE(in2) == TY_CHAR)) { # Both operands and the conditional are scalars; the expression # type is the type of the selected operand. if (O_VALI(cond) != 0) { YYMOVE (in1, out) call xvv_freeop (in2) } else { YYMOVE (in2, out) call xvv_freeop (in1) } } else if (O_TYPE(in1) == TY_CHAR || O_TYPE(in2) == TY_CHAR) { # This combination is not legal. call xvv_error ("evvexpr: character and vector in cond expr") } else { # Vector/scalar or vector/vector operation. Both operands must # be of the same type. dtype = xvv_newtype (O_TYPE(in1), O_TYPE(in2)) # Compute the size of the output operand. If both input operands # are vectors the length of the output vector is the shorter of # the two. The condition operand contributes to the dimension of # the expression result, although not to the datatype. nelem = 0 if (O_LEN(in1) > 0 && O_LEN(in2) > 0) nelem = min (O_LEN(in1), O_LEN(in2)) else if (O_LEN(in1) > 0) nelem = O_LEN(in1) else if (O_LEN(in2) > 0) nelem = O_LEN(in2) if (O_LEN(cond) > 0 && nelem > 0) nelem = min (O_LEN(cond), nelem) else if (O_LEN(cond) > 0) nelem = O_LEN(cond) # If this is a scalar/vector operation make sure the vector is the # first operand. if (O_LEN(in1) == 0 && O_LEN(in2) > 0) { call smark (sp) call salloc (otemp, LEN_OPERAND, TY_STRUCT) YYMOVE (in1, otemp) YYMOVE (in2, in1) YYMOVE (otemp, in2) call sfree (sp) # Since we are swapping arguments we need to negate the cond. if (O_LEN(cond) <= 0) O_VALI(cond) = btoi (O_VALI(cond) == 0) else { call abeqki (Memi[O_VALP(cond)], NO, Memi[O_VALP(cond)], nelem) } } # Initialize the output operand. call xvv_initop (out, nelem, dtype) # Convert input operands to desired computation type. if (O_TYPE(in1) != dtype) call xvv_chtype (in1, in1, dtype) if (O_TYPE(in2) != dtype) call xvv_chtype (in2, in2, dtype) ip1 = O_VALP(in1) ip2 = O_VALP(in2) op = O_VALP(out) sel = O_VALP(cond) # Perform the operation. switch (dtype) { case TY_SHORT: if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { # Vector conditional, both operands are scalars. do i = 1, nelem if (Memi[sel+i-1] != 0) Mems[op+i-1] = O_VALS(in1) else Mems[op+i-1] = O_VALS(in2) } else if (O_LEN(in2) <= 0) { # Operand 1 is a vector, operand 2 is a scalar. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovs (Mems[ip1], Mems[op], nelem) else call amovks (O_VALS(in2), Mems[op], nelem) } else { # Conditional is a vector. call aselks (Mems[ip1], O_VALS(in2), Mems[op], Memi[sel], nelem) } } else { # Both operands are vectors. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovs (Mems[ip1], Mems[op], nelem) else call amovs (Mems[ip2], Mems[op], nelem) } else { # Conditional is a vector. call asels (Mems[ip1], Mems[ip2], Mems[op], Memi[sel], nelem) } } case TY_INT: if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { # Vector conditional, both operands are scalars. do i = 1, nelem if (Memi[sel+i-1] != 0) Memi[op+i-1] = O_VALI(in1) else Memi[op+i-1] = O_VALI(in2) } else if (O_LEN(in2) <= 0) { # Operand 1 is a vector, operand 2 is a scalar. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovi (Memi[ip1], Memi[op], nelem) else call amovki (O_VALI(in2), Memi[op], nelem) } else { # Conditional is a vector. call aselki (Memi[ip1], O_VALI(in2), Memi[op], Memi[sel], nelem) } } else { # Both operands are vectors. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovi (Memi[ip1], Memi[op], nelem) else call amovi (Memi[ip2], Memi[op], nelem) } else { # Conditional is a vector. call aseli (Memi[ip1], Memi[ip2], Memi[op], Memi[sel], nelem) } } case TY_LONG: if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { # Vector conditional, both operands are scalars. do i = 1, nelem if (Memi[sel+i-1] != 0) Meml[op+i-1] = O_VALL(in1) else Meml[op+i-1] = O_VALL(in2) } else if (O_LEN(in2) <= 0) { # Operand 1 is a vector, operand 2 is a scalar. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovl (Meml[ip1], Meml[op], nelem) else call amovkl (O_VALL(in2), Meml[op], nelem) } else { # Conditional is a vector. call aselkl (Meml[ip1], O_VALL(in2), Meml[op], Memi[sel], nelem) } } else { # Both operands are vectors. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovl (Meml[ip1], Meml[op], nelem) else call amovl (Meml[ip2], Meml[op], nelem) } else { # Conditional is a vector. call asell (Meml[ip1], Meml[ip2], Meml[op], Memi[sel], nelem) } } case TY_REAL: if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { # Vector conditional, both operands are scalars. do i = 1, nelem if (Memi[sel+i-1] != 0) Memr[op+i-1] = O_VALR(in1) else Memr[op+i-1] = O_VALR(in2) } else if (O_LEN(in2) <= 0) { # Operand 1 is a vector, operand 2 is a scalar. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovr (Memr[ip1], Memr[op], nelem) else call amovkr (O_VALR(in2), Memr[op], nelem) } else { # Conditional is a vector. call aselkr (Memr[ip1], O_VALR(in2), Memr[op], Memi[sel], nelem) } } else { # Both operands are vectors. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovr (Memr[ip1], Memr[op], nelem) else call amovr (Memr[ip2], Memr[op], nelem) } else { # Conditional is a vector. call aselr (Memr[ip1], Memr[ip2], Memr[op], Memi[sel], nelem) } } case TY_DOUBLE: if (O_LEN(in1) <= 0 && O_LEN(in2) <= 0) { # Vector conditional, both operands are scalars. do i = 1, nelem if (Memi[sel+i-1] != 0) Memd[op+i-1] = O_VALD(in1) else Memd[op+i-1] = O_VALD(in2) } else if (O_LEN(in2) <= 0) { # Operand 1 is a vector, operand 2 is a scalar. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovd (Memd[ip1], Memd[op], nelem) else call amovkd (O_VALD(in2), Memd[op], nelem) } else { # Conditional is a vector. call aselkd (Memd[ip1], O_VALD(in2), Memd[op], Memi[sel], nelem) } } else { # Both operands are vectors. if (O_LEN(cond) <= 0) { # Conditional is a scalar. if (O_VALI(cond) != 0) call amovd (Memd[ip1], Memd[op], nelem) else call amovd (Memd[ip2], Memd[op], nelem) } else { # Conditional is a vector. call aseld (Memd[ip1], Memd[ip2], Memd[op], Memi[sel], nelem) } } default: call xvv_error ("evvexpr: bad datatype in cond expr") } call xvv_freeop (in1) call xvv_freeop (in2) } call xvv_freeop (cond) end # XVV_CALLFCN -- Call an intrinsic function. If the function named is not # one of the standard intrinsic functions, call an external user function # if a function call procedure was supplied. procedure xvv_callfcn (fcn, args, nargs, out) char fcn[ARB] #I function to be called pointer args[ARB] #I pointer to arglist descriptor int nargs #I number of arguments pointer out #I output operand (function value) short v_s short ahivs(), alovs() short ameds() int aravs() int v_i int ahivi(), alovi() int amedi() int aravi() long v_l long ahivl(), alovl() long amedl() int aravl() real v_r real ahivr(), alovr() real amedr() int aravr() double v_d double ahivd(), alovd() double amedd() int aravd() real mean_r, sigma_r double mean_d, sigma_d real asums(), asumi(), asumr() double asuml(), asumd() bool rangecheck int optype, opcode int chunk, repl, nelem, v_nargs, ch, shift, i, j pointer sp, sym, buf, ap, ip, op, in1, in2 include "evvexpr.com" pointer stfind() int xvv_newtype(), strlen(), gctod(), btoi() errchk xvv_chtype, xvv_initop, xvv_newtype, xvv_error1, xvv_error2 errchk zcall5, malloc string s_badtype "%s: illegal operand type" define free_ 91 begin call smark (sp) call salloc (buf, SZ_FNAME, TY_CHAR) # Lookup the function name in the symbol table. sym = stfind (ev_st, fcn) if (sym != NULL) opcode = SYM_CODE(sym) else opcode = 0 # If the function named is not a standard one and the user has supplied # the entry point of an external function evaluation procedure, call # the user procedure to evaluate the function, otherwise abort. if (opcode <= 0) if (ev_ufcn != NULL) { call zcall5 (ev_ufcn, ev_ufcn_data, fcn, args, nargs, out) if (O_TYPE(out) <= 0) call xvv_error1 ("unrecognized macro or function `%s'", fcn) goto free_ } else call xvv_error1 ("unknown function `%s' called", fcn) # Range checking on functions that need it? rangecheck = (and (ev_flags, EV_RNGCHK) != 0) # Verify correct number of arguments. switch (opcode) { case F_MOD, F_REPL, F_SHIFT: v_nargs = 2 case F_MAX, F_MIN, F_ATAN, F_ATAN2, F_MEAN, F_STDDEV, F_MEDIAN: v_nargs = -1 default: v_nargs = 1 } if (v_nargs > 0 && nargs != v_nargs) call xvv_error2 ("function `%s' requires %d arguments", fcn, v_nargs) else if (v_nargs < 0 && nargs < abs(v_nargs)) call xvv_error2 ("function `%s' requires at least %d arguments", fcn, abs(v_nargs)) # Some functions require that the input operand be a certain type, # e.g. floating. Handle the simple cases, converting input operands # to the desired type. switch (opcode) { case F_ACOS, F_ASIN, F_ATAN, F_ATAN2, F_COS, F_COSH, F_DEG, F_EXP, F_LOG, F_LOG10, F_RAD, F_SIN, F_SINH, F_SQRT, F_TAN, F_TANH: # These functions want a floating point input operand. optype = TY_REAL do i = 1, nargs { if (O_TYPE(args[i]) == TY_DOUBLE || O_TYPE(args[i]) == TY_LONG) optype = TY_DOUBLE } do i = 1, nargs { if (O_TYPE(args[i]) != optype) call xvv_chtype (args[i], args[i], optype) } call xvv_initop (out, O_LEN(args[1]), optype) case F_MOD, F_MIN, F_MAX, F_MEDIAN: # These functions may have multiple arguments, all of which # should be the same type. optype = O_TYPE(args[1]) nelem = O_LEN(args[1]) do i = 2, nargs { optype = xvv_newtype (optype, O_TYPE(args[i])) if (O_LEN(args[i]) > 0) if (nelem > 0) nelem = min (nelem, O_LEN(args[i])) else if (nelem == 0) nelem = O_LEN(args[i]) } do i = 1, nargs if (O_TYPE(args[i]) != optype) call xvv_chtype (args[i], args[i], optype) if (nargs == 1 && opcode == F_MEDIAN) nelem = 0 call xvv_initop (out, nelem, optype) case F_LEN: # This function always returns an integer scalar value. nelem = 0 optype = TY_INT call xvv_initop (out, nelem, optype) case F_HIV, F_LOV: # These functions return a scalar value. nelem = 0 optype = O_TYPE(args[1]) if (optype == TY_BOOL) optype = TY_INT call xvv_initop (out, nelem, optype) case F_SUM, F_MEAN, F_STDDEV: # These functions require a vector argument and return a scalar # value. nelem = 0 optype = O_TYPE(args[1]) if (optype == TY_BOOL) optype = TY_INT if (optype == TY_DOUBLE) call xvv_initop (out, nelem, TY_DOUBLE) else call xvv_initop (out, nelem, TY_REAL) case F_SORT, F_SHIFT: # Vector to vector, no type conversions. nelem = O_LEN(args[1]) optype = O_TYPE(args[1]) call xvv_initop (out, nelem, optype) default: optype = 0 } # Evaluate the function. ap = args[1] switch (opcode) { case F_ABS: call xvv_initop (out, O_LEN(ap), O_TYPE(ap)) switch (O_TYPE(ap)) { case TY_SHORT: if (O_LEN(ap) > 0) { call aabss (Mems[O_VALP(ap)], Mems[O_VALP(out)], O_LEN(ap)) } else O_VALS(out) = -(O_VALS(ap)) case TY_INT: if (O_LEN(ap) > 0) { call aabsi (Memi[O_VALP(ap)], Memi[O_VALP(out)], O_LEN(ap)) } else O_VALI(out) = -(O_VALI(ap)) case TY_LONG: if (O_LEN(ap) > 0) { call aabsl (Meml[O_VALP(ap)], Meml[O_VALP(out)], O_LEN(ap)) } else O_VALL(out) = -(O_VALL(ap)) case TY_REAL: if (O_LEN(ap) > 0) { call aabsr (Memr[O_VALP(ap)], Memr[O_VALP(out)], O_LEN(ap)) } else O_VALR(out) = -(O_VALR(ap)) case TY_DOUBLE: if (O_LEN(ap) > 0) { call aabsd (Memd[O_VALP(ap)], Memd[O_VALP(out)], O_LEN(ap)) } else O_VALD(out) = -(O_VALD(ap)) default: call xvv_error1 (s_badtype, fcn) } case F_ACOS: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = acos (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = acos (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = acos (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = acos (O_VALD(ap)) case F_ASIN: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = asin (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = asin (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = asin (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = asin (O_VALD(ap)) case F_COS: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = cos (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = cos (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = cos (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = cos (O_VALD(ap)) case F_COSH: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = cosh (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = cosh (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = cosh (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = cosh (O_VALD(ap)) case F_DEG: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = RADTODEG(Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = RADTODEG (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = RADTODEG(Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = RADTODEG (O_VALD(ap)) case F_EXP: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = exp (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = exp (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = exp (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = exp (O_VALD(ap)) case F_LOG: if (optype == TY_REAL) if (O_LEN(ap) > 0) { op = O_VALP(out) do i = 1, O_LEN(ap) { v_r = Memr[O_VALP(ap)+i-1] if (rangecheck && v_r <= 0) Memr[op] = 0 else Memr[op] = log (v_r) op = op + 1 } } else { v_r = O_VALR(ap) if (rangecheck && v_r <= 0) O_VALR(out) = 0 else O_VALR(out) = log (v_r) } if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { op = O_VALP(out) do i = 1, O_LEN(ap) { v_d = Memd[O_VALP(ap)+i-1] if (rangecheck && v_d <= 0) Memd[op] = 0 else Memd[op] = log (v_d) op = op + 1 } } else { v_d = O_VALD(ap) if (rangecheck && v_d <= 0) O_VALD(out) = 0 else O_VALD(out) = log (v_d) } case F_LOG10: if (optype == TY_REAL) if (O_LEN(ap) > 0) { op = O_VALP(out) do i = 1, O_LEN(ap) { v_r = Memr[O_VALP(ap)+i-1] if (rangecheck && v_r <= 0) Memr[op] = 0 else Memr[op] = log10 (v_r) op = op + 1 } } else { v_r = O_VALR(ap) if (rangecheck && v_r <= 0) O_VALR(out) = 0 else O_VALR(out) = log10 (v_r) } if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { op = O_VALP(out) do i = 1, O_LEN(ap) { v_d = Memd[O_VALP(ap)+i-1] if (rangecheck && v_d <= 0) Memd[op] = 0 else Memd[op] = log10 (v_d) op = op + 1 } } else { v_d = O_VALD(ap) if (rangecheck && v_d <= 0) O_VALD(out) = 0 else O_VALD(out) = log10 (v_d) } case F_RAD: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = DEGTORAD(Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = DEGTORAD (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = DEGTORAD(Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = DEGTORAD (O_VALD(ap)) case F_SIN: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = sin (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = sin (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = sin (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = sin (O_VALD(ap)) case F_SINH: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = sinh (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = sinh (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = sinh (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = sinh (O_VALD(ap)) case F_SQRT: if (optype == TY_REAL) if (O_LEN(ap) > 0) { op = O_VALP(out) do i = 1, O_LEN(ap) { v_r = Memr[O_VALP(ap)+i-1] if (rangecheck && v_r < 0) Memr[op] = 0 else Memr[op] = sqrt (v_r) op = op + 1 } } else { v_r = O_VALR(ap) if (rangecheck && v_r <= 0) O_VALR(out) = 0 else O_VALR(out) = sqrt (v_r) } if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { op = O_VALP(out) do i = 1, O_LEN(ap) { v_d = Memd[O_VALP(ap)+i-1] if (rangecheck && v_d < 0) Memd[op] = 0 else Memd[op] = sqrt (v_d) op = op + 1 } } else { v_d = O_VALD(ap) if (rangecheck && v_d <= 0) O_VALD(out) = 0 else O_VALD(out) = sqrt (v_d) } case F_TAN: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = tan (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = tan (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = tan (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = tan (O_VALD(ap)) case F_TANH: if (optype == TY_REAL) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = tanh (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = tanh (O_VALR(ap)) if (optype == TY_DOUBLE) if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = tanh (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = tanh (O_VALD(ap)) case F_LEN: # Vector length. O_VALI(out) = O_LEN(ap) case F_HIV: # High value. switch (optype) { case TY_SHORT: if (O_LEN(ap) > 0) O_VALS(out) = ahivs (Mems[O_VALP(ap)], O_LEN(ap)) else O_VALS(out) = O_VALS(ap) case TY_INT: if (O_LEN(ap) > 0) O_VALI(out) = ahivi (Memi[O_VALP(ap)], O_LEN(ap)) else O_VALI(out) = O_VALI(ap) case TY_LONG: if (O_LEN(ap) > 0) O_VALL(out) = ahivl (Meml[O_VALP(ap)], O_LEN(ap)) else O_VALL(out) = O_VALL(ap) case TY_REAL: if (O_LEN(ap) > 0) O_VALR(out) = ahivr (Memr[O_VALP(ap)], O_LEN(ap)) else O_VALR(out) = O_VALR(ap) case TY_DOUBLE: if (O_LEN(ap) > 0) O_VALD(out) = ahivd (Memd[O_VALP(ap)], O_LEN(ap)) else O_VALD(out) = O_VALD(ap) default: call xvv_error1 (s_badtype, fcn) } case F_LOV: # Low value. switch (optype) { case TY_SHORT: if (O_LEN(ap) > 0) O_VALS(out) = alovs (Mems[O_VALP(ap)], O_LEN(ap)) else O_VALS(out) = O_VALS(ap) case TY_INT: if (O_LEN(ap) > 0) O_VALI(out) = alovi (Memi[O_VALP(ap)], O_LEN(ap)) else O_VALI(out) = O_VALI(ap) case TY_LONG: if (O_LEN(ap) > 0) O_VALL(out) = alovl (Meml[O_VALP(ap)], O_LEN(ap)) else O_VALL(out) = O_VALL(ap) case TY_REAL: if (O_LEN(ap) > 0) O_VALR(out) = alovr (Memr[O_VALP(ap)], O_LEN(ap)) else O_VALR(out) = O_VALR(ap) case TY_DOUBLE: if (O_LEN(ap) > 0) O_VALD(out) = alovd (Memd[O_VALP(ap)], O_LEN(ap)) else O_VALD(out) = O_VALD(ap) default: call xvv_error1 (s_badtype, fcn) } case F_SUM: # Vector sum. switch (optype) { case TY_SHORT: if (O_LEN(ap) > 0) v_r = asums (Mems[O_VALP(ap)], O_LEN(ap)) else v_r = O_VALS(ap) case TY_INT: if (O_LEN(ap) > 0) v_r = asumi (Memi[O_VALP(ap)], O_LEN(ap)) else v_r = O_VALI(ap) case TY_LONG: if (O_LEN(ap) > 0) v_r = asuml (Meml[O_VALP(ap)], O_LEN(ap)) else v_r = O_VALL(ap) case TY_REAL: if (O_LEN(ap) > 0) v_r = asumr (Memr[O_VALP(ap)], O_LEN(ap)) else v_r = O_VALR(ap) case TY_DOUBLE: if (O_LEN(ap) > 0) v_d = asumd (Memd[O_VALP(ap)], O_LEN(ap)) else v_d = O_VALD(ap) default: call xvv_error1 (s_badtype, fcn) } if (optype == TY_DOUBLE) O_VALD(out) = v_d else O_VALR(out) = v_r case F_MEAN, F_STDDEV: # Compute the mean or standard deviation of a vector. An optional # second argument may be supplied to compute a K-sigma rejection # mean and sigma. if (nargs == 2) { if (O_LEN(args[2]) > 0) call xvv_error1 ("%s: ksigma arg must be a scalar" , fcn) switch (O_TYPE(args[2])) { case TY_REAL: v_r = O_VALR(args[2]) v_d = v_r case TY_DOUBLE: v_d = O_VALD(args[2]) v_r = v_d default: call xvv_chtype (args[2], args[2], TY_REAL) v_r = O_VALR(args[2]) v_d = v_r } } else { v_r = 0.0 v_d = 0.0 } switch (optype) { case TY_SHORT: v_i = aravs (Mems[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) case TY_INT: v_i = aravi (Memi[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) case TY_REAL: v_i = aravr (Memr[O_VALP(ap)], O_LEN(ap), mean_r,sigma_r,v_r) case TY_LONG: v_i = aravl (Meml[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) case TY_DOUBLE: v_i = aravd (Memd[O_VALP(ap)], O_LEN(ap), mean_d,sigma_d,v_d) default: call xvv_error1 (s_badtype, fcn) } if (opcode == F_MEAN) { if (O_TYPE(out) == TY_REAL) O_VALR(out) = mean_r else O_VALD(out) = mean_d } else { if (O_TYPE(out) == TY_REAL) O_VALR(out) = sigma_r else O_VALD(out) = sigma_d } case F_MEDIAN: # Compute the median value of a vector, or the vector median # of 3 or more vectors. switch (nargs) { case 1: switch (optype) { case TY_SHORT: O_VALS(out) = ameds (Mems[O_VALP(ap)], O_LEN(ap)) case TY_INT: O_VALI(out) = amedi (Memi[O_VALP(ap)], O_LEN(ap)) case TY_LONG: O_VALL(out) = amedl (Meml[O_VALP(ap)], O_LEN(ap)) case TY_REAL: O_VALR(out) = amedr (Memr[O_VALP(ap)], O_LEN(ap)) case TY_DOUBLE: O_VALD(out) = amedd (Memd[O_VALP(ap)], O_LEN(ap)) default: call xvv_error1 (s_badtype, fcn) } case 3: switch (optype) { case TY_SHORT: call amed3s (Mems[O_VALP(args[1])], Mems[O_VALP(args[2])], Mems[O_VALP(args[3])], Mems[O_VALP(out)], nelem) case TY_INT: call amed3i (Memi[O_VALP(args[1])], Memi[O_VALP(args[2])], Memi[O_VALP(args[3])], Memi[O_VALP(out)], nelem) case TY_LONG: call amed3l (Meml[O_VALP(args[1])], Meml[O_VALP(args[2])], Meml[O_VALP(args[3])], Meml[O_VALP(out)], nelem) case TY_REAL: call amed3r (Memr[O_VALP(args[1])], Memr[O_VALP(args[2])], Memr[O_VALP(args[3])], Memr[O_VALP(out)], nelem) case TY_DOUBLE: call amed3d (Memd[O_VALP(args[1])], Memd[O_VALP(args[2])], Memd[O_VALP(args[3])], Memd[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case 4: switch (optype) { case TY_SHORT: call amed4s (Mems[O_VALP(args[1])], Mems[O_VALP(args[2])], Mems[O_VALP(args[3])], Mems[O_VALP(args[4])], Mems[O_VALP(out)], nelem) case TY_INT: call amed4i (Memi[O_VALP(args[1])], Memi[O_VALP(args[2])], Memi[O_VALP(args[3])], Memi[O_VALP(args[4])], Memi[O_VALP(out)], nelem) case TY_LONG: call amed4l (Meml[O_VALP(args[1])], Meml[O_VALP(args[2])], Meml[O_VALP(args[3])], Meml[O_VALP(args[4])], Meml[O_VALP(out)], nelem) case TY_REAL: call amed4r (Memr[O_VALP(args[1])], Memr[O_VALP(args[2])], Memr[O_VALP(args[3])], Memr[O_VALP(args[4])], Memr[O_VALP(out)], nelem) case TY_DOUBLE: call amed4d (Memd[O_VALP(args[1])], Memd[O_VALP(args[2])], Memd[O_VALP(args[3])], Memd[O_VALP(args[4])], Memd[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case 5: switch (optype) { case TY_SHORT: call amed5s (Mems[O_VALP(args[1])], Mems[O_VALP(args[2])], Mems[O_VALP(args[3])], Mems[O_VALP(args[4])], Mems[O_VALP(args[5])], Mems[O_VALP(out)], nelem) case TY_INT: call amed5i (Memi[O_VALP(args[1])], Memi[O_VALP(args[2])], Memi[O_VALP(args[3])], Memi[O_VALP(args[4])], Memi[O_VALP(args[5])], Memi[O_VALP(out)], nelem) case TY_LONG: call amed5l (Meml[O_VALP(args[1])], Meml[O_VALP(args[2])], Meml[O_VALP(args[3])], Meml[O_VALP(args[4])], Meml[O_VALP(args[5])], Meml[O_VALP(out)], nelem) case TY_REAL: call amed5r (Memr[O_VALP(args[1])], Memr[O_VALP(args[2])], Memr[O_VALP(args[3])], Memr[O_VALP(args[4])], Memr[O_VALP(args[5])], Memr[O_VALP(out)], nelem) case TY_DOUBLE: call amed5d (Memd[O_VALP(args[1])], Memd[O_VALP(args[2])], Memd[O_VALP(args[3])], Memd[O_VALP(args[4])], Memd[O_VALP(args[5])], Memd[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } default: call xvv_error1 ("%s: wrong number of arguments", fcn) } case F_REPL: # Replicate an item to make a longer vector. chunk = O_LEN(ap) optype = O_TYPE(ap) if (optype == TY_BOOL) optype = TY_INT if (O_LEN(args[2]) > 0) call xvv_error1 ("%s: replication factor must be a scalar", fcn) if (O_TYPE(args[2]) != TY_INT) call xvv_chtype (args[2], args[2], TY_INT) repl = max (1, O_VALI(args[2])) if (chunk <= 0) nelem = repl else nelem = chunk * repl call xvv_initop (out, nelem, optype) switch (optype) { case TY_SHORT: if (chunk > 0) { ip = O_VALP(ap) op = O_VALP(out) do i = 1, repl { call amovs (Mems[ip], Mems[op], chunk) op = op + chunk } } else call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) case TY_INT: if (chunk > 0) { ip = O_VALP(ap) op = O_VALP(out) do i = 1, repl { call amovi (Memi[ip], Memi[op], chunk) op = op + chunk } } else call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) case TY_LONG: if (chunk > 0) { ip = O_VALP(ap) op = O_VALP(out) do i = 1, repl { call amovl (Meml[ip], Meml[op], chunk) op = op + chunk } } else call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) case TY_REAL: if (chunk > 0) { ip = O_VALP(ap) op = O_VALP(out) do i = 1, repl { call amovr (Memr[ip], Memr[op], chunk) op = op + chunk } } else call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) case TY_DOUBLE: if (chunk > 0) { ip = O_VALP(ap) op = O_VALP(out) do i = 1, repl { call amovd (Memd[ip], Memd[op], chunk) op = op + chunk } } else call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case F_SHIFT: # Vector shift. if (O_LEN(args[2]) > 0) call xvv_error1 ("%s: shift arg must be a scalar" , fcn) if (O_TYPE(args[2]) != TY_INT) call xvv_chtype (args[2], args[2], TY_INT) shift = O_VALI(args[2]) if (abs(shift) > nelem) { if (shift > 0) shift = nelem else shift = -nelem } switch (optype) { case TY_SHORT: if (nelem > 0) { do i = 1, nelem { j = i - shift if (j < 1) j = j + nelem else if (j > nelem) j = j - nelem Mems[O_VALP(out)+i-1] = Mems[O_VALP(ap)+j-1] } } else O_VALS(out) = (O_VALS(ap)) case TY_INT: if (nelem > 0) { do i = 1, nelem { j = i - shift if (j < 1) j = j + nelem else if (j > nelem) j = j - nelem Memi[O_VALP(out)+i-1] = Memi[O_VALP(ap)+j-1] } } else O_VALI(out) = (O_VALI(ap)) case TY_LONG: if (nelem > 0) { do i = 1, nelem { j = i - shift if (j < 1) j = j + nelem else if (j > nelem) j = j - nelem Meml[O_VALP(out)+i-1] = Meml[O_VALP(ap)+j-1] } } else O_VALL(out) = (O_VALL(ap)) case TY_REAL: if (nelem > 0) { do i = 1, nelem { j = i - shift if (j < 1) j = j + nelem else if (j > nelem) j = j - nelem Memr[O_VALP(out)+i-1] = Memr[O_VALP(ap)+j-1] } } else O_VALR(out) = (O_VALR(ap)) case TY_DOUBLE: if (nelem > 0) { do i = 1, nelem { j = i - shift if (j < 1) j = j + nelem else if (j > nelem) j = j - nelem Memd[O_VALP(out)+i-1] = Memd[O_VALP(ap)+j-1] } } else O_VALD(out) = (O_VALD(ap)) default: call xvv_error1 (s_badtype, fcn) } case F_SORT: # Sort a vector. switch (optype) { case TY_SHORT: if (nelem > 0) call asrts (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) else O_VALS(out) = (O_VALS(ap)) case TY_INT: if (nelem > 0) call asrti (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) else O_VALI(out) = (O_VALI(ap)) case TY_LONG: if (nelem > 0) call asrtl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) else O_VALL(out) = (O_VALL(ap)) case TY_REAL: if (nelem > 0) call asrtr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) else O_VALR(out) = (O_VALR(ap)) case TY_DOUBLE: if (nelem > 0) call asrtd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) else O_VALD(out) = (O_VALD(ap)) default: call xvv_error1 (s_badtype, fcn) } case F_ATAN, F_ATAN2: if (optype == TY_REAL) { if (nargs == 1) { if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = atan (Memr[O_VALP(ap)+i-1]) } else O_VALR(out) = atan (O_VALR(ap)) } else { if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memr[O_VALP(out)+i-1] = atan2 (Memr[O_VALP(args[1])+i-1], Memr[O_VALP(args[2])+i-1]) } else O_VALR(out) = atan2(O_VALR(args[1]), O_VALR(args[2])) } } if (optype == TY_DOUBLE) { if (nargs == 1) { if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = atan (Memd[O_VALP(ap)+i-1]) } else O_VALD(out) = atan (O_VALD(ap)) } else { if (O_LEN(ap) > 0) { do i = 1, O_LEN(ap) Memd[O_VALP(out)+i-1] = atan2 (Memd[O_VALP(args[1])+i-1], Memd[O_VALP(args[2])+i-1]) } else O_VALD(out) = atan2(O_VALD(args[1]), O_VALD(args[2])) } } case F_MOD: in1 = args[1] in2 = args[2] call eprintf ("types: %d %d, lengths: %d %d\n") call pargi (O_TYPE(in1)) call pargi (O_TYPE(in2)) call pargi (O_LEN(in1)) call pargi (O_LEN(in2)) switch (optype) { case TY_SHORT: if (O_LEN(in1) <= 0) { O_VALS(out) = mod (O_VALS(in1), O_VALS(in2)) } else if (O_LEN(in2) <= 0) { call amodks (Mems[O_VALP(in1)], O_VALS(in2), Mems[O_VALP(out)], nelem) } else { call amods (Mems[O_VALP(in1)], Mems[O_VALP(in2)], Mems[O_VALP(out)], nelem) } case TY_INT: if (O_LEN(in1) <= 0) { O_VALI(out) = mod (O_VALI(in1), O_VALI(in2)) } else if (O_LEN(in2) <= 0) { call amodki (Memi[O_VALP(in1)], O_VALI(in2), Memi[O_VALP(out)], nelem) } else { call amodi (Memi[O_VALP(in1)], Memi[O_VALP(in2)], Memi[O_VALP(out)], nelem) } case TY_LONG: if (O_LEN(in1) <= 0) { O_VALL(out) = mod (O_VALL(in1), O_VALL(in2)) } else if (O_LEN(in2) <= 0) { call amodkl (Meml[O_VALP(in1)], O_VALL(in2), Meml[O_VALP(out)], nelem) } else { call amodl (Meml[O_VALP(in1)], Meml[O_VALP(in2)], Meml[O_VALP(out)], nelem) } case TY_REAL: if (O_LEN(in1) <= 0) { O_VALR(out) = mod (O_VALR(in1), O_VALR(in2)) } else if (O_LEN(in2) <= 0) { call amodkr (Memr[O_VALP(in1)], O_VALR(in2), Memr[O_VALP(out)], nelem) } else { call amodr (Memr[O_VALP(in1)], Memr[O_VALP(in2)], Memr[O_VALP(out)], nelem) } case TY_DOUBLE: if (O_LEN(in1) <= 0) { O_VALD(out) = mod (O_VALD(in1), O_VALD(in2)) } else if (O_LEN(in2) <= 0) { call amodkd (Memd[O_VALP(in1)], O_VALD(in2), Memd[O_VALP(out)], nelem) } else { call amodd (Memd[O_VALP(in1)], Memd[O_VALP(in2)], Memd[O_VALP(out)], nelem) } default: call xvv_error1 (s_badtype, fcn) } case F_MAX: switch (optype) { case TY_SHORT: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) else O_VALS(out) = O_VALS(ap) } else call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALS(out) = max (O_VALS(ap), O_VALS(out)) else { call amaxks (Mems[O_VALP(out)], O_VALS(ap), Mems[O_VALP(out)], nelem) } } else { call amaxs (Mems[O_VALP(out)], Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) } } case TY_INT: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) else O_VALI(out) = O_VALI(ap) } else call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALI(out) = max (O_VALI(ap), O_VALI(out)) else { call amaxki (Memi[O_VALP(out)], O_VALI(ap), Memi[O_VALP(out)], nelem) } } else { call amaxi (Memi[O_VALP(out)], Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) } } case TY_LONG: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) else O_VALL(out) = O_VALL(ap) } else call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALL(out) = max (O_VALL(ap), O_VALL(out)) else { call amaxkl (Meml[O_VALP(out)], O_VALL(ap), Meml[O_VALP(out)], nelem) } } else { call amaxl (Meml[O_VALP(out)], Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) } } case TY_REAL: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) else O_VALR(out) = O_VALR(ap) } else call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALR(out) = max (O_VALR(ap), O_VALR(out)) else { call amaxkr (Memr[O_VALP(out)], O_VALR(ap), Memr[O_VALP(out)], nelem) } } else { call amaxr (Memr[O_VALP(out)], Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) } } case TY_DOUBLE: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) else O_VALD(out) = O_VALD(ap) } else call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALD(out) = max (O_VALD(ap), O_VALD(out)) else { call amaxkd (Memd[O_VALP(out)], O_VALD(ap), Memd[O_VALP(out)], nelem) } } else { call amaxd (Memd[O_VALP(out)], Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) } } default: call xvv_error1 (s_badtype, fcn) } case F_MIN: switch (optype) { case TY_SHORT: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovks (O_VALS(ap), Mems[O_VALP(out)], nelem) else O_VALS(out) = O_VALS(ap) } else call amovs (Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALS(out) = min (O_VALS(ap), O_VALS(out)) else { call aminks (Mems[O_VALP(out)], O_VALS(ap), Mems[O_VALP(out)], nelem) } } else { call amins (Mems[O_VALP(out)], Mems[O_VALP(ap)], Mems[O_VALP(out)], nelem) } } case TY_INT: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovki (O_VALI(ap), Memi[O_VALP(out)], nelem) else O_VALI(out) = O_VALI(ap) } else call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALI(out) = min (O_VALI(ap), O_VALI(out)) else { call aminki (Memi[O_VALP(out)], O_VALI(ap), Memi[O_VALP(out)], nelem) } } else { call amini (Memi[O_VALP(out)], Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) } } case TY_LONG: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovkl (O_VALL(ap), Meml[O_VALP(out)], nelem) else O_VALL(out) = O_VALL(ap) } else call amovl (Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALL(out) = min (O_VALL(ap), O_VALL(out)) else { call aminkl (Meml[O_VALP(out)], O_VALL(ap), Meml[O_VALP(out)], nelem) } } else { call aminl (Meml[O_VALP(out)], Meml[O_VALP(ap)], Meml[O_VALP(out)], nelem) } } case TY_REAL: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovkr (O_VALR(ap), Memr[O_VALP(out)], nelem) else O_VALR(out) = O_VALR(ap) } else call amovr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALR(out) = min (O_VALR(ap), O_VALR(out)) else { call aminkr (Memr[O_VALP(out)], O_VALR(ap), Memr[O_VALP(out)], nelem) } } else { call aminr (Memr[O_VALP(out)], Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) } } case TY_DOUBLE: # Copy the first argument. ap = args[1] if (O_LEN(ap) <= 0) { if (O_LEN(out) > 0) call amovkd (O_VALD(ap), Memd[O_VALP(out)], nelem) else O_VALD(out) = O_VALD(ap) } else call amovd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) # Process the second and remaining arguments. do i = 2, nargs { ap = args[i] if (O_LEN(ap) <= 0) { if (O_LEN(out) <= 0) O_VALD(out) = min (O_VALD(ap), O_VALD(out)) else { call aminkd (Memd[O_VALP(out)], O_VALD(ap), Memd[O_VALP(out)], nelem) } } else { call amind (Memd[O_VALP(out)], Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) } } default: call xvv_error1 (s_badtype, fcn) } case F_BOOL: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_BOOL) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALI(ap) else call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_CHAR: ch = O_VALC(ap) O_VALI(out) = btoi (ch == 'y' || ch == 'Y') case TY_SHORT: if (O_LEN(ap) <= 0) O_VALI(out) = btoi (O_VALS(ap) != 0) else { v_s = 0 call abneks (Mems[O_VALP(ap)], v_s, Memi[O_VALP(out)], nelem) } case TY_INT: if (O_LEN(ap) <= 0) O_VALI(out) = btoi (O_VALI(ap) != 0) else { v_i = 0 call abneki (Memi[O_VALP(ap)], v_i, Memi[O_VALP(out)], nelem) } case TY_LONG: if (O_LEN(ap) <= 0) O_VALI(out) = btoi (O_VALL(ap) != 0) else { v_l = 0 call abnekl (Meml[O_VALP(ap)], v_l, Memi[O_VALP(out)], nelem) } case TY_REAL: if (O_LEN(ap) <= 0) O_VALI(out) = btoi (O_VALR(ap) != 0.0) else { v_r = 0.0 call abnekr (Memr[O_VALP(ap)], v_r, Memi[O_VALP(out)], nelem) } case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALI(out) = btoi (O_VALD(ap) != 0.0D0) else { v_d = 0.0D0 call abnekd (Memd[O_VALP(ap)], v_d, Memi[O_VALP(out)], nelem) } default: call xvv_error1 (s_badtype, fcn) } case F_SHORT: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_SHORT) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALS(out) = O_VALI(ap) else call achtis (Memi[O_VALP(ap)], Mems[O_VALP(out)], nelem) case TY_CHAR: ip = O_VALP(ap) if (gctod (Memc, ip, v_d) <= 0) O_VALS(out) = 0 else O_VALS(out) = v_d case TY_SHORT: if (O_LEN(ap) <= 0) O_VALS(out) = O_VALS(ap) else call achtss (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_INT: if (O_LEN(ap) <= 0) O_VALS(out) = O_VALI(ap) else call achtis (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_LONG: if (O_LEN(ap) <= 0) O_VALS(out) = O_VALL(ap) else call achtls (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_REAL: if (O_LEN(ap) <= 0) O_VALS(out) = O_VALR(ap) else call achtrs (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALS(out) = O_VALD(ap) else call achtds (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case F_INT: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_INT) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALI(ap) else call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_CHAR: ip = O_VALP(ap) if (gctod (Memc, ip, v_d) <= 0) O_VALI(out) = 0 else O_VALI(out) = v_d case TY_SHORT: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALS(ap) else call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_INT: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALI(ap) else call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_LONG: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALL(ap) else call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_REAL: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALR(ap) else call achtri (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALD(ap) else call achtdi (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case F_LONG: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_LONG) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALL(out) = O_VALI(ap) else call amovi (Memi[O_VALP(ap)], Meml[O_VALP(out)], nelem) case TY_CHAR: ip = O_VALP(ap) if (gctod (Memc, ip, v_d) <= 0) O_VALL(out) = 0 else O_VALL(out) = v_d case TY_SHORT: if (O_LEN(ap) <= 0) O_VALL(out) = O_VALS(ap) else call achtsl (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_INT: if (O_LEN(ap) <= 0) O_VALL(out) = O_VALI(ap) else call achtil (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_LONG: if (O_LEN(ap) <= 0) O_VALL(out) = O_VALL(ap) else call achtll (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_REAL: if (O_LEN(ap) <= 0) O_VALL(out) = O_VALR(ap) else call achtrl (Memr[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALL(out) = O_VALD(ap) else call achtdl (Memd[O_VALP(ap)], Memi[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case F_NINT: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_INT) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALI(ap) else call amovi (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_CHAR: ip = O_VALP(ap) if (gctod (Memc, ip, v_d) <= 0) O_VALI(out) = 0 else O_VALI(out) = nint (v_d) case TY_SHORT: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALS(ap) else call achtsi (Mems[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_INT: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALI(ap) else call achtii (Memi[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_LONG: if (O_LEN(ap) <= 0) O_VALI(out) = O_VALL(ap) else call achtli (Meml[O_VALP(ap)], Memi[O_VALP(out)], nelem) case TY_REAL: if (O_LEN(ap) <= 0) O_VALI(out) = nint (O_VALR(ap)) else { do i = 1, nelem Memi[O_VALP(out)+i-1] = nint (Memr[O_VALP(ap)+i-1]) } case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALI(out) = nint (O_VALD(ap)) else { do i = 1, nelem Memi[O_VALP(out)+i-1] = nint (Memd[O_VALP(ap)+i-1]) } default: call xvv_error1 (s_badtype, fcn) } case F_REAL: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_REAL) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALR(out) = O_VALI(ap) else call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) case TY_CHAR: ip = O_VALP(ap) if (gctod (Memc, ip, v_d) <= 0) O_VALR(out) = 0 else O_VALR(out) = v_d case TY_SHORT: if (O_LEN(ap) <= 0) O_VALR(out) = O_VALS(ap) else call achtsr (Mems[O_VALP(ap)], Memr[O_VALP(out)], nelem) case TY_INT: if (O_LEN(ap) <= 0) O_VALR(out) = O_VALI(ap) else call achtir (Memi[O_VALP(ap)], Memr[O_VALP(out)], nelem) case TY_LONG: if (O_LEN(ap) <= 0) O_VALR(out) = O_VALL(ap) else call achtlr (Meml[O_VALP(ap)], Memr[O_VALP(out)], nelem) case TY_REAL: if (O_LEN(ap) <= 0) O_VALR(out) = O_VALR(ap) else call achtrr (Memr[O_VALP(ap)], Memr[O_VALP(out)], nelem) case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALR(out) = O_VALD(ap) else call achtdr (Memd[O_VALP(ap)], Memr[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case F_DOUBLE: nelem = 0 if (O_LEN(ap) > 0 && O_TYPE(ap) != TY_CHAR) nelem = O_LEN(ap) call xvv_initop (out, nelem, TY_DOUBLE) switch (O_TYPE(ap)) { case TY_BOOL: if (O_LEN(ap) <= 0) O_VALD(out) = O_VALI(ap) else call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) case TY_CHAR: ip = O_VALP(ap) if (gctod (Memc, ip, v_d) <= 0) O_VALD(out) = 0 else O_VALD(out) = v_d case TY_SHORT: if (O_LEN(ap) <= 0) O_VALD(out) = O_VALS(ap) else call achtsd (Mems[O_VALP(ap)], Memd[O_VALP(out)], nelem) case TY_INT: if (O_LEN(ap) <= 0) O_VALD(out) = O_VALI(ap) else call achtid (Memi[O_VALP(ap)], Memd[O_VALP(out)], nelem) case TY_LONG: if (O_LEN(ap) <= 0) O_VALD(out) = O_VALL(ap) else call achtld (Meml[O_VALP(ap)], Memd[O_VALP(out)], nelem) case TY_REAL: if (O_LEN(ap) <= 0) O_VALD(out) = O_VALR(ap) else call achtrd (Memr[O_VALP(ap)], Memd[O_VALP(out)], nelem) case TY_DOUBLE: if (O_LEN(ap) <= 0) O_VALD(out) = O_VALD(ap) else call achtdd (Memd[O_VALP(ap)], Memd[O_VALP(out)], nelem) default: call xvv_error1 (s_badtype, fcn) } case F_STR: optype = TY_CHAR if (O_TYPE(ap) == TY_CHAR) nelem = strlen (O_VALC(ap)) else nelem = MAX_DIGITS call xvv_initop (out, nelem, TY_CHAR) switch (O_TYPE(ap)) { case TY_BOOL: call sprintf (O_VALC(out), nelem, "%b") call pargi (O_VALI(ap)) case TY_CHAR: call sprintf (O_VALC(out), nelem, "%s") call pargstr (O_VALC(ap)) case TY_SHORT: call sprintf (O_VALC(out), nelem, "%d") call pargs (O_VALS(ap)) case TY_INT: call sprintf (O_VALC(out), nelem, "%d") call pargi (O_VALI(ap)) case TY_LONG: call sprintf (O_VALC(out), nelem, "%d") call pargl (O_VALL(ap)) case TY_REAL: call sprintf (O_VALC(out), nelem, "%g") call pargr (O_VALR(ap)) case TY_DOUBLE: call sprintf (O_VALC(out), nelem, "%g") call pargd (O_VALD(ap)) default: call xvv_error1 (s_badtype, fcn) } default: call xvv_error ("callfcn: unknown function type") } free_ # Free any storage used by the argument list operands. do i = 1, nargs call xvv_freeop (args[i]) call sfree (sp) end # XVV_STARTARGLIST -- Allocate an argument list descriptor to receive # arguments as a function call is parsed. We are called with either # zero or one arguments. The argument list descriptor is pointed to by # a ficticious operand. The descriptor itself contains a count of the # number of arguments, an array of pointers to the operand structures, # as well as storage for the operand structures. The operands must be # stored locally since the parser will discard its copy of the operand # structure for each argument as the associated grammar rule is reduced. procedure xvv_startarglist (arg, out) pointer arg #I pointer to first argument, or NULL pointer out #I output operand pointing to arg descriptor pointer ap errchk xvv_initop begin call xvv_initop (out, LEN_ARGSTRUCT, TY_STRUCT) ap = O_VALP(out) if (arg == NULL) A_NARGS(ap) = 0 else { A_NARGS(ap) = 1 A_ARGP(ap,1) = A_OPS(ap) YYMOVE (arg, A_OPS(ap)) } end # XVV_ADDARG -- Add an argument to the argument list for a function call. procedure xvv_addarg (arg, arglist, out) pointer arg #I pointer to argument to be added pointer arglist #I pointer to operand pointing to arglist pointer out #I output operand pointing to arg descriptor pointer ap, o int nargs begin ap = O_VALP(arglist) nargs = A_NARGS(ap) + 1 A_NARGS(ap) = nargs if (nargs > MAX_ARGS) call xvv_error ("too many function arguments") o = A_OPS(ap) + ((nargs - 1) * LEN_OPERAND) A_ARGP(ap,nargs) = o YYMOVE (arg, o) YYMOVE (arglist, out) end # XVV_ERROR1 -- Take an error action, formatting an error message with one # format string plus one string argument. procedure xvv_error1 (fmt, arg) char fmt[ARB] #I printf format string char arg[ARB] #I string argument pointer sp, buf begin call smark (sp) call salloc (buf, SZ_LINE, TY_CHAR) call sprintf (Memc[buf], SZ_LINE, fmt) call pargstr (arg) call xvv_error (Memc[buf]) call sfree (sp) end # XVV_ERROR2 -- Take an error action, formatting an error message with one # format string plus one string argument and one integer argument. procedure xvv_error2 (fmt, arg1, arg2) char fmt[ARB] #I printf format string char arg1[ARB] #I string argument int arg2 #I integer argument pointer sp, buf begin call smark (sp) call salloc (buf, SZ_LINE, TY_CHAR) call sprintf (Memc[buf], SZ_LINE, fmt) call pargstr (arg1) call pargi (arg2) call xvv_error (Memc[buf]) call sfree (sp) end # XVV_ERROR -- Take an error action, given an error message string as the # sole argument. procedure xvv_error (errmsg) char errmsg[ARB] #I error message begin call error (1, errmsg) end # XVV_GETTOK -- Lexical analyzer for EVVEXPR. Returns the token code as the # function value. If the token is an operand (identifier or constant) the # operand value is returned in OUT. int procedure xvv_gettok (ip, out) pointer ip #I pointer into input string (expression) pointer out #I pointer to yacc YYLVAL token value operand char ch long lval double dval pointer ip_start char numbuf[MAX_DIGITS] int nchars, token, junk, dtype int stridx(), stridxs(), lexnum(), gctod(), gctol() define ident_ 91 begin while (IS_WHITE(Memc[ip])) ip = ip + 1 ch = Memc[ip] switch (ch) { case 'A', 'B', 'C', 'D', 'E', 'F', 'G', 'H', 'J', 'K', 'L', 'M', 'N', 'O', 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 'X', 'Y', 'Z', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 'x', 'y', 'z': # Return an identifier. ident_ ip_start = ip while (IS_ALNUM(ch) || stridx (ch, "_.$@#%&;[]\\^{}~") > 0) { ip = ip + 1 ch = Memc[ip] } nchars = ip - ip_start call xvv_initop (out, nchars, TY_CHAR) call strcpy (Memc[ip_start], O_VALC(out), nchars) return (IDENTIFIER) case 'I', '.', '0', '1', '2', '3', '4', '5', '6', '7', '8', '9': # Return a numeric constant. The character I vectors here so # that we can check for INDEF, a legal number. token = lexnum (Memc, ip, nchars) switch (token) { case LEX_OCTAL: junk = gctol (Memc, ip, lval, 8) call xvv_initop (out, 0, TY_INT) O_VALI(out) = lval case LEX_DECIMAL: junk = gctol (Memc, ip, lval, 10) call xvv_initop (out, 0, TY_INT) O_VALI(out) = lval case LEX_HEX: junk = gctol (Memc, ip, lval, 16) call xvv_initop (out, 0, TY_INT) O_VALI(out) = lval case LEX_REAL: ip_start = ip nchars = gctod (Memc, ip, dval) call strcpy (Memc[ip], numbuf, min(nchars,MAX_DIGITS)) dtype = TY_REAL if (stridxs ("dD", numbuf) > 0 || nchars > NDIGITS_RP+3) dtype = TY_DOUBLE call xvv_initop (out, 0, dtype) if (dtype == TY_REAL) { if (IS_INDEFD (dval)) O_VALR(out) = INDEFR else O_VALR(out) = dval } else { if (IS_INDEFD (dval)) O_VALD(out) = INDEFD else O_VALD(out) = dval } default: goto ident_ } return (CONSTANT) case '\'', '"': # Return a string constant. ip_start = ip + 1 for (ip=ip+1; Memc[ip] != ch && Memc[ip] != EOS; ip=ip+1) ; nchars = ip - ip_start if (Memc[ip] == EOS) call xvv_error ("missing closing quote in string constant") else ip = ip + 1 call xvv_initop (out, nchars, TY_CHAR) call strcpy (Memc[ip_start], O_VALC(out), nchars) return (CONSTANT) case '+': token = PLUS case '-': token = MINUS case '*': if (Memc[ip+1] == '*') { ip = ip + 1 token = EXPON } else token = STAR case '/': if (Memc[ip+1] == '/') { ip = ip + 1 token = CONCAT } else token = SLASH case '?': if (Memc[ip+1] == '=') { ip = ip + 1 token = SE } else token = QUEST case ':': token = COLON case '@': token = AT case '<': if (Memc[ip+1] == '=') { ip = ip + 1 token = LE } else token = LT case '>': if (Memc[ip+1] == '=') { ip = ip + 1 token = GE } else token = GT case '!': if (Memc[ip+1] == '=') { ip = ip + 1 token = NE } else token = LNOT case '=': if (Memc[ip+1] == '=') { ip = ip + 1 token = EQ } else token = EQ case '&': if (Memc[ip+1] == '&') { ip = ip + 1 token = LAND } else token = BAND case '|': if (Memc[ip+1] == '|') { ip = ip + 1 token = LOR } else token = BOR case '^': token = BXOR case '~': token = BNOT case '(', ')', ',': token = ch default: if (ch == '\n') token = NEWLINE else if (ch == EOS) token = YYEOS else { # Anything we don't understand is assumed to be an identifier. goto ident_ } } ip = ip + 1 return (token) end # XVV_CHTYPE -- Change the datatype of an operand. The input and output # operands may be the same. procedure xvv_chtype (o1, o2, dtype) pointer o1 #I input operand pointer o2 #I output operand int dtype #I new datatype short v_s int v_i long v_l real v_r double v_d pointer vp, ip, op bool float, freeval int old_type, nelem, ch pointer coerce() int sizeof(), btoi(), gctod() string s_badtype "chtype: invalid operand type" begin old_type = O_TYPE(o1) nelem = O_LEN(o1) # No type conversion needed? if (old_type == dtype) { if (o1 != o2) { if (nelem <= 0) YYMOVE (o1, o2) else { call xvv_initop (o2, nelem, old_type) call amovc (O_VALC(o1), O_VALC(o2), nelem * sizeof(dtype)) } } return } if (nelem <= 0) { # Scalar input operand. O_TYPE(o2) = dtype O_LEN(o2) = 0 float = false # Read the old value into a local variable of type long or double. switch (old_type) { case TY_BOOL: v_l = O_VALI(o1) case TY_CHAR: v_l = 0 # null string? case TY_SHORT: v_l = O_VALS(o1) case TY_INT: v_l = O_VALI(o1) case TY_LONG: v_l = O_VALL(o1) case TY_REAL: v_d = O_VALR(o1) float = true case TY_DOUBLE: v_d = O_VALD(o1) float = true default: call xvv_error (s_badtype) } # Set the value of the output operand. switch (dtype) { case TY_BOOL: if (float) O_VALI(o2) = btoi (v_d != 0) else O_VALI(o2) = btoi (v_l != 0) case TY_CHAR: call xvv_initop (o2, MAX_DIGITS, TY_CHAR) if (float) { call sprintf (O_VALC(o2), MAX_DIGITS, "%g") call pargd (v_d) } else { call sprintf (O_VALC(o2), MAX_DIGITS, "%d") call pargl (v_l) } case TY_SHORT: if (float) O_VALS(o2) = v_d else O_VALS(o2) = v_l case TY_INT: if (float) O_VALI(o2) = v_d else O_VALI(o2) = v_l case TY_LONG: if (float) O_VALL(o2) = v_d else O_VALL(o2) = v_l case TY_REAL: if (float) O_VALR(o2) = v_d else O_VALR(o2) = v_l case TY_DOUBLE: if (float) O_VALD(o2) = v_d else O_VALD(o2) = v_l default: call xvv_error (s_badtype) } } else { # Vector input operand. # Save a pointer to the input operand data vector, to avoid it # getting clobbered if O1 and O2 are the same operand. vp = O_VALP(o1) # If we have a char string input operand the output numeric # operand can only be a scalar. If we have a char string output # operand nelem is the length of the string. if (old_type == TY_CHAR) nelem = 0 else if (dtype == TY_CHAR) nelem = MAX_DIGITS # Initialize the output operand O2. The freeval flag is cleared # cleared to keep the initop from freeing the input operand array, # inherited when the input operand is copied (or when the input # and output operands are the same). We free the old operand # array manually below. if (o1 != o2) YYMOVE (o1, o2) freeval = (and (O_FLAGS(o1), O_FREEVAL) != 0) O_FLAGS(o2) = and (O_FLAGS(o2), not(O_FREEVAL)) call xvv_initop (o2, nelem, dtype) # Write output value. switch (dtype) { case TY_BOOL: if (old_type == TY_CHAR) { ch = Memc[vp] O_VALI(o2) = btoi (ch == 'y' || ch == 'Y') } else { switch (old_type) { case TY_SHORT: v_s = 0 call abneks (Mems[vp], v_s, Memi[O_VALP(o2)], nelem) case TY_INT: v_i = 0 call abneki (Memi[vp], v_i, Memi[O_VALP(o2)], nelem) case TY_LONG: v_l = 0 call abnekl (Meml[vp], v_l, Memi[O_VALP(o2)], nelem) case TY_REAL: v_r = 0.0 call abnekr (Memr[vp], v_r, Memi[O_VALP(o2)], nelem) case TY_DOUBLE: v_d = 0.0D0 call abnekd (Memd[vp], v_d, Memi[O_VALP(o2)], nelem) default: call xvv_error (s_badtype) } } case TY_CHAR: call xvv_error (s_badtype) case TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE: switch (old_type) { case TY_BOOL: op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) call achti (Memi[vp], Memc[op], nelem, dtype) case TY_CHAR: ip = vp if (gctod (Memc, ip, v_d) <= 0) v_d = 0 switch (dtype) { case TY_SHORT: O_VALS(o2) = v_d case TY_INT: O_VALI(o2) = v_d case TY_LONG: O_VALL(o2) = v_d case TY_REAL: O_VALR(o2) = v_d case TY_DOUBLE: O_VALD(o2) = v_d } case TY_SHORT: op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) call achts (Mems[vp], Memc[op], nelem, dtype) case TY_INT: op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) call achti (Memi[vp], Memc[op], nelem, dtype) case TY_LONG: op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) call achtl (Meml[vp], Memc[op], nelem, dtype) case TY_REAL: op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) call achtr (Memr[vp], Memc[op], nelem, dtype) case TY_DOUBLE: op = coerce (O_VALP(o2), O_TYPE(o2), TY_CHAR) call achtd (Memd[vp], Memc[op], nelem, dtype) default: call xvv_error (s_badtype) } default: call xvv_error (s_badtype) } # Free old operand value. if (freeval) call mfree (vp, old_type) } end # XVV_INITOP -- Initialize an operand, providing storage for an operand value # of the given size and type. procedure xvv_initop (o, o_len, o_type) pointer o #I pointer to operand structure int o_len #I length of operand (zero if scalar) int o_type #I datatype of operand begin O_LEN(o) = 0 call xvv_makeop (o, o_len, o_type) end # XVV_MAKEOP -- Set up the operand structure. If the operand structure has # already been initialized and array storage allocated, free the old array. procedure xvv_makeop (o, o_len, o_type) pointer o #I pointer to operand structure int o_len #I length of operand (zero if scalar) int o_type #I datatype of operand errchk malloc begin # Free old array storage if any. if (O_TYPE(o) != 0 && O_LEN(o) > 0) if (and (O_FLAGS(o), O_FREEVAL) != 0) { if (O_TYPE(o) == TY_BOOL) call mfree (O_VALP(o), TY_INT) else call mfree (O_VALP(o), O_TYPE(o)) O_LEN(o) = 0 } # Set new operand type. O_TYPE(o) = o_type # Allocate array storage if nonscalar operand. if (o_len > 0) { if (o_type == TY_BOOL) call malloc (O_VALP(o), o_len, TY_INT) else call malloc (O_VALP(o), o_len, o_type) O_LEN(o) = o_len } O_FLAGS(o) = O_FREEVAL end # XVV_FREEOP -- Reinitialize an operand structure, i.e., free any associated # array storage and clear the operand datatype field, but do not free the # operand structure itself (which may be only a segment of an array and not # a separately allocated structure). procedure xvv_freeop (o) pointer o #I pointer to operand structure begin # Free old array storage if any. if (O_TYPE(o) != 0 && O_LEN(o) > 0) { call eprintf ("Here 1\n") if (and (O_FLAGS(o), O_FREEVAL) != 0) { call eprintf ("Here 2\n") if (O_TYPE(o) == TY_BOOL) call mfree (O_VALP(o), TY_INT) else call mfree (O_VALP(o), O_TYPE(o)) call eprintf ("Here 3\n") O_LEN(o) = 0 } } # Either free operand struct or clear the operand type to mark # operand invalid. call eprintf ("Here 4\n") if (and (O_FLAGS(o), O_FREEOP) != 0) call mfree (o, TY_STRUCT) else O_TYPE(o) = 0 end # XVV_LOADSYMBOLS -- Load a list of symbol names into a symbol table. Each # symbol is tagged with an integer code corresponding to its sequence number # in the symbol list. pointer procedure xvv_loadsymbols (s) char s[ARB] #I symbol list "|sym1|sym2|...|" int delim, symnum, ip pointer sp, symname, st, sym, op pointer stopen(), stenter() begin call smark (sp) call salloc (symname, SZ_FNAME, TY_CHAR) st = stopen ("evvexpr", LEN_INDEX, LEN_STAB, LEN_SBUF) delim = s[1] symnum = 0 for (ip=2; s[ip] != EOS; ip=ip+1) { op = symname while (s[ip] != delim && s[ip] != EOS) { Memc[op] = s[ip] op = op + 1 ip = ip + 1 } Memc[op] = EOS symnum = symnum + 1 if (op > symname && IS_ALPHA(Memc[symname])) { sym = stenter (st, Memc[symname], LEN_SYM) SYM_CODE(sym) = symnum } } call sfree (sp) return (st) end # XVV_NULL -- Return a null value to be used when a computation cannot be # performed and range checking is enabled. Perhaps we should permit a user # specified value here, however this doesn't really work in an expression # evaluator since the value generated may be used in subsequent calculations # and hence may change. If more careful treatment of out of range values # is needed a conditional expression can be used in which case the value # we return here is ignored (but still needed to avoid a hardware exception # when computing a vector). short procedure xvv_nulls (ignore) short ignore #I ignored begin return (0) end int procedure xvv_nulli (ignore) int ignore #I ignored begin return (0) end long procedure xvv_nulll (ignore) long ignore #I ignored begin return (0) end real procedure xvv_nullr (ignore) real ignore #I ignored begin return (0.0) end double procedure xvv_nulld (ignore) double ignore #I ignored begin return (0.0D0) end define YYNPROD 39 define YYLAST 303 # Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. # Parser for yacc output, translated to the IRAF SPP language. The contents # of this file form the bulk of the source of the parser produced by Yacc. # Yacc recognizes several macros in the yaccpar input source and replaces # them as follows: # A user suppled "global" definitions and declarations # B parser tables # C user supplied actions (reductions) # The remainder of the yaccpar code is not changed. define yystack_ 10 # statement labels for gotos define yynewstate_ 20 define yydefault_ 30 define yyerrlab_ 40 define yyabort_ 50 define YYFLAG (-1000) # defs used in user actions define YYERROR goto yyerrlab_ define YYACCEPT return (OK) define YYABORT return (ERR) # YYPARSE -- Parse the input stream, returning OK if the source is # syntactically acceptable (i.e., if compilation is successful), # otherwise ERR. The parameters YYMAXDEPTH and YYOPLEN must be # supplied by the caller in the %{ ... %} section of the Yacc source. # The token value stack is a dynamically allocated array of operand # structures, with the length and makeup of the operand structure being # application dependent. int procedure yyparse (fd, yydebug, yylex) int fd # stream to be parsed bool yydebug # print debugging information? int yylex() # user-supplied lexical input function extern yylex() short yys[YYMAXDEPTH] # parser stack -- stacks tokens pointer yyv # pointer to token value stack pointer yyval # value returned by action pointer yylval # value of token int yyps # token stack pointer pointer yypv # value stack pointer int yychar # current input token number int yyerrflag # error recovery flag int yynerrs # number of errors short yyj, yym # internal variables pointer yysp, yypvt short yystate, yyn int yyxi, i errchk salloc, yylex # XVV_PARSE -- SPP/Yacc parser for the evaluation of an expression passed as # a text string. Expression evaluation is carried out as the expression is # parsed, rather than being broken into separate compile and execute stages. # There is only one statement in this grammar, the expression. Our function # is to reduce an expression to a single value of type bool, string, int, # or real. pointer ap bool streq() errchk zcall3, xvv_error1, xvv_unop, xvv_binop, xvv_boolop errchk xvv_quest, xvv_callfcn, xvv_addarg include "evvexpr.com" short yyexca[96] data (yyexca(i),i= 1, 8) / -1, 1, 0, -1, -2, 0, -1, 5/ data (yyexca(i),i= 9, 16) / 40, 33, -2, 5, -1, 6, 40, 32/ data (yyexca(i),i= 17, 24) / -2, 6, -1, 76, 269, 0, 270, 0/ data (yyexca(i),i= 25, 32) / 271, 0, 283, 0, -2, 22, -1, 77/ data (yyexca(i),i= 33, 40) / 269, 0, 270, 0, 271, 0, 283, 0/ data (yyexca(i),i= 41, 48) / -2, 23, -1, 78, 269, 0, 270, 0/ data (yyexca(i),i= 49, 56) / 271, 0, 283, 0, -2, 24, -1, 79/ data (yyexca(i),i= 57, 64) / 269, 0, 270, 0, 271, 0, 283, 0/ data (yyexca(i),i= 65, 72) / -2, 25, -1, 80, 272, 0, 273, 0/ data (yyexca(i),i= 73, 80) / 274, 0, -2, 26, -1, 81, 272, 0/ data (yyexca(i),i= 81, 88) / 273, 0, 274, 0, -2, 27, -1, 82/ data (yyexca(i),i= 89, 96) / 272, 0, 273, 0, 274, 0, -2, 28/ short yyact[303] data (yyact(i),i= 1, 8) / 15, 16, 17, 18, 19, 20, 33, 86/ data (yyact(i),i= 9, 16) / 26, 27, 28, 30, 32, 31, 21, 22/ data (yyact(i),i= 17, 24) / 62, 23, 24, 25, 19, 34, 29, 15/ data (yyact(i),i= 25, 32) / 16, 17, 18, 19, 20, 33, 38, 26/ data (yyact(i),i= 33, 40) / 27, 28, 30, 32, 31, 21, 22, 60/ data (yyact(i),i= 41, 48) / 23, 24, 25, 12, 11, 29, 15, 16/ data (yyact(i),i= 49, 56) / 17, 18, 19, 20, 12, 2, 26, 27/ data (yyact(i),i= 57, 64) / 28, 30, 32, 31, 12, 1, 0, 23/ data (yyact(i),i= 65, 72) / 24, 25, 0, 14, 29, 15, 16, 17/ data (yyact(i),i= 73, 80) / 18, 19, 20, 0, 0, 26, 27, 28/ data (yyact(i),i= 81, 88) / 30, 32, 31, 0, 15, 16, 17, 18/ data (yyact(i),i= 89, 96) / 19, 20, 0, 29, 26, 27, 28, 15/ data (yyact(i),i= 97,104) / 16, 17, 18, 19, 20, 15, 16, 17/ data (yyact(i),i=105,112) / 18, 19, 29, 17, 18, 19, 4, 0/ data (yyact(i),i=113,120) / 84, 0, 40, 85, 0, 0, 0, 35/ data (yyact(i),i=121,128) / 36, 37, 0, 39, 0, 0, 0, 0/ data (yyact(i),i=129,136) / 0, 0, 41, 42, 43, 44, 45, 46/ data (yyact(i),i=137,144) / 47, 48, 49, 50, 51, 52, 53, 54/ data (yyact(i),i=145,152) / 55, 56, 57, 58, 59, 61, 0, 63/ data (yyact(i),i=153,160) / 65, 66, 67, 68, 69, 70, 71, 72/ data (yyact(i),i=161,168) / 73, 74, 75, 76, 77, 78, 79, 80/ data (yyact(i),i=169,176) / 81, 82, 83, 0, 0, 0, 0, 0/ data (yyact(i),i=177,184) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yyact(i),i=185,192) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yyact(i),i=193,200) / 0, 0, 0, 0, 0, 0, 89, 90/ data (yyact(i),i=201,208) / 87, 88, 0, 0, 0, 0, 0, 0/ data (yyact(i),i=209,216) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yyact(i),i=217,224) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yyact(i),i=225,232) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yyact(i),i=233,240) / 0, 0, 0, 0, 15, 16, 17, 18/ data (yyact(i),i=241,248) / 19, 20, 33, 0, 26, 27, 28, 30/ data (yyact(i),i=249,256) / 32, 31, 21, 22, 0, 23, 24, 25/ data (yyact(i),i=257,264) / 0, 0, 29, 0, 5, 6, 64, 0/ data (yyact(i),i=265,272) / 0, 8, 0, 0, 3, 5, 6, 0/ data (yyact(i),i=273,280) / 0, 0, 8, 0, 0, 5, 6, 0/ data (yyact(i),i=281,288) / 9, 0, 8, 13, 10, 7, 0, 0/ data (yyact(i),i=289,296) / 0, 9, 0, 0, 0, 10, 7, 0/ data (yyact(i),i=297,303) / 0, 9, 0, 0, 0, 10, 7/ short yypact[91] data (yypact(i),i= 1, 8) / 12,-1000, 23,-1000,-238,-1000,-1000,-236/ data (yypact(i),i= 9, 16) / 20, 20, 20, -10, 20,-1000,-1000,-1000/ data (yypact(i),i= 17, 24) /-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ data (yypact(i),i= 25, 32) /-1000,-1000,-1000,-1000,-1000,-1000,-1000,-1000/ data (yypact(i),i= 33, 40) /-1000,-1000,-1000,-245,-245,-245, 20, -25/ data (yypact(i),i= 41, 48) / 3, 3, 3, 3, 3, 3, 3, 3/ data (yypact(i),i= 49, 56) / 3, 3, 3, 3, 3, 3, 3, 3/ data (yypact(i),i= 57, 64) / 3, 3, 3, 3, 71,-238,-1000,-238/ data (yypact(i),i= 65, 72) /-1000,-156,-156,-245,-245,-1000,-160,-215/ data (yypact(i),i= 73, 80) /-215,-192,-192,-192,-166,-166,-166,-166/ data (yypact(i),i= 81, 88) /-177,-177,-177,-261,-1000,-1000,-1000, 3/ data (yypact(i),i= 89, 91) / 3,-238,-238/ short yypgo[7] data (yypgo(i),i= 1, 7) / 0, 61, 53, 110, 114, 44, 39/ short yyr1[39] data (yyr1(i),i= 1, 8) / 0, 1, 1, 2, 2, 3, 3, 3/ data (yyr1(i),i= 9, 16) / 3, 3, 3, 3, 3, 3, 3, 3/ data (yyr1(i),i= 17, 24) / 3, 3, 3, 3, 3, 3, 3, 3/ data (yyr1(i),i= 25, 32) / 3, 3, 3, 3, 3, 3, 3, 3/ data (yyr1(i),i= 33, 39) / 5, 5, 6, 6, 6, 4, 4/ short yyr2[39] data (yyr2(i),i= 1, 8) / 0, 2, 1, 1, 4, 1, 1, 2/ data (yyr2(i),i= 9, 16) / 2, 2, 2, 4, 4, 4, 4, 4/ data (yyr2(i),i= 17, 24) / 4, 4, 4, 4, 4, 4, 4, 4/ data (yyr2(i),i= 25, 32) / 4, 4, 4, 4, 4, 7, 4, 3/ data (yyr2(i),i= 33, 39) / 1, 1, 0, 1, 4, 0, 2/ short yychk[91] data (yychk(i),i= 1, 8) /-1000, -1, -2, 256, -3, 257, 258, 282/ data (yychk(i),i= 9, 16) / 262, 277, 281, -5, 40, 260, 44, 261/ data (yychk(i),i= 17, 24) / 262, 263, 264, 265, 266, 275, 276, 278/ data (yychk(i),i= 25, 32) / 279, 280, 269, 270, 271, 283, 272, 274/ data (yychk(i),i= 33, 40) / 273, 267, 257, -3, -3, -3, 40, -3/ data (yychk(i),i= 41, 48) / -4, -4, -4, -4, -4, -4, -4, -4/ data (yychk(i),i= 49, 56) / -4, -4, -4, -4, -4, -4, -4, -4/ data (yychk(i),i= 57, 64) / -4, -4, -4, -4, -6, -3, 41, -3/ data (yychk(i),i= 65, 72) / 259, -3, -3, -3, -3, -3, -3, -3/ data (yychk(i),i= 73, 80) / -3, -3, -3, -3, -3, -3, -3, -3/ data (yychk(i),i= 81, 88) / -3, -3, -3, -3, 41, 44, 268, -4/ data (yychk(i),i= 89, 91) / -4, -3, -3/ short yydef[91] data (yydef(i),i= 1, 8) / 0, -2, 0, 2, 3, -2, -2, 0/ data (yydef(i),i= 9, 16) / 0, 0, 0, 0, 0, 1, 37, 37/ data (yydef(i),i= 17, 24) / 37, 37, 37, 37, 37, 37, 37, 37/ data (yydef(i),i= 25, 32) / 37, 37, 37, 37, 37, 37, 37, 37/ data (yydef(i),i= 33, 40) / 37, 37, 7, 8, 9, 10, 34, 0/ data (yydef(i),i= 41, 48) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yydef(i),i= 49, 56) / 0, 0, 0, 0, 0, 0, 0, 0/ data (yydef(i),i= 57, 64) / 0, 0, 0, 0, 0, 35, 31, 4/ data (yydef(i),i= 65, 72) / 38, 11, 12, 13, 14, 15, 16, 17/ data (yydef(i),i= 73, 80) / 18, 19, 20, 21, -2, -2, -2, -2/ data (yydef(i),i= 81, 88) / -2, -2, -2, 0, 30, 37, 37, 0/ data (yydef(i),i= 89, 91) / 0, 36, 29/ begin call smark (yysp) call salloc (yyv, (YYMAXDEPTH+2) * YYOPLEN, TY_STRUCT) # Initialization. The first element of the dynamically allocated # token value stack (yyv) is used for yyval, the second for yylval, # and the actual stack starts with the third element. yystate = 0 yychar = -1 yynerrs = 0 yyerrflag = 0 yyps = 0 yyval = yyv yylval = yyv + YYOPLEN yypv = yylval yystack_ # SHIFT -- Put a state and value onto the stack. The token and # value stacks are logically the same stack, implemented as two # separate arrays. if (yydebug) { call printf ("state %d, char 0%o\n") call pargs (yystate) call pargi (yychar) } yyps = yyps + 1 yypv = yypv + YYOPLEN if (yyps > YYMAXDEPTH) { call sfree (yysp) call eprintf ("yacc stack overflow\n") return (ERR) } yys[yyps] = yystate YYMOVE (yyval, yypv) yynewstate_ # Process the new state. yyn = yypact[yystate+1] if (yyn <= YYFLAG) goto yydefault_ # simple state # The variable "yychar" is the lookahead token. if (yychar < 0) { yychar = yylex (fd, yylval) if (yychar < 0) yychar = 0 } yyn = yyn + yychar if (yyn < 0 || yyn >= YYLAST) goto yydefault_ yyn = yyact[yyn+1] if (yychk[yyn+1] == yychar) { # valid shift yychar = -1 YYMOVE (yylval, yyval) yystate = yyn if (yyerrflag > 0) yyerrflag = yyerrflag - 1 goto yystack_ } yydefault_ # Default state action. yyn = yydef[yystate+1] if (yyn == -2) { if (yychar < 0) { yychar = yylex (fd, yylval) if (yychar < 0) yychar = 0 } # Look through exception table. yyxi = 1 while ((yyexca[yyxi] != (-1)) || (yyexca[yyxi+1] != yystate)) yyxi = yyxi + 2 for (yyxi=yyxi+2; yyexca[yyxi] >= 0; yyxi=yyxi+2) { if (yyexca[yyxi] == yychar) break } yyn = yyexca[yyxi+1] if (yyn < 0) { call sfree (yysp) return (OK) # ACCEPT -- all done } } # SYNTAX ERROR -- resume parsing if possible. if (yyn == 0) { switch (yyerrflag) { case 0, 1, 2: if (yyerrflag == 0) { # brand new error call eprintf ("syntax error\n") yyerrlab_ yynerrs = yynerrs + 1 # fall through... } # case 1: # case 2: incompletely recovered error ... try again yyerrflag = 3 # Find a state where "error" is a legal shift action. while (yyps >= 1) { yyn = yypact[yys[yyps]+1] + YYERRCODE if ((yyn >= 0) && (yyn < YYLAST) && (yychk[yyact[yyn+1]+1] == YYERRCODE)) { # Simulate a shift of "error". yystate = yyact[yyn+1] goto yystack_ } yyn = yypact[yys[yyps]+1] # The current yyps has no shift on "error", pop stack. if (yydebug) { call printf ("error recovery pops state %d, ") call pargs (yys[yyps]) call printf ("uncovers %d\n") call pargs (yys[yyps-1]) } yyps = yyps - 1 yypv = yypv - YYOPLEN } # ABORT -- There is no state on the stack with an error shift. yyabort_ call sfree (yysp) return (ERR) case 3: # No shift yet; clobber input char. if (yydebug) { call printf ("error recovery discards char %d\n") call pargi (yychar) } if (yychar == 0) goto yyabort_ # don't discard EOF, quit yychar = -1 goto yynewstate_ # try again in the same state } } # REDUCE -- Reduction by production yyn. if (yydebug) { call printf ("reduce %d\n") call pargs (yyn) } yyps = yyps - yyr2[yyn+1] yypvt = yypv yypv = yypv - yyr2[yyn+1] * YYOPLEN YYMOVE (yypv + YYOPLEN, yyval) yym = yyn # Consult goto table to find next state. yyn = yyr1[yyn+1] yyj = yypgo[yyn+1] + yys[yyps] + 1 if (yyj >= YYLAST) yystate = yyact[yypgo[yyn+1]+1] else { yystate = yyact[yyj+1] if (yychk[yystate+1] != -yyn) yystate = yyact[yypgo[yyn+1]+1] } # Perform action associated with the grammar rule, if any. switch (yym) { case 1: # line 266 "evvexpr.y" { # Normal exit. Move the final expression value operand # into the operand structure pointed to by the global # variable ev_oval. YYMOVE (yypvt-YYOPLEN, ev_oval) call sfree (yysp) return (OK) } case 2: # line 275 "evvexpr.y" { call error (1, "syntax error") } case 3: # line 280 "evvexpr.y" { YYMOVE (yypvt, yyval) } case 4: # line 283 "evvexpr.y" { YYMOVE (yypvt, yyval) call xvv_freeop (yypvt-3*YYOPLEN) } case 5: # line 289 "evvexpr.y" { # Numeric constant. YYMOVE (yypvt, yyval) } case 6: # line 293 "evvexpr.y" { # The boolean constants "yes" and "no" are implemented # as reserved operands. call xvv_initop (yyval, 0, TY_BOOL) if (streq (O_VALC(yypvt), "yes")) { O_VALI(yyval) = YES } else if (streq (O_VALC(yypvt), "no")) { O_VALI(yyval) = NO } else if (ev_getop != NULL) { call zcall3 (ev_getop,ev_getop_data, O_VALC(yypvt), yyval) call eprintf ("parse: %s %d\n") call pargstr (O_VALC(yypvt)) call pargi (O_TYPE(yyval)) if (O_TYPE(yyval) <= 0) call xvv_error1 ("unknown operand `%s'", O_VALC(yypvt)) } else call xvv_error1 ("illegal operand `%s'", O_VALC(yypvt)) call xvv_freeop (yypvt) } case 7: # line 311 "evvexpr.y" { # e.g., @"param" if (ev_getop != NULL) { call zcall3 (ev_getop,ev_getop_data, O_VALC(yypvt), yyval) if (O_TYPE(yyval) <= 0) call xvv_error1 ("unknown operand `%s'", O_VALC(yypvt-YYOPLEN)) } else call xvv_error1 ("illegal operand `%s'", O_VALC(yypvt)) call xvv_freeop (yypvt) } case 8: # line 322 "evvexpr.y" { # Unary arithmetic minus. call xvv_unop (MINUS, yypvt, yyval) } case 9: # line 326 "evvexpr.y" { # Logical not. call xvv_unop (LNOT, yypvt, yyval) } case 10: # line 330 "evvexpr.y" { # Boolean not. call xvv_unop (BNOT, yypvt, yyval) } case 11: # line 334 "evvexpr.y" { # Addition. call xvv_binop (PLUS, yypvt-3*YYOPLEN, yypvt, yyval) } case 12: # line 338 "evvexpr.y" { # Subtraction. call xvv_binop (MINUS, yypvt-3*YYOPLEN, yypvt, yyval) } case 13: # line 342 "evvexpr.y" { # Multiplication. call xvv_binop (STAR, yypvt-3*YYOPLEN, yypvt, yyval) } case 14: # line 346 "evvexpr.y" { # Division. call xvv_binop (SLASH, yypvt-3*YYOPLEN, yypvt, yyval) } case 15: # line 350 "evvexpr.y" { # Exponentiation. call xvv_binop (EXPON, yypvt-3*YYOPLEN, yypvt, yyval) } case 16: # line 354 "evvexpr.y" { # Concatenate two operands. call xvv_binop (CONCAT, yypvt-3*YYOPLEN, yypvt, yyval) } case 17: # line 358 "evvexpr.y" { # Logical and. call xvv_boolop (LAND, yypvt-3*YYOPLEN, yypvt, yyval) } case 18: # line 362 "evvexpr.y" { # Logical or. call xvv_boolop (LOR, yypvt-3*YYOPLEN, yypvt, yyval) } case 19: # line 366 "evvexpr.y" { # Boolean and. call xvv_binop (BAND, yypvt-3*YYOPLEN, yypvt, yyval) } case 20: # line 370 "evvexpr.y" { # Boolean or. call xvv_binop (BOR, yypvt-3*YYOPLEN, yypvt, yyval) } case 21: # line 374 "evvexpr.y" { # Boolean xor. call xvv_binop (BXOR, yypvt-3*YYOPLEN, yypvt, yyval) } case 22: # line 378 "evvexpr.y" { # Boolean less than. call xvv_boolop (LT, yypvt-3*YYOPLEN, yypvt, yyval) } case 23: # line 382 "evvexpr.y" { # Boolean greater than. call xvv_boolop (GT, yypvt-3*YYOPLEN, yypvt, yyval) } case 24: # line 386 "evvexpr.y" { # Boolean less than or equal. call xvv_boolop (LE, yypvt-3*YYOPLEN, yypvt, yyval) } case 25: # line 390 "evvexpr.y" { # Boolean greater than or equal. call xvv_boolop (GE, yypvt-3*YYOPLEN, yypvt, yyval) } case 26: # line 394 "evvexpr.y" { # Boolean equal. call xvv_boolop (EQ, yypvt-3*YYOPLEN, yypvt, yyval) } case 27: # line 398 "evvexpr.y" { # String pattern-equal. call xvv_boolop (SE, yypvt-3*YYOPLEN, yypvt, yyval) } case 28: # line 402 "evvexpr.y" { # Boolean not equal. call xvv_boolop (NE, yypvt-3*YYOPLEN, yypvt, yyval) } case 29: # line 406 "evvexpr.y" { # Conditional expression. call xvv_quest (yypvt-6*YYOPLEN, yypvt-3*YYOPLEN, yypvt, yyval) } case 30: # line 410 "evvexpr.y" { # Call an intrinsic or external function. ap = O_VALP(yypvt-YYOPLEN) call eprintf ("%s: %d %d\n") call pargstr (O_VALC(yypvt-3*YYOPLEN)) call pargi (O_TYPE(A_ARGP(ap,1))) call pargi (O_TYPE(A_ARGP(ap,2))) call xvv_callfcn (O_VALC(yypvt-3*YYOPLEN), A_ARGP(ap,1), A_NARGS(ap), yyval) call xvv_freeop (yypvt-3*YYOPLEN) call xvv_freeop (yypvt-YYOPLEN) } case 31: # line 418 "evvexpr.y" { YYMOVE (yypvt-YYOPLEN, yyval) } case 32: # line 424 "evvexpr.y" { YYMOVE (yypvt, yyval) } case 33: # line 427 "evvexpr.y" { if (O_TYPE(yypvt) != TY_CHAR) call error (1, "illegal function name") YYMOVE (yypvt, yyval) } case 34: # line 435 "evvexpr.y" { # Empty. call xvv_startarglist (NULL, yyval) } case 35: # line 439 "evvexpr.y" { # First arg; start a nonnull list. call xvv_startarglist (yypvt, yyval) } case 36: # line 443 "evvexpr.y" { # Add an argument to an existing list. call xvv_addarg (yypvt, yypvt-3*YYOPLEN, yyval) } } goto yystack_ # stack new state and value end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/mfree.x�������������������������������������������������������0000664�0000000�0000000�00000001171�13321663143�0020214�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include # MFREE -- Free a previously allocated buffer. If the buffer has already been # returned (NULL pointer), ignore the request. Once the buffer has been # returned, the old pointer value is of not useful (and invalid), so set it # to NULL. procedure mfree (ptr, dtype) pointer ptr int fwa, dtype, status int mgtfwa() errchk mgtfwa begin if (ptr != NULL) { fwa = mgtfwa (ptr, dtype) call zmfree (fwa, status) if (status == ERR) call sys_panic (SYS_MCORRUPTED, "Memory has been corrupted") ptr = NULL } end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/mimpars.par���������������������������������������������������0000664�0000000�0000000�00000000753�13321663143�0021106�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Mosaic image parameters extname,s,h,"",,,"extension name pattern" exttmplt,s,h,"_![1-9]*.*",,,"extension template for separate images " xgap,i,h,72,0,,"minimum X gap between images" ygap,i,h,36,0,,"minimum Y gap between images " process,b,h,no,,,"do calibration processing?" overscan,b,h,yes,,,"do line-by-line overscan subtraction?" zerosub,b,h,yes,,,"do zero subtraction?" flatfield,b,h,yes,,,"do flat field correction?" caldir,s,h,"",,,"calibration directory" filter,s,h,"",,,"filter" ���������������������mscred-5.05-2018.07.09/src/mscdisplay/mkpkg���������������������������������������������������������0000664�0000000�0000000�00000002416�13321663143�0017764�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCDISPLAY $call lmscdisp $call relink $exit update: $call relink $call mscexam $call install ; relink: $call mscdisplay ; mscdisplay: $set LIBS1 = "-lccdred -lmscred -lds -lxtools -lcurfit -lgsurfit" $set LIBS2 = "-lnlfit -liminterp -lncar -lgks -lllsq" $checkout x_mscdisplay.o mscbin$ $omake x_mscdisplay.x $iffile (pkg$images/tv/display/imdwcsver.x) $link x_mscdisplay.o -lsf -lmscdisp\ $(LIBS1) $(LIBS2) -o xx_mscdisplay.e $else $omake imdwcsver.x $link x_mscdisplay.o imdwcsver.o -lsf -lmscdisp\ $(LIBS1) $(LIBS2) -o xx_mscdisplay.e $endif $checkin x_mscdisplay.o mscbin$ ; mscexam: $set LIBS1 = "-lccdred -lmscred -lslalib -lds -lxtools -lcurfit" $set LIBS2 = "-lgsurfit -lnlfit -liminterp -lncar -lgks -lllsq" $checkout x_mscexam.o mscbin$ $omake x_mscexam.x $iffile (pkg$images/tv/display/imdwcsver.x) $link x_mscexam.o -limexam -lmscdisp\ $(LIBS1) $(LIBS2) -o xx_mscexam.e $else $omake imdwcsver.x $link x_mscexam.o imdwcsver.o -limexam -lmscdisp\ $(LIBS1) $(LIBS2) -o xx_mscexam.e $endif $checkin x_mscexam.o mscbin$ ; install: $move xx_mscdisplay.e mscbin$x_mscdisplay.e $move xx_mscexam.e mscbin$x_mscexam.e ; lmscdisp: $call lmscdisp@src ; limexam: $call limexam@src ; lsf: $call lsf@src ; ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/mosdisp.par���������������������������������������������������0000664�0000000�0000000�00000001705�13321663143�0021112�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������image,s,a,"",,,Root name for input images frame,i,a,1,1,4,"display frame to be written into" # Display parameters" erase,b,h,yes,,,erase frame select_frame,b,h,yes,,,display frame being loaded zscale,b,h,yes,,,display range of greylevels near median zrange,b,h,yes,,,display full image intensity range zcombine,s,h,"none","|none|minmax|average|median|",,Algorithm for combining z1 and z2 values for each image z1,r,h,,,,minimum greylevel to be displayed z2,r,h,,,,maximum greylevel to be displayed ztrans,s,h,linear,,,greylevel transformation (linear|log|none|user) contrast,r,h,0.25,,,contrast adjustment for zscale algorithm nsample_lines,i,h,5,,,number of sample lines order,i,h,0,0,1,"spatial interpolator order (0=replicate, 1=linear)" lutfile,f,h,"",,,"file containing user defined look up table # PROCESSING PARAMETERS" procpars,pset,h,"",,,"Processing parameters # AMPLIFIER INFORMATION" ampinfo,pset,h,"",,,"Amplifier Information pset " mode,s,h,"a",,, �����������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/mscdisplay.par������������������������������������������������0000664�0000000�0000000�00000002604�13321663143�0021603�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parameter file for MSCDISPLAY image,f,a,,,,root name for image to be displayed zero,f,h,"",,,root name for zero subtraction frame,i,a,1,1,16,frame to be written into mimpars,pset,h,"",,,"mosaic image parameters (extensions, gaps, processing)" check,b,h,no,,,check if image is loaded onepass,b,h,no,,,load all extensions in one pass? bpmask,f,h,"BPM",,,bad pixel mask bpdisplay,s,h,"none","none|overlay|interpolate",,bad pixel display (none|overlay|interpolate) bpcolors,s,h,"red",,,bad pixel colors overlay,f,h,"",,,overlay mask ocolors,s,h,"green",,,overlay colors erase,b,h,yes,,,erase frame border_erase,b,h,no,,,erase unfilled area of window select_frame,b,h,yes,,,display frame being loaded fill,b,h,no,,,scale image to fit display window zscale,b,h,yes,,,display range of greylevels near median contrast,r,h,0.25,,,contrast adjustment for zscale algorithm zrange,b,h,yes,,,display full image intensity range zmask,f,h,"",,,sample mask zcombine,s,h,"auto","|none|auto|minmax|average|median|",,Algorithm for combining z1 and z2 values for each image nsample,i,h,1000,100,,maximum number of sample pixels to use order,i,h,0,0,1,"spatial interpolator order (0=replicate, 1=linear)" z1,r,h,0.,,,minimum greylevel to be displayed z2,r,h,1000.,,,maximum greylevel to be displayed ztrans,s,h,linear,,,greylevel transformation (linear|log|none|user) lutfile,f,h,"",,,"file containing user defined look up table" ����������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/mscexamine.par������������������������������������������������0000777�0000000�0000000�00000000000�13321663143�0026461�2src/imexam/mscexamine.par���������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/mscrtdisplay.par����������������������������������������������0000664�0000000�0000000�00000003054�13321663143�0022151�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parameter file for MSCRTDISPLAY image,f,a,,,,root name for image to be displayed zero,f,h,"",,,root name for zero subtraction frame,i,a,1,1,16,frame to be written into check,b,h,no,,,check if image is loaded mimpars,pset,h,"",,,"mosaic image parameters (extensions, gaps, processing)" bpmask,f,h,"BPM",,,bad pixel mask bpdisplay,s,h,"none","none|overlay|interpolate",,bad pixel display (none|overlay|interpolate) bpcolors,s,h,"red",,,bad pixel colors overlay,f,h,"",,,overlay mask ocolors,s,h,"green",,,overlay colors erase,b,h,yes,,,erase frame border_erase,b,h,no,,,erase unfilled area of window select_frame,b,h,yes,,,display frame being loaded repeat,b,h,no,,,repeat previous display parameters fill,b,h,no,,,scale image to fit display window zscale,b,h,yes,,,display range of greylevels near median contrast,r,h,0.25,,,contrast adjustment for zscale algorithm zrange,b,h,yes,,,display full image intensity range zmask,f,h,"",,,sample mask zcombine,s,h,"auto","|none|auto|minmax|average|median|",,Algorithm for combining z1 and z2 values for each image nsample,i,h,1000,100,,maximum number of sample pixels to use order,i,h,0,0,1,"spatial interpolator order (0=replicate, 1=linear)" z1,r,h,0.,,,minimum greylevel to be displayed z2,r,h,1000.,,,maximum greylevel to be displayed ztrans,s,h,linear,,,greylevel transformation (linear|log|none|user) lutfile,f,h,"",,,"file containing user defined look up table # DCA DISPLAY PARAMETERS" wait,i,h,0,0,,Initial wait before executing sleep,i,h,5,0,,Sleep between incremental displays niterate,i,h,5,1,,Iterations between scaling ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/procpars.par��������������������������������������������������0000664�0000000�0000000�00000000421�13321663143�0021257�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# PROCESSING FLAGS trim,b,h,no,,,include only trim sections in tiled image overscan,s,h,"none","|none|constant|average|",,Overscan subtraction method gain,b,h,no,,,Normalise gains dark,b,h,no,,,Subtract dark current blank,r,h,0.0,,,Fill value for empty portions of mosaic �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/qproc.par�����������������������������������������������������0000664�0000000�0000000�00000001640�13321663143�0020556�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,"",,,List of input image root names output,s,h,"",,,"List of output images # PROCESSING FLAGS" trim,b,h,no,,,include only trim sections in tiled image overscan,s,h,"none","|none|constant|average|line|fit|",,Overscan subtraction method gain,b,h,no,,,Normalise gains dark,b,h,no,,,Subtract dark current blank,r,h,0.0,,,"Fill value for empty portions of mosaic # PARAMETERS OF OVERSCAN FIT" interactive,b,h,no,,,Fit overscan interactively? function,s,h,"legendre",,,Fitting function order,i,h,1,1,,Number of polynomial terms or spline pieces sample,s,h,"*",,,Sample points to fit naverage,i,h,1,,,Number of sample points to combine niterate,i,h,1,0,,Number of rejection iterations low_reject,r,h,3.,0.,,Low sigma rejection factor high_reject,r,h,3.,0.,,High sigma rejection factor grow,r,h,0.,0.,,"Rejection growing radius # AMPLIFIER INFORMATION" ampinfo, pset, h, "",,,"Amplifier Information pset " mode,s,h,"a",,, ������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/sigm2.x�������������������������������������������������������0000664�0000000�0000000�00000102525�13321663143�0020144�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include .help sigm2, sigm2_setup .nf ___________________________________________________________________________ SIGM2 -- Get a line from a spatially scaled 2-dimensional image. This procedure works like the regular IMIO get line procedure, but rescales the input 2-dimensional image in either or both axes upon input. If the magnification ratio required is greater than 0 and less than 2 then linear interpolation is used to resample the image. If the magnification ratio is greater than or equal to 2 then the image is block averaged by the smallest factor which reduces the magnification to the range 0-2 and then interpolated back up to the desired size. In some cases this will smooth the data slightly, but the operation is efficient and avoids aliasing effects. si = sigm2_setup (im,pm, x1,x2,nx,xblk, y1,y2,ny,yblk, order) sigm2_free (si) ptr = sigm2[sr] (si, linenumber) SIGM2_SETUP must be called to set up the transformations after mapping the image and before performing any scaled i/o to the image. SIGM2_FREE must be called when finished to return buffer space. The SIGM routines are like SIGL routines except for the addition of interpolation over bad pixels and order=-1 takes the maximum rather than the average when doing block averaging or interpolation. .endhelp ______________________________________________________________________ # Scaled image descriptor for 2-dim images define SI_LEN 19 define SI_MAXDIM 2 # images of 2 dimensions supported define SI_NBUFS 3 # nbuffers used by SIGL2 define SI_IM Memi[$1] # pointer to input image header define SI_FP Memi[$1+1] # pointer to fixpix structure define SI_GRID Memi[$1+2+$2-1] # pointer to array of X coords define SI_NPIX Memi[$1+4+$2-1] # number of X coords define SI_BAVG Memi[$1+6+$2-1] # X block averaging factor define SI_INTERP Memi[$1+8+$2-1] # interpolate X axis define SI_BUF Memi[$1+10+$2-1]# line buffers define SI_BUFY Memi[$1+13+$2-1]# Y values of buffers define SI_ORDER Memi[$1+15] # interpolator order define SI_TYBUF Memi[$1+16] # buffer type define SI_XOFF Memi[$1+17] # offset in input image to first X define SI_INIT Memi[$1+18] # YES until first i/o is done define OUTBUF SI_BUF($1,3) define SI_TOL (1E-5) # close to a pixel define INTVAL (abs ($1 - nint($1)) < SI_TOL) define SWAPI {tempi=$2;$2=$1;$1=tempi} define SWAPP {tempp=$2;$2=$1;$1=tempp} define NOTSET (-9999) # SIGM2_SETUP -- Set up the spatial transformation for SIGL2[SR]. Compute # the block averaging factors (1 if no block averaging is required) and # the sampling grid points, i.e., pixel coordinates of the output pixels in # the input image. pointer procedure sigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) pointer im # the input image pointer pm # pixel mask real px1, px2 # range in X to be sampled on an even grid int nx # number of output pixels in X int xblk # blocking factor in x real py1, py2 # range in Y to be sampled on an even grid int ny # number of output pixels in Y int yblk # blocking factor in y int order # interpolator order (0=replicate, 1=linear) int npix, noldpix, nbavpix, i, j int npts[SI_MAXDIM] # number of output points for axis int blksize[SI_MAXDIM] # block averaging factor (npix per block) real tau[SI_MAXDIM] # tau = p(i+1) - p(i) in fractional pixels real p1[SI_MAXDIM] # starting pixel coords in each axis real p2[SI_MAXDIM] # ending pixel coords in each axis real scalar, start pointer si, gp, xt_fpinit() begin iferr (call calloc (si, SI_LEN, TY_STRUCT)) call erract (EA_FATAL) SI_IM(si) = im SI_FP(si) = xt_fpinit (pm, 1, INDEFI) SI_NPIX(si,1) = nx SI_NPIX(si,2) = ny SI_ORDER(si) = order SI_INIT(si) = YES p1[1] = px1 # X = index 1 p2[1] = px2 npts[1] = nx blksize[1] = xblk p1[2] = py1 # Y = index 2 p2[2] = py2 npts[2] = ny blksize[2] = yblk # Compute block averaging factors if not defined. # If there is only one pixel then the block average is the average # between the first and last point. do i = 1, SI_MAXDIM { if ((blksize[i] >= 1) && !IS_INDEFI (blksize[i])) { if (npts[i] == 1) tau[i] = 0. else tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) } else { if (npts[i] == 1) { tau[i] = 0. blksize[i] = int (p2[i] - p1[i] + 1 + SI_TOL) } else { tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) if (tau[i] >= 2.0) { # If nx or ny is not an integral multiple of the block # averaging factor, noldpix is the next larger number # which is an integral multiple. When the image is # block averaged pixels will be replicated as necessary # to fill the last block out to this size. blksize[i] = int (tau[i] + SI_TOL) npix = p2[i] - p1[i] + 1 noldpix = (npix+blksize[i]-1) / blksize[i] * blksize[i] nbavpix = noldpix / blksize[i] scalar = real (nbavpix - 1) / real (noldpix - 1) p1[i] = (p1[i] - 1.0) * scalar + 1.0 p2[i] = (p2[i] - 1.0) * scalar + 1.0 tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) } else blksize[i] = 1 } } } SI_BAVG(si,1) = blksize[1] SI_BAVG(si,2) = blksize[2] # if (IS_INDEFI (xblk)) # xblk = blksize[1] # if (IS_INDEFI (yblk)) # yblk = blksize[2] # Allocate and initialize the grid arrays, specifying the X and Y # coordinates of each pixel in the output image, in units of pixels # in the input (possibly block averaged) image. do i = 1, SI_MAXDIM { # The X coordinate is special. We do not want to read entire # input image lines if only a range of input X values are needed. # Since the X grid vector passed to ALUI (the interpolator) must # contain explicit offsets into the vector being interpolated, # we must generate interpolator grid points starting near 1.0. # The X origin, used to read the block averaged input line, is # given by XOFF. if (i == 1) { SI_XOFF(si) = int (p1[i] + SI_TOL) start = p1[1] - int (p1[i] + SI_TOL) + 1.0 } else start = p1[i] # Do the axes need to be interpolated? if (INTVAL(start) && INTVAL(tau[i])) SI_INTERP(si,i) = NO else SI_INTERP(si,i) = YES # Allocate grid buffer and set the grid points. iferr (call malloc (gp, npts[i], TY_REAL)) call erract (EA_FATAL) SI_GRID(si,i) = gp if (SI_ORDER(si) <= 0) { do j = 0, npts[i]-1 Memr[gp+j] = int (start + (j * tau[i]) + 0.5 + SI_TOL) } else { do j = 0, npts[i]-1 Memr[gp+j] = start + (j * tau[i]) } } return (si) end # SIGM2_FREE -- Free storage associated with an image opened for scaled # input. This does not close and unmap the image. procedure sigm2_free (si) pointer si int i begin # Free fixpix structure. call xt_fpfree (SI_FP(si)) # Free SIGM2 buffers. do i = 1, SI_NBUFS if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) # Free GRID buffers. do i = 1, SI_MAXDIM if (SI_GRID(si,i) != NULL) call mfree (SI_GRID(si,i), TY_REAL) call mfree (si, TY_STRUCT) end # SIGM2S -- Get a line of type short from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure sigm2s (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer si_blmavgs() errchk si_blmavgs begin nraw = IM_LEN(SI_IM(si),1) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_SHORT) SI_TYBUF(si) = TY_SHORT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_SHORT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call si_samples (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call si_maxs (Mems[rawline], nraw, Memr[SI_GRID(si,1)], Mems[SI_BUF(si,i)], npix) } else { call aluis (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxs (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVGS -- Get a line from a block averaged image of type short. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure si_blmavgs (im, fp, x1, x2, y, xbavg, ybavg, order) pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum short blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer xt_fps() errchk xt_fps begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "si_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "si_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (xt_fps (fp, im, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "si_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = xt_fps (fp, im, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Mems[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Mems[k]) Mems[a+j-1] = blkmax blk1 = blk2 } } else call abavs (Mems[a], Mems[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Mems[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Mems[k]) Mems[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Mems[a+j-1] count = count + 1 } Mems[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Mems[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Mems[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Mems[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Mems[a+i] = Meml[b+i] / real(nlines_in_sum) } } call sfree (sp) return (a) end # SI_MAXS -- Resample a line via maximum value. procedure si_maxs (a, na, x, b, nb) short a[na] # input array int na # input size real x[nb] # sample grid short b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end # SIGM2I -- Get a line of type short from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure sigm2i (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer si_blmavgi() errchk si_blmavgi begin nraw = IM_LEN(SI_IM(si),1) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (si_blmavgi (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_INT) SI_TYBUF(si) = TY_INT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_INT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = si_blmavgi (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovi (Memi[rawline], Memi[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call si_samplei (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call si_maxi (Memi[rawline], nraw, Memr[SI_GRID(si,1)], Memi[SI_BUF(si,i)], npix) } else { call aluii (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxi (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsui (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVGI -- Get a line from a block averaged image of type integer. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure si_blmavgi (im, fp, x1, x2, y, xbavg, ybavg, order) pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum int blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer xt_fpi() errchk xt_fpi begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "si_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "si_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (xt_fpi (fp, im, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "si_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = xt_fpi (fp, im, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Memi[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax blk1 = blk2 } } else call abavi (Memi[a], Memi[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Memi[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Memi[a+j-1] count = count + 1 } Memi[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Memi[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Memi[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] / real(nlines_in_sum) } } call sfree (sp) return (a) end # SI_MAXI -- Resample a line via maximum value. procedure si_maxi (a, na, x, b, nb) int a[na] # input array int na # input size real x[nb] # sample grid int b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end # SIGM2R -- Get a line of type real from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure sigm2r (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer si_blmavgr() errchk si_blmavgr begin nraw = IM_LEN(SI_IM(si)) npix = SI_NPIX(si,1) # Deterine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (si_blmavgr (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_REAL) SI_TYBUF(si) = TY_REAL SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_REAL) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = si_blmavgr (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovr (Memr[rawline], Memr[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call si_sampler (Memr[rawline], Memr[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call si_maxr (Memr[rawline], nraw, Memr[SI_GRID(si,1)], Memr[SI_BUF(si,i)], npix) } else { call aluir (Memr[rawline], Memr[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxr (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], Memr[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsur (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], Memr[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVGR -- Get a line from a block averaged image of type short. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure si_blmavgr (im, fp, x1, x2, y, xbavg, ybavg, order) pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count real sum, blkmax pointer sp, a, b pointer xt_fpr() errchk xt_fpr begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "si_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "si_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (xt_fpr (fp, im, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "si_blmavg: block number out of range") call salloc (b, nblks_x, TY_REAL) if (ybavg > 1) { call aclrr (Memr[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = xt_fpr (fp, im, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Memr[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Memr[k]) Memr[a+j-1] = blkmax blk1 = blk2 } } else call abavr (Memr[a], Memr[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Memr[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Memr[k]) Memr[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Memr[a+j-1] count = count + 1 } Memr[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) call amaxr (Memr[a], Memr[b], Memr[b], nblks_x) else { call aaddr (Memr[a], Memr[b], Memr[b], nblks_x) nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) call amovr (Memr[b], Memr[a], nblks_x) else call adivkr (Memr[b], real(nlines_in_sum), Memr[a], nblks_x) } call sfree (sp) return (a) end # SI_MAXR -- Resample a line via maximum value. procedure si_maxr (a, na, x, b, nb) real a[na] # input array int na # input size real x[nb] # sample grid real b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/����������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0017514�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/ace.h�����������������������������������������������������0000664�0000000�0000000�00000002466�13321663143�0020425�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������define NUMSTART 11 # First object number # Mask Flags. define MASK_NUM 000777777B # Mask number define MASK_GRW 001000000B # Grow pixel define MASK_SPLIT 002000000B # Split flag define MASK_BNDRY 004000000B # Boundary flag define MASK_BP 010000000B # Bad pixel define MASK_BPFLAG 020000000B # Bad pixel flag define MASK_DARK 040000000B # Dark flag define MSETFLAG ori($1,$2) define MUNSETFLAG andi($1,noti($2)) define MNUM (andi($1,MASK_NUM)) define MNOTGRW (andi($1,MASK_GRW)==0) define MGRW (andi($1,MASK_GRW)!=0) define MNOTBP (andi($1,MASK_BP)==0) define MBP (andi($1,MASK_BP)!=0) define MNOTBPFLAG (andi($1,MASK_BPFLAG)==0) define MBPFLAG (andi($1,MASK_BPFLAG)!=0) define MNOTBNDRY (andi($1,MASK_BNDRY)==0) define MBNDRY (andi($1,MASK_BNDRY)!=0) define MNOTSPLIT (andi($1,MASK_SPLIT)==0) define MSPLIT (andi($1,MASK_SPLIT)!=0) define MNOTDARK (andi($1,MASK_DARK)==0) define MDARK (andi($1,MASK_DARK)!=0) # Output object masks types. define OM_TYPES "|boolean|numbers|colors|all|\ |bboolean|bnumbers|bcolors|" define OM_BOOL 1 # Boolean (0=sky, 1=object+bad+grow) define OM_ONUM 2 # Object number only define OM_COLORS 3 # Bad=1, Objects=2-9 define OM_ALL 4 # All values define OM_BBOOL 6 # Boolean (0=sky, 1=object+bad+grow) define OM_BONUM 7 # Object number only define OM_BCOLORS 8 # Bad=1, Objects=2-9 ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/akavg.gx��������������������������������������������������0000664�0000000�0000000�00000004563�13321663143�0021155�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # AKAVG -- Compute the mean and standard deviation of a sample array by # iteratively rejecting points further than KSIG from the mean. # The k-clipped sigma is corrected to match the classical sigma for a # normal distribution. The number of pixels remaining in the sample upon # termination is returned as the function value. $for (silrd) int procedure akavg$t (a, npix, mean, sigma, kclip, itmax) PIXEL a[ARB] # input data array $if (datatype == dl) double mean, sigma, kclip $else real mean, sigma, kclip $endif int npix, itmax, ngpix int akavr$t() double corr, signorm() begin # Compute ratio of k-clipped sigma to classical sigma for a normal # distribution $if (datatype == dl) corr = signorm (kclip) $else corr = signorm (double(kclip)) $endif $if (datatype == dl) ngpix = akavr$t (a, npix, mean, sigma, kclip, corr, itmax) $else ngpix = akavr$t (a, npix, mean, sigma, kclip, real(corr), itmax) $endif return (ngpix) end # AKAVRx -- As AKAVGx except that the sigma normalisation is supplied by # the caller. int procedure akavr$t (a, npix, mean, sigma, kclip, signorm, itmax) PIXEL a[ARB] # input data array $if (datatype == dl) double mean, sigma, kclip, signorm, deviation, lcut, hcut $else real mean, sigma, kclip, signorm, deviation, lcut, hcut $endif int itmax, npix, ngpix, old_ngpix, iter, awvg$t() begin lcut = -MAX_REAL # no rejection to start hcut = MAX_REAL ngpix = MAX_INT # Iteratively compute mean and sigma and reject outliers. # We exit when no more pixels are rejected, when there are # no more pixels, or when we have completed itmax iterations. do iter = 1, itmax { old_ngpix = ngpix ngpix = awvg$t (a, npix, mean, sigma, lcut, hcut) # call eprintf ("iter=%d nrej=%d mean=%f sigma=%f") # call pargi (iter) # call pargi (npix - ngpix) # call parg$t (mean) # call parg$t (sigma) # Correct for clipping if (iter > 1 && signorm > EPSILOND) sigma = sigma / signorm # call eprintf (" sigma_corr=%f\n") # call parg$t (sigma) $if (datatype == dl) if (ngpix <= 1 || sigma <= EPSILOND) $else if (ngpix <= 1 || sigma <= EPSILONR) $endif break if (ngpix >= old_ngpix) break deviation = sigma * kclip lcut = mean - deviation # compute window hcut = mean + deviation } return (ngpix) end $endfor ���������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/akavg.x���������������������������������������������������0000664�0000000�0000000�00000020214�13321663143�0020775�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # AKAVG -- Compute the mean and standard deviation of a sample array by # iteratively rejecting points further than KSIG from the mean. # The k-clipped sigma is corrected to match the classical sigma for a # normal distribution. The number of pixels remaining in the sample upon # termination is returned as the function value. int procedure akavgs (a, npix, mean, sigma, kclip, itmax) short a[ARB] # input data array real mean, sigma, kclip int npix, itmax, ngpix int akavrs() double corr, signorm() begin # Compute ratio of k-clipped sigma to classical sigma for a normal # distribution corr = signorm (double(kclip)) ngpix = akavrs (a, npix, mean, sigma, kclip, real(corr), itmax) return (ngpix) end # AKAVRx -- As AKAVGx except that the sigma normalisation is supplied by # the caller. int procedure akavrs (a, npix, mean, sigma, kclip, signorm, itmax) short a[ARB] # input data array real mean, sigma, kclip, signorm, deviation, lcut, hcut int itmax, npix, ngpix, old_ngpix, iter, awvgs() begin lcut = -MAX_REAL # no rejection to start hcut = MAX_REAL ngpix = MAX_INT # Iteratively compute mean and sigma and reject outliers. # We exit when no more pixels are rejected, when there are # no more pixels, or when we have completed itmax iterations. do iter = 1, itmax { old_ngpix = ngpix ngpix = awvgs (a, npix, mean, sigma, lcut, hcut) # call eprintf ("iter=%d nrej=%d mean=%f sigma=%f") # call pargi (iter) # call pargi (npix - ngpix) # call parg$t (mean) # call parg$t (sigma) # Correct for clipping if (iter > 1 && signorm > EPSILOND) sigma = sigma / signorm # call eprintf (" sigma_corr=%f\n") # call parg$t (sigma) if (ngpix <= 1 || sigma <= EPSILONR) break if (ngpix >= old_ngpix) break deviation = sigma * kclip lcut = mean - deviation # compute window hcut = mean + deviation } return (ngpix) end int procedure akavgi (a, npix, mean, sigma, kclip, itmax) int a[ARB] # input data array real mean, sigma, kclip int npix, itmax, ngpix int akavri() double corr, signorm() begin # Compute ratio of k-clipped sigma to classical sigma for a normal # distribution corr = signorm (double(kclip)) ngpix = akavri (a, npix, mean, sigma, kclip, real(corr), itmax) return (ngpix) end # AKAVRx -- As AKAVGx except that the sigma normalisation is supplied by # the caller. int procedure akavri (a, npix, mean, sigma, kclip, signorm, itmax) int a[ARB] # input data array real mean, sigma, kclip, signorm, deviation, lcut, hcut int itmax, npix, ngpix, old_ngpix, iter, awvgi() begin lcut = -MAX_REAL # no rejection to start hcut = MAX_REAL ngpix = MAX_INT # Iteratively compute mean and sigma and reject outliers. # We exit when no more pixels are rejected, when there are # no more pixels, or when we have completed itmax iterations. do iter = 1, itmax { old_ngpix = ngpix ngpix = awvgi (a, npix, mean, sigma, lcut, hcut) # call eprintf ("iter=%d nrej=%d mean=%f sigma=%f") # call pargi (iter) # call pargi (npix - ngpix) # call parg$t (mean) # call parg$t (sigma) # Correct for clipping if (iter > 1 && signorm > EPSILOND) sigma = sigma / signorm # call eprintf (" sigma_corr=%f\n") # call parg$t (sigma) if (ngpix <= 1 || sigma <= EPSILONR) break if (ngpix >= old_ngpix) break deviation = sigma * kclip lcut = mean - deviation # compute window hcut = mean + deviation } return (ngpix) end int procedure akavgl (a, npix, mean, sigma, kclip, itmax) long a[ARB] # input data array double mean, sigma, kclip int npix, itmax, ngpix int akavrl() double corr, signorm() begin # Compute ratio of k-clipped sigma to classical sigma for a normal # distribution corr = signorm (kclip) ngpix = akavrl (a, npix, mean, sigma, kclip, corr, itmax) return (ngpix) end # AKAVRx -- As AKAVGx except that the sigma normalisation is supplied by # the caller. int procedure akavrl (a, npix, mean, sigma, kclip, signorm, itmax) long a[ARB] # input data array double mean, sigma, kclip, signorm, deviation, lcut, hcut int itmax, npix, ngpix, old_ngpix, iter, awvgl() begin lcut = -MAX_REAL # no rejection to start hcut = MAX_REAL ngpix = MAX_INT # Iteratively compute mean and sigma and reject outliers. # We exit when no more pixels are rejected, when there are # no more pixels, or when we have completed itmax iterations. do iter = 1, itmax { old_ngpix = ngpix ngpix = awvgl (a, npix, mean, sigma, lcut, hcut) # call eprintf ("iter=%d nrej=%d mean=%f sigma=%f") # call pargi (iter) # call pargi (npix - ngpix) # call parg$t (mean) # call parg$t (sigma) # Correct for clipping if (iter > 1 && signorm > EPSILOND) sigma = sigma / signorm # call eprintf (" sigma_corr=%f\n") # call parg$t (sigma) if (ngpix <= 1 || sigma <= EPSILOND) break if (ngpix >= old_ngpix) break deviation = sigma * kclip lcut = mean - deviation # compute window hcut = mean + deviation } return (ngpix) end int procedure akavgr (a, npix, mean, sigma, kclip, itmax) real a[ARB] # input data array real mean, sigma, kclip int npix, itmax, ngpix int akavrr() double corr, signorm() begin # Compute ratio of k-clipped sigma to classical sigma for a normal # distribution corr = signorm (double(kclip)) ngpix = akavrr (a, npix, mean, sigma, kclip, real(corr), itmax) return (ngpix) end # AKAVRx -- As AKAVGx except that the sigma normalisation is supplied by # the caller. int procedure akavrr (a, npix, mean, sigma, kclip, signorm, itmax) real a[ARB] # input data array real mean, sigma, kclip, signorm, deviation, lcut, hcut int itmax, npix, ngpix, old_ngpix, iter, awvgr() begin lcut = -MAX_REAL # no rejection to start hcut = MAX_REAL ngpix = MAX_INT # Iteratively compute mean and sigma and reject outliers. # We exit when no more pixels are rejected, when there are # no more pixels, or when we have completed itmax iterations. do iter = 1, itmax { old_ngpix = ngpix ngpix = awvgr (a, npix, mean, sigma, lcut, hcut) # call eprintf ("iter=%d nrej=%d mean=%f sigma=%f") # call pargi (iter) # call pargi (npix - ngpix) # call parg$t (mean) # call parg$t (sigma) # Correct for clipping if (iter > 1 && signorm > EPSILOND) sigma = sigma / signorm # call eprintf (" sigma_corr=%f\n") # call parg$t (sigma) if (ngpix <= 1 || sigma <= EPSILONR) break if (ngpix >= old_ngpix) break deviation = sigma * kclip lcut = mean - deviation # compute window hcut = mean + deviation } return (ngpix) end int procedure akavgd (a, npix, mean, sigma, kclip, itmax) double a[ARB] # input data array double mean, sigma, kclip int npix, itmax, ngpix int akavrd() double corr, signorm() begin # Compute ratio of k-clipped sigma to classical sigma for a normal # distribution corr = signorm (kclip) ngpix = akavrd (a, npix, mean, sigma, kclip, corr, itmax) return (ngpix) end # AKAVRx -- As AKAVGx except that the sigma normalisation is supplied by # the caller. int procedure akavrd (a, npix, mean, sigma, kclip, signorm, itmax) double a[ARB] # input data array double mean, sigma, kclip, signorm, deviation, lcut, hcut int itmax, npix, ngpix, old_ngpix, iter, awvgd() begin lcut = -MAX_REAL # no rejection to start hcut = MAX_REAL ngpix = MAX_INT # Iteratively compute mean and sigma and reject outliers. # We exit when no more pixels are rejected, when there are # no more pixels, or when we have completed itmax iterations. do iter = 1, itmax { old_ngpix = ngpix ngpix = awvgd (a, npix, mean, sigma, lcut, hcut) # call eprintf ("iter=%d nrej=%d mean=%f sigma=%f") # call pargi (iter) # call pargi (npix - ngpix) # call parg$t (mean) # call parg$t (sigma) # Correct for clipping if (iter > 1 && signorm > EPSILOND) sigma = sigma / signorm # call eprintf (" sigma_corr=%f\n") # call parg$t (sigma) if (ngpix <= 1 || sigma <= EPSILOND) break if (ngpix >= old_ngpix) break deviation = sigma * kclip lcut = mean - deviation # compute window hcut = mean + deviation } return (ngpix) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/ampinfo.com�����������������������������������������������0000664�0000000�0000000�00000000771�13321663143�0021652�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# AMPINFO.com -- Amplifier information common int namps # Number of amplifiers. pointer amplist # LIST of amplifier names. pointer offset_key # Name of zero offset header keyword pointer gain_key # Name of gain header keyword pointer dark_key # Name of dark rate header keyword pointer offset # Zero offset for each amp. pointer gain # Gain for each amp. pointer dark # Dark rate for each amp. common /ampinfo/ namps, amplist, offset_key, gain_key, dark_key, offset, gain, dark �������mscred-5.05-2018.07.09/src/mscdisplay/src/ampset.x��������������������������������������������������0000664�0000000�0000000�00000012672�13321663143�0021206�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include define DELIM "|" # Amplist dictionary delimitor define SZ_KEYWRD 8 # Length of valid FITS keyword procedure ampset() include "ampinfo.com" #pointer sp, pset, buf1, buf2, token, pp #int ip, nch, tok # #int ctotok(), ctowrd() #pointer clopset() #bool streq() begin call calloc (amplist, SZ_LINE, TY_CHAR) call calloc (offset_key, SZ_KEYWRD, TY_CHAR) call calloc (gain_key, SZ_KEYWRD, TY_CHAR) call calloc (dark_key, SZ_KEYWRD, TY_CHAR) namps = 0 # # Allocate stack space # call smark (sp) # call salloc (pset, SZ_LINE, TY_CHAR) # call salloc (buf1, SZ_LINE, TY_CHAR) # call salloc (buf2, SZ_LINE, TY_CHAR) # call salloc (token, SZ_LINE, TY_CHAR) # # # allocate space for string items in /ampinfo/ # call malloc (amplist, SZ_LINE, TY_CHAR) # call malloc (offset_key, SZ_KEYWRD, TY_CHAR) # call malloc (gain_key, SZ_KEYWRD, TY_CHAR) # call malloc (dark_key, SZ_KEYWRD, TY_CHAR) # # # Open "ampinfo" pset. # call clgstr ("ampinfo", Memc[pset], SZ_LINE) # if (Memc[pset] == EOS) # call strcpy ("ampinfo", Memc[pset], SZ_LINE) # pp = clopset (Memc[pset]) # # # Get list of amplifier names. # call clgpseta(pp, "amplist", Memc[buf1], SZ_LINE) # # # The amplist parameter may be: # # an image keyword # # one of the special values "image" or "" --> default keyword # # an explicit amplifier list # #if (Memc[buf1] == EOS || streq (Memc[buf1], "image")) { # # call hdmgstr ("amplist", Memc[buf1], SZ_LINE) # #} else { # # ip = 1 # # nch = ctowrd (Memc[buf1], ip, Memc[buf2], SZ_LINE) # # call hdmgstr (Memc[buf2], Memc[buf2], SZ_LINE) # # if (Memc[buf2] != EOS) # # call strcpy (Memc[buf2], Memc[buf1], SZ_LINE) # #} # # # Parse list of amplifier names # ip = 1 # namps = 0 # call strcpy (DELIM, Memc[amplist], SZ_LINE) # repeat { # tok = ctotok (Memc[buf1], ip, Memc[token], SZ_LINE) # switch (tok) { # # case TOK_EOS, TOK_NEWLINE: # break # # case TOK_PUNCTUATION, TOK_UNKNOWN: # next # # default: # namps = namps + 1 # call strcat (Memc[token], Memc[amplist], SZ_LINE) # call strcat (DELIM, Memc[amplist], SZ_LINE) # } # } # # if (namps == 0) { # Memc[amplist] = EOS # offset = NULL # gain = NULL # dark = NULL # } else { # call calloc (offset, namps, TY_REAL) # call calloc (dark, namps, TY_REAL) # call malloc (gain, namps, TY_REAL) # call amovkr (1.0, Memr[gain], namps) # } # # iferr { # # # Get offset gain and dark keywords, or lists of numeric values # call ampvals (pp, "offset", Memr[offset], namps, Memc[offset_key], # SZ_KEYWRD) # call ampvals (pp, "dark", Memr[dark], namps, Memc[dark_key], # SZ_KEYWRD) # call ampvals (pp, "gain", Memr[gain], namps, Memc[gain_key], # SZ_KEYWRD) # # } then { # call clcpset (pp) # call sfree (sp) # call ampfree () # call erract (EA_ERROR) # } # ## call eprintf ("namps=%d\n") ## call pargi (namps) ## ## do ip = 1, namps { ## call eprintf ("amp=%d offset=%f gain=%f dark=%f\n") ## call pargstr (ip) ## call pargr (Memr[offset+ip-1]) ## call pargr (Memr[gain+ip-1]) ## call pargr (Memr[dark+ip-1]) ## } # # call clcpset (pp) # call sfree (sp) end # AMPVALS -- Parse a string returning either a keyword or an array of values procedure ampvals (pset, param, vals, maxvals, keyword, maxch) pointer pset #I pset pointer. char param[ARB] #I parameter. real vals[ARB] #O Value array. int maxvals #I maximum number of values to return. char keyword[ARB] #O Keyword name. int maxch #I Max chars in keyword pointer sp, buffer, token int ip, nvals, tok, jp, nch, i char errmsg[SZ_LINE] int ctotok(), ctor() bool streq() begin call smark (sp) call salloc (buffer, SZ_LINE, TY_CHAR) call salloc (token, SZ_LINE, TY_CHAR) call clgpseta (pset, param, Memc[buffer], SZ_LINE) ip = 1 nvals = 0 keyword[1] = EOS repeat { tok = ctotok (Memc[buffer], ip, Memc[token], SZ_LINE) switch (tok) { case TOK_EOS, TOK_NEWLINE: break case TOK_PUNCTUATION, TOK_UNKNOWN: next # Got a number. Interpret as next value. case TOK_NUMBER: jp = 1 nvals = nvals + 1 if (nvals > maxvals) # Quit if we have as many as we need break nch = ctor (Memc[token], jp, vals[nvals]) # Got a string. If at beginning, interpret as fits keyword. # Otherwise complain. default: if (nvals == 0) { if (streq (Memc[token], "image")) { call strcpy (param, keyword, maxch) } else { call strcpy (Memc[token], keyword, maxch) } break } else { call sfree (sp) call sprintf (errmsg, SZ_LINE, "Badly formed value for %s") call pargstr (param) call error (0, errmsg) } } } if (nvals == 0) { if (keyword[1] == EOS) call strcpy (param, keyword, maxch) } else { # If the list of values is short set the remainder to the last value if (nvals <= maxvals) { do i = nvals+1, maxvals vals[i] = vals[nvals] } } call sfree (sp) end # AMPFREE -- Free memory assigned in /ampinfo/ common block. procedure ampfree () include "ampinfo.com" begin call mfree (amplist, TY_CHAR) call mfree (offset_key, TY_CHAR) call mfree (gain_key, TY_CHAR) call mfree (dark_key, TY_CHAR) if (namps > 0) { call mfree (offset, TY_REAL) call mfree (gain, TY_REAL) call mfree (dark, TY_REAL) } end # AMPNULL -- Set null information in /ampinfo/ common block. procedure ampnull () include "ampinfo.com" begin namps = 0 end ����������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/display.h�������������������������������������������������0000664�0000000�0000000�00000002110�13321663143�0021324�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Display modes: define RGB 1 # True color mode define FRAME 2 # Single frame mode # Color selections: define BLUE 1B # BLUE Select define GREEN 2B # GREEN Select define RED 4B # RED Select define MONO 7B # RED + GREEN + BLUE # Size limiting parameters. define MAXCHAN 2 define SAMPLE_SIZE 600 # If a logarithmic greyscale transformation is desired, the input range Z1:Z2 # will be mapped into the range 1.0 to 10.0 ** MAXLOG before taking the log # to the base 10. define MAXLOG 3 # The following parameter is used to compare display pixel coordinates for # equality. It determines the maximum permissible magnification. The machine # epsilon is not used because the computations are nontrivial and accumulation # of error is a problem. define DS_TOL (1E-4) # These parameters are needed for user defined transfer functions. define U_MAXPTS 4096 define U_Z1 0 define U_Z2 4095 # BPDISPLAY options: define BPDISPLAY "|none|overlay|interpolate|" define BPDNONE 1 # Ignore bad pixel mask define BPDOVRLY 2 # Overlay bad pixels define BPDINTERP 3 # Interpolate bad pixels ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/gamma.x���������������������������������������������������0000664�0000000�0000000�00000007175�13321663143�0021001�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # SIGNORM -- Calculate the ratio of the k-clipped sigma to the classical # sigma for a normal distribution. double procedure signorm (ksigma) double ksigma #I Clipping threshold expressed in sigma. double result #O Ratio of clipped to classical sigma. double x double gammp() begin x = 0.5d0 * ksigma**2 if (x > 0.0d0) { result = sqrt (gammp (1.5d0, x) / gammp (0.5d0, x)) } else { result = 0.0d0 } return (result) end # Based on Numerical Recipes by Press, Flannery, Teukolsky, and Vetterling. # Copyright(c) 1986 Numerical Recipes Software. # GAMMP -- returns the incomplete gamma function P(a,x) double procedure gammp (a, x) double a double x double result double gamcf(), gamser() begin if (x < 0.0d0) call error (0, "GAMMP -- X must be non-negative") if (a <= 0.0d0) call error (0, "GAMMP -- A must be positive") if (x < a + 1.0d0) { result = gamser (a, x) } else { result = 1.0d0 - gamcf (a, x) } return (result) end # GAMMQ -- returns the incomplete gamma function Q(a, x) = 1.0 - P(a,x) double procedure gammq (a, x) double a double x double gammp double gamcf(), gamser() begin if (x < 0.0d0) call error (0, "GAMMP -- X must be non-negative") if (a <= 0.0d0) call error (0, "GAMMP -- A must be positive") if (x < a + 1.0d0) { gammp = 1.0d0 - gamser (a, x) } else { gammp = gamcf (a, x) } return (gammp) end define ITMAX 500 define EPS EPSILOND * 2.0d0 # Evaluates the incomplete gamma function P(a,x) by its series representation. double procedure gamser (a, x) double a double x double result double gln, ap, sum, del int n double gammln() begin gln = gammln (a) if (x <= 0.0d0) { if (x < 0.0d0) call error (0, "GSER -- X must be non-negative") result = 0.0d0 return (result) } ap = a sum = 1.0d0 / a del = sum n = 1 repeat { ap = ap + 1.0d0 del = del * x / ap sum = sum + del n = n + 1 if (n > ITMAX) call error (0, "GAMSER -- A to large or itmax too small") } until (abs(del) < abs (sum) * EPS) result = sum * exp (-x + a*log(x) - gln) return (result) end # GAMCF -- Evaluates incomplete gamma function Q(a, x) via its continued # fraction representation. double procedure gamcf (a, x) double a double x double result double gln, gold, g, an, ana, a0, a1, b0, b1, fac, anf int n double gammln() begin gln = gammln (a) gold = 0.0d0 a0 = 1.0d0 a1 = x b0 = 0.0d0 b1 = 1.0d0 fac = 1.0d0 n = 1 repeat { an = double (n) ana = an - a a0 = (a1 + a0 * ana) * fac b0 = (b1 + b0 * ana) * fac anf = an * fac a1 = x * a0 + anf * a1 b1 = x * b0 + anf * b1 if (a1 != 0.0d0) { fac = 1.0d0 / a1 g = b1 * fac if (abs ((g - gold) / g) < EPS) break gold = g } n = n + 1 if (n > ITMAX) call error (0, "GAMCF -- A to large or itmax too small") } result = g * exp (-x + a * log(x) - gln) return (result) end # GAMMLN -- Return natural log of gamma function. # Argument must greater than 0. Full accuracy is obtained for values # greater than 1. For 0 include include "imexam.h" include "mscexam.h" # IE_CIMEXAM -- Column plot # If the input column is INDEF use the last column. procedure ie_cimexam (gp, mode, ie, x) pointer gp # GIO pointer int mode # Mode pointer ie # Structure pointer real x # Column real xavg, junk int i, x1, x2, y1, y2, nx, ny, npts pointer sp, title, im, data, ptr, xp, yp real asumr() int clgpseti() pointer clopset(), ie_gimage(), ie_gdata() errchk clcpset, clopset begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) IE_PP(ie) = clopset ("cimexam2") if (!IS_INDEF(x)) IE_X1(ie) = x nx = clgpseti (IE_PP(ie), "naverage") x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 x2 = IE_X1(ie) + nx / 2 + 0.5 xavg = (x1 + x2) / 2. y1 = INDEFI y2 = INDEFI iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny call smark (sp) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (xp, ny, TY_REAL) do i = 1, ny call ie_mwctran (ie, xavg, real(i), junk, Memr[xp+i-1]) if (nx > 1) { ptr = data call salloc (yp, ny, TY_REAL) do i = 1, ny { Memr[yp+i-1] = asumr (Memr[ptr], nx) ptr = ptr + nx } call adivkr (Memr[yp], real (nx), Memr[yp], ny) } else yp = data call sprintf (Memc[title], IE_SZTITLE, "%s: Columns %d - %d\n%s") call pargstr (IE_IMAGE(ie)) call pargi (x1) call pargi (x2) call pargstr (IM_TITLE(im)) call ie_graph (gp, mode, IE_PP(ie), Memc[title], Memr[xp], Memr[yp], ny, IE_YLABEL(ie), IE_YFORMAT(ie)) call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iecolon.x������������������������������������������0000664�0000000�0000000�00000062160�13321663143�0022622�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" # List of boundary types, marker types, and colon commands. define BTYPES "|constant|nearest|reflect|wrap|project|" define MTYPES "|point|box|plus|cross|circle|hebar|vebar|hline|vline|diamond|" define CMDS "|angh|angv|background|banner|boundary|box|buffer|ceiling|\ |center|constant|dashpat|defkey|eparam|fill|floor|interval|\ |label|logfile|logx|logy|magzero|majrx|majry|marker|minrx|\ |minry|naverage|ncolumns|ncontours|ncstat|nhi|nlines|nlstat|\ |pointmode|radius|round|rplot|select|szmarker|ticklabels|\ |title|width|x|xlabel|xorder|y|ylabel|yorder|zero|unlearn|\ |autoredraw|nbins|z1|z2|autoscale|top_closed|allframes|wcs|\ |xformat|yformat|fitplot|sigma|axes|fittype|beta|iterations|\ |output|ncoutput|nloutput|" define ANGH 1 define ANGV 2 define BACKGROUND 3 define BANNER 4 define BOUNDARY 5 define BOX 6 define BUFFER 7 define CEILING 8 define CENTER 10 define CONSTANT 11 define DASHPAT 12 define DEFKEY 13 define EPARAM 14 define FILL 15 define FLOOR 16 define INTERVAL 17 define LABEL 19 define LOGFILE 20 define LOGX 21 define LOGY 22 define MAGZERO 23 define MAJRX 24 define MAJRY 25 define MARKER 26 define MINRX 27 define MINRY 29 define NAVERAGE 30 define NCOLUMNS 31 define NCONTOURS 32 define NCSTAT 33 define NHI 34 define NLINES 35 define NLSTAT 36 define POINTMODE 38 define RADIUS 39 define ROUND 40 define RPLOT 41 define SELECT 42 define SZMARKER 43 define TICKLABELS 44 define TITLE 46 define WIDTH 47 define X 48 define XLABEL 49 define XORDER 50 define Y 51 define YLABEL 52 define YORDER 53 define ZERO 54 define UNLEARN 55 define AUTOREDRAW 57 define NBINS 58 define Z1 59 define Z2 60 define AUTOSCALE 61 define TOP_CLOSED 62 define ALLFRAMES 63 define WCS 64 define XFORMAT 66 define YFORMAT 67 define FITPLOT 68 define SIGMA 69 define AXES 70 define FITTYPE 71 define BETA 72 define ITERATIONS 73 define OUTPUT 75 define NCOUTPUT 76 define NLOUTPUT 77 # IE_COLON -- Respond to colon commands. procedure ie_colon (ie, cmdstr, gp, redraw) pointer ie # IMEXAM data structure char cmdstr[ARB] # Colon command pointer gp # GIO pointer int redraw # Redraw graph? char gtype bool bval real rval1 int ival, ncmd pointer sp, cmd, pp bool clgetb(), clgpsetb() char clgetc() real clgetr(), clgpsetr() int nscan(), strdic(), clgeti() pointer clopset() errchk clopset, clppsetb, clppsetr, clputb, clputi, clputr begin call smark (sp) call salloc (cmd, SZ_LINE, TY_CHAR) # Scan the command string and get the first word. call sscan (cmdstr) call gargwrd (Memc[cmd], SZ_LINE) ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, CMDS) if (ncmd == 0) { call printf ("Unrecognized or ambiguous command\007") call sfree (sp) return } gtype = IE_GTYPE(ie) pp = IE_PP(ie) # Special optimization for the a key. switch (ncmd) { case BACKGROUND, CENTER, NAVERAGE, RPLOT, XORDER, WIDTH: if (IE_LASTKEY(ie) == 'a') { gtype = 'r' pp = clopset ("rimexam2") } if (IE_LASTKEY(ie) == ',') { gtype = '.' pp = clopset ("rimexam2") } } # Switch on the command and possibly read further arguments. switch (ncmd) { case ANGH: call gargr (rval1) if (nscan() == 1) { call printf ("angh %g\n") call pargr (clgetr ("simexam2.angh")) } else { call clputr ("simexam2.angh", rval1) if (gtype == 's') redraw = YES } case ANGV: call gargr (rval1) if (nscan() == 1) { call printf ("angv %g\n") call pargr (clgetr ("simexam2.angv")) } else { call clputr ("simexam2.angv", rval1) if (gtype == 's') redraw = YES } case BACKGROUND: switch (gtype) { case 'j', 'k', 'r', '.': call gargb (bval) if (nscan() == 1) { call printf ("background %b\n") call pargb (clgpsetb (pp, "background")) } else { call clppsetb (pp, "background", bval) if (pp == IE_PP(ie)) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case BANNER: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "banner", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case BOUNDARY: call gargwrd (Memc[cmd], SZ_LINE) ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, BTYPES) if (ncmd == 0) { call printf ("Boundary types are %s\n") call pargstr (BTYPES) } else call clpstr ("vimexam2.boundary", Memc[cmd]) case BOX: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "box", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case BUFFER: call gargr (rval1) if (nscan() == 1) { call printf ("buffer %g\n") call pargr (clgetr ("rimexam2.buffer")) } else { call clputr ("rimexam2.buffer", rval1) if (gtype == 'r' || gtype == '.') redraw = YES } case CEILING: switch (gtype) { case 's', 'e': call gargr (rval1) if (nscan() == 1) { call printf ("ceiling %g\n") call pargr (clgpsetr (pp, "ceiling")) } else { call clppsetr (pp, "ceiling", rval1) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case CENTER: switch (gtype) { case 'j', 'k', 'r', '.': call gargb (bval) if (nscan() == 1) { call printf ("center %b\n") call pargb (clgpsetb (pp, "center")) } else { call clppsetb (pp, "center", bval) if (pp == IE_PP(ie)) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case CONSTANT: call gargr (rval1) if (nscan() == 1) { call printf ("constant %g\n") call pargr (clgetr ("vimexam2.constant")) } else call clputr ("vimexam2.constant", rval1) case DASHPAT: call gargi (ival) if (nscan() == 1) { call printf ("dashpat %g\n") call pargi (clgeti ("eimexam2.dashpat")) } else { call clputi ("eimexam2.dashpat", ival) if (gtype == 'e') redraw = YES } case DEFKEY: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) { call printf ("defkey %c\n") call pargc (clgetc ("defkey")) } else call clputc ("defkey", Memc[cmd]) case EPARAM: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) Memc[cmd] = gtype switch (Memc[cmd]) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 's', 'h', '.': call gdeactivate (gp, 0) switch (Memc[cmd]) { case 'c': call clcmdw ("eparam cimexam2") case 'j': call clcmdw ("eparam jimexam2") case 'k': call clcmdw ("eparam kimexam2") case 'l': call clcmdw ("eparam limexam2") case 'r', '.': call clcmdw ("eparam rimexam2") case 's': call clcmdw ("eparam simexam2") case 'u', 'v': call clcmdw ("eparam vimexam2") case 'e': call clcmdw ("eparam eimexam2") case 'h': call clcmdw ("eparam himexam2") } if (Memc[cmd] == gtype) redraw = YES } case FILL: call gargb (bval) if (nscan() == 1) { call printf ("fill %b\n") call pargb (clgetb ("eimexam2.fill")) } else { call clputb ("eimexam2.fill", bval) if (gtype == 'e') redraw = YES } case FLOOR: switch (gtype) { case 's', 'e': call gargr (rval1) if (nscan() == 1) { call printf ("floor %g\n") call pargr (clgpsetr (pp, "floor")) } else { call clppsetr (pp, "floor", rval1) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case INTERVAL: call gargr (rval1) if (nscan() == 1) { call printf ("interval %g\n") call pargr (clgetr ("eimexam2.interval")) } else { call clputr ("eimexam2.interval", rval1) if (gtype == 'e') redraw = YES } case LABEL: call gargb (bval) if (nscan() == 2) { call clputb ("eimexam2.label", bval) if (gtype == 'e') redraw = YES } case LOGFILE: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) { call strcpy (IE_LOGFILE(ie), Memc[cmd], SZ_LINE) if (IE_LOGFD(ie) == NULL) { call printf ("logfile %s [closed]\n") call pargstr (Memc[cmd]) } else { call printf ("logfile %s [open]\n") call pargstr (Memc[cmd]) } } else { call clpstr ("logfile", Memc[cmd]) if (IE_LOGFD(ie) != NULL) { call close (IE_LOGFD(ie)) IE_LOGFD(ie) = NULL } call clgstr ("logfile", IE_LOGFILE(ie), SZ_LINE) if (clgetb ("keeplog")) iferr (call ie_openlog (ie)) call erract (EA_WARN) } case LOGX: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "logx", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case LOGY: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "logy", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case MAGZERO: call gargr (rval1) if (nscan() == 1) { call printf ("magzero %g\n") call pargr (clgetr ("rimexam2.magzero")) } else { call clputr ("rimexam2.magzero", rval1) if (gtype == 'r' || gtype == '.') redraw = YES } case AUTOREDRAW: call gargb (bval) if (nscan() == 1) { call printf ("autoredraw %b\n") call pargb (clgetb ("autoredraw")) } else call clputb ("autoredraw", bval) default: call ie_colon1 (ie, ncmd, gp, pp, gtype, redraw) } if (pp != IE_PP(ie)) call clcpset (pp) if (redraw == YES && !clgetb ("autoredraw")) redraw = NO call sfree (sp) end # IE_COLON1 -- Subprocedure to get around too many strings error in xc. procedure ie_colon1 (ie, ncmd, gp, pp, gtype, redraw) pointer ie # IMEXAM data structure int ncmd # Command number pointer gp # GIO pointer pointer pp # Pset pointer char gtype # Graph type int redraw # Redraw graph? int ival real rval1, rval2 bool bval pointer sp, cmd, im real clgetr(), clgpsetr() pointer ie_gimage() int nscan(), strdic(), clgeti(), clgpseti() errchk ie_gimage, clppseti begin call smark (sp) call salloc (cmd, SZ_LINE, TY_CHAR) switch (ncmd) { case MAJRX: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargi (ival) if (nscan() == 1) { call printf ("majrx %d\n") call pargi (clgpseti (pp, "majrx")) } else { call clppseti (pp, "majrx", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case MAJRY: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargi (ival) if (nscan() == 1) { call printf ("majry %d\n") call pargi (clgpseti (pp, "majry")) } else { call clppseti (pp, "majry", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case MARKER: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargwrd (Memc[cmd], SZ_LINE) ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, MTYPES) if (ncmd == 0) { call printf ("Marker types are %s\n") call pargstr (MTYPES) } else { call clppset (pp, "marker", Memc[cmd]) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case MINRX: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargi (ival) if (nscan() == 1) { call printf ("minrx %d\n") call pargi (clgpseti (pp, "minrx")) } else { call clppseti (pp, "minrx", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case MINRY: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargi (ival) if (nscan() == 1) { call printf ("minry %d\n") call pargi (clgpseti (pp, "minry")) } else { call clppseti (pp, "minry", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case NAVERAGE: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'v': call gargi (ival) if (nscan() == 1) { call printf ("naverage %d\n") call pargi (clgpseti (pp, "naverage")) } else { call clppseti (pp, "naverage", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case NCOLUMNS: switch (gtype) { case 's', 'e', 'h': call gargi (ival) if (nscan() == 1) { call printf ("ncolumns %d\n") call pargi (clgpseti (pp, "ncolumns")) } else { call clppseti (pp, "ncolumns", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case NCONTOURS: call gargi (ival) if (nscan() == 1) { call printf ("ncontours %g\n") call pargi (clgeti ("eimexam2.ncontours")) } else { call clputi ("eimexam2.ncontours", ival) if (gtype == 'e') redraw = YES } case NCSTAT: call gargi (ival) if (nscan() == 1) { call printf ("ncstat %g\n") call pargi (clgeti ("ncstat")) } else call clputi ("ncstat", ival) case NHI: call gargi (ival) if (nscan() == 1) { call printf ("nhi %g\n") call pargi (clgeti ("eimexam2.nhi")) } else { call clputi ("eimexam2.nhi", ival) if (gtype == 'e') redraw = YES } case NLINES: switch (gtype) { case 's', 'e', 'h': call gargi (ival) if (nscan() == 1) { call printf ("nlines %d\n") call pargi (clgpseti (pp, "nlines")) } else { call clppseti (pp, "nlines", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case NLSTAT: call gargi (ival) if (nscan() == 1) { call printf ("nlstat %g\n") call pargi (clgeti ("nlstat")) } else call clputi ("nlstat", ival) case POINTMODE: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "pointmode", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case RADIUS: call gargr (rval1) if (nscan() == 1) { call printf ("radius %g\n") call pargr (clgetr ("rimexam2.radius")) } else { call clputr ("rimexam2.radius", rval1) if (gtype == 'r' || gtype == '.') redraw = YES } case ROUND: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "round", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case RPLOT: switch (gtype) { case 'j', 'k', 'r', '.': call gargr (rval1) if (nscan() == 1) { call printf ("rplot %g\n") call pargr (clgpsetr (pp, "rplot")) } else { call clppsetr (pp, "rplot", rval1) if (pp == IE_PP(ie)) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case SELECT: call gargi (ival) if (nscan () > 1) { if (IE_LIST(ie) != NULL) IE_INDEX(ie) = ival else IE_NEWFRAME(ie) = ival IE_MAPFRAME(ie) = 0 iferr (im = ie_gimage (ie, YES)) call erract (EA_WARN) } case SZMARKER: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargi (ival) if (nscan() == 1) { call printf ("szmarker %d\n") call pargi (clgpseti (pp, "szmarker")) } else { call clppseti (pp, "szmarker", ival) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case TICKLABELS: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': call gargb (bval) if (nscan() == 2) { call clppsetb (pp, "ticklabels", bval) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case TITLE: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 's', 'v', 'e', 'h', '.': Memc[cmd] = EOS call gargstr (Memc[cmd], SZ_LINE) call clppset (pp, "title", Memc[cmd]) redraw = YES default: call printf ("Parameter does not apply to current graph\007\n") } case WIDTH: switch (gtype) { case 'j', 'k', 'r', '.': call gargr (rval1) if (nscan() == 1) { call printf ("width %g\n") call pargr (clgpsetr (pp, "width")) } else { call clppsetr (pp, "width", rval1) if (pp == IE_PP(ie)) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case X: switch (gtype) { case 'c', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargr (rval1) call gargr (rval2) if (nscan() < 3) { call clppsetr (pp, "x1", INDEF) call clppsetr (pp, "x2", INDEF) } else { call clppsetr (pp, "x1", rval1) call clppsetr (pp, "x2", rval2) } redraw = YES default: call printf ("Parameter does not apply to current graph\007\n") } case XLABEL: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': Memc[cmd] = EOS call gargstr (Memc[cmd], SZ_LINE) call clppset (pp, "xlabel", Memc[cmd]) redraw = YES default: call printf ("Parameter does not apply to current graph\007\n") } case XORDER: switch (gtype) { case 'j', 'k', 'r', '.': call gargi (ival) if (nscan() == 1) { call printf ("xorder %d\n") call pargi (clgpseti (pp, "xorder")) } else { call clppseti (pp, "xorder", ival) if (pp == IE_PP(ie)) redraw = YES } default: call printf ("Parameter does not apply to current graph\007\n") } case Y: switch (gtype) { case 'c', 'j', 'k', 'l', 'r', 'v', 'h', '.': call gargr (rval1) call gargr (rval2) if (nscan() < 3) { call clppsetr (pp, "y1", INDEF) call clppsetr (pp, "y2", INDEF) } else { call clppsetr (pp, "y1", rval1) call clppsetr (pp, "y2", rval2) } redraw = YES default: call printf ("Parameter does not apply to current graph\007\n") } default: call ie_colon2 (ie, ncmd, gp, pp, gtype, redraw) } call sfree (sp) end # IE_COLON2 -- Subprocedure to get around too many strings error in xc. procedure ie_colon2 (ie, ncmd, gp, pp, gtype, redraw) pointer ie # IMEXAM data structure int ncmd # Command number pointer gp # GIO pointer pointer pp # Pset pointer char gtype # Graph type int redraw # Redraw graph? int ival real rval1 bool bval pointer sp, cmd real clgetr() bool clgetb() int nscan(), clgeti(), btoi(), strdic() begin call smark (sp) call salloc (cmd, SZ_LINE, TY_CHAR) switch (ncmd) { case YLABEL: switch (gtype) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 'h', '.': Memc[cmd] = EOS call gargstr (Memc[cmd], SZ_LINE) call clppset (pp, "ylabel", Memc[cmd]) redraw = YES default: call printf ("Parameter does not apply to current graph\007\n") } case YORDER: call gargi (ival) if (nscan() == 1) { call printf ("yorder %d\n") call pargi (clgeti ("rimexam2.yorder")) } else { call clputi ("rimexam2.yorder", ival) if (gtype == 'r' || gtype == '.') redraw = YES } case ZERO: call gargr (rval1) if (nscan() == 1) { call printf ("zero %g\n") call pargr (clgetr ("eimexam2.zero")) } else { call clputr ("eimexam2.zero", rval1) if (gtype == 'e') redraw = YES } case UNLEARN: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) Memc[cmd] = gtype switch (Memc[cmd]) { case 'c', 'u', 'j', 'k', 'l', 'r', 'v', 'e', 's', 'h', '.': switch (Memc[cmd]) { case 'c': call clcmdw ("unlearn cimexam2") case 'j': call clcmdw ("unlearn jimexam2") case 'k': call clcmdw ("unlearn jimexam2") case 'l': call clcmdw ("unlearn limexam2") case 'r', '.': call clcmdw ("unlearn rimexam2") case 's': call clcmdw ("unlearn simexam2") case 'u', 'v': call clcmdw ("unlearn vimexam2") case 'e': call clcmdw ("unlearn eimexam2") case 'h': call clcmdw ("unlearn himexam2") } if (Memc[cmd] == gtype) redraw = YES default: call printf ("Parameter does not apply to current graph\007\n") } case NBINS: call gargi (ival) if (nscan() == 1) { call printf ("nbins %d\n") call pargi (clgeti ("himexam2.nbins")) } else { call clputi ("himexam2.nbins", ival) if (gtype == 'h') redraw = YES } case Z1: call gargr (rval1) if (nscan() == 1) { call printf ("z1 %g\n") call pargr (clgetr ("himexam2.z1")) } else { call clputr ("himexam2.z1", rval1) if (gtype == 'h') redraw = YES } case Z2: call gargr (rval1) if (nscan() == 1) { call printf ("z2 %g\n") call pargr (clgetr ("himexam2.z2")) } else { call clputr ("himexam2.z2", rval1) if (gtype == 'h') redraw = YES } case AUTOSCALE: call gargb (bval) if (nscan() == 1) { call printf ("autoscale %b\n") call pargb (clgetb ("himexam2.autoscale")) } else { call clputb ("himexam2.autoscale", bval) if (gtype == 'h') redraw = YES } case TOP_CLOSED: call gargb (bval) if (nscan() == 1) { call printf ("top_closed %b\n") call pargb (clgetb ("himexam2.top_closed")) } else { call clputb ("himexam2.top_closed", bval) if (gtype == 'h') redraw = YES } case ALLFRAMES: call gargb (bval) if (nscan() == 1) { call printf ("allframes %b\n") call pargb (clgetb ("allframes")) } else { call clputb ("allframes", bval) IE_ALLFRAMES(ie) = btoi (bval) } case WCS: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) { call printf ("wcs %s\n") call pargstr (IE_WCSNAME(ie)) } else { call strcpy (Memc[cmd], IE_WCSNAME(ie), SZ_FNAME) call ie_mwinit (ie, NULL) redraw = YES } case XFORMAT: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) call clpstr ("xformat", "") else call clpstr ("xformat", Memc[cmd]) case YFORMAT: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) call clpstr ("yformat", "") else call clpstr ("yformat", Memc[cmd]) case FITPLOT: call gargb (bval) if (nscan() == 1) { call printf ("fitplot %b\n") call pargb (clgetb ("rimexam2.fitplot")) } else { call clputb ("rimexam2.fitplot", bval) if (gtype == 'r') redraw = YES } case SIGMA: call gargr (rval1) if (nscan() == 1) { call printf ("sigma %g\n") call pargr (clgetr ("jimexam2.sigma")) } else { call clputr ("jimexam2.sigma", rval1) if (gtype == 'j' || gtype == 'k') redraw = YES } case AXES: call gargb (bval) if (nscan() == 2) { call clputb ("simexam2.axes", bval) if (gtype == 's') redraw = YES } case FITTYPE: call gargwrd (Memc[cmd], SZ_LINE) if (nscan() == 1) { call clgstr ("rimexam2.fittype", Memc[cmd], SZ_LINE) call printf ("fittype %s\n") call pargstr (Memc[cmd]) } else { ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, "|gaussian|moffat|") if (ncmd == 0) { call printf ("Profile fit types are %s\n") call pargstr ("|gaussian|moffat|") } else { call clpstr ("rimexam2.fittype", Memc[cmd]) if (gtype == 'r' || gtype == '.') redraw = YES } } case BETA: call gargr (rval1) if (nscan() == 1) { call printf ("beta %g\n") call pargr (clgetr ("rimexam2.beta")) } else { call clputr ("rimexam2.beta", rval1) if (gtype == 'r' || gtype == '.') redraw = YES } case ITERATIONS: call gargi (ival) if (nscan() == 1) { call printf ("iterations %d\n") call pargi (clgeti ("rimexam2.iterations")) } else { call clputi ("rimexam2.iterations", ival) if (gtype == 'r') redraw = YES } case OUTPUT: call gargwrd (Memc[cmd], SZ_FNAME) if (nscan() == 1) { call clgstr ("output", Memc[cmd], SZ_FNAME) call printf ("output %s\n") call pargstr (Memc[cmd]) } else call clpstr ("output", Memc[cmd]) case NCOUTPUT: call gargi (ival) if (nscan() == 1) { call printf ("ncoutput %g\n") call pargi (clgeti ("ncoutput")) } else call clputi ("ncoutput", ival) case NLOUTPUT: call gargi (ival) if (nscan() == 1) { call printf ("nloutput %g\n") call pargi (clgeti ("nloutput")) } else call clputi ("nloutput", ival) default: call printf ("Ambiguous or unrecognized command\007\n") } call sfree (sp) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iedisplay.x����������������������������������������0000664�0000000�0000000�00000003265�13321663143�0023156�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "mscexam.h" # IE_DISPLAY -- Display an image. For the sake of convenience in this # prototype program we do this by calling a task via the cl. This is an # interface violation which we try to mitigate by using a CL parameter to # hide the knowledge of how to format the command (as well as make it easy # for the user to control how images are displayed). procedure ie_display (ie, image, frame) pointer ie #I imexamine descriptor char image[ARB] #I image to be displayed int frame #I frame in which to display image int nchars pointer sp, d_cmd, d_args, d_template, im int gstrcpy(), strmac(), ie_getnframes() pointer immap() begin call smark (sp) call salloc (d_cmd, SZ_LINE, TY_CHAR) call salloc (d_args, SZ_LINE, TY_CHAR) call salloc (d_template, SZ_LINE, TY_CHAR) # Verify that the named image or image section exists. iferr (im = immap (image, READ_ONLY, 0)) { call erract (EA_WARN) call sfree (sp) return } else call imunmap (im) # Get the display command template. call clgstr ("display", Memc[d_template], SZ_LINE) # Construct the macro argument list, a sequence of EOS delimited # strings terminated by a double EOS. call aclrc (Memc[d_args], SZ_LINE) nchars = gstrcpy (image, Memc[d_args], SZ_LINE) + 1 call sprintf (Memc[d_args+nchars], SZ_LINE-nchars, "%d") call pargi (frame) # Expand the command template to form the CL command. nchars = strmac (Memc[d_template], Memc[d_args], Memc[d_cmd], SZ_LINE) # Send the command off to the CL and wait for completion. call clcmdw (Memc[d_cmd]) nchars = ie_getnframes (ie) call sfree (sp) end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ieeimexam.x����������������������������������������0000664�0000000�0000000�00000014370�13321663143�0023135�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include include "imexam.h" include "mscexam.h" # IE_EIMEXAM -- Contour map # This is an interface to the NCAR CONREC routine. procedure ie_eimexam (gp, mode, ie, x, y) pointer gp # GIO pointer int mode # Mode pointer ie # IE pointer real x, y # Center bool banner int nset, ncontours, dashpat, nhi int x1, x2, y1, y2, nx, ny, npts, wkid real vx1, vx2, vy1, vy2, xs, xe, ys, ye real interval, floor, ceiling, zero, finc, zmin, zmax pointer sp, title, hostid, user, xlabel, ylabel, im, data, data1 pointer pp, clopset(), ie_gdata(), ie_gimage() bool clgpsetb(), fp_equalr() int clgpseti(), btoi() real clgpsetr() int isizel, isizem, isizep, nrep, ncrt, ilab, nulbll, ioffd int ioffm, isolid, nla, nlm real xlt, ybt, side, ext, hold[5] common /conre4/ isizel, isizem , isizep, nrep, ncrt, ilab, nulbll, ioffd, ext, ioffm, isolid, nla, nlm, xlt, ybt, side int first common /conflg/ first common /noaolb/ hold begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } pp = IE_PP(ie) if (pp != NULL) call clcpset (pp) pp = clopset ("eimexam2") IE_PP(ie) = pp if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y nx = clgpseti (pp, "ncolumns") ny = clgpseti (pp, "nlines") x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 x2 = IE_X1(ie) + nx / 2 + 0.5 y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 y2 = IE_Y1(ie) + ny / 2 + 0.5 iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny xs = x1 xe = x2 ys = y1 ye = y2 call smark (sp) banner = false if (mode == NEW_FILE) { call gclear (gp) # Set the WCS call gswind (gp, xs, xe, ys, ye) if (!clgpsetb (pp, "fill")) call gsetr (gp, G_ASPECT, real (ny-1) / real (nx-1)) call gseti (gp, G_ROUND, btoi (clgpsetb (pp, "round"))) if (clgpsetb (pp, "box")) { # Get number of major and minor tick marks. call gseti (gp, G_XNMAJOR, clgpseti (pp, "majrx")) call gseti (gp, G_XNMINOR, clgpseti (pp, "minrx")) call gseti (gp, G_YNMAJOR, clgpseti (pp, "majry")) call gseti (gp, G_YNMINOR, clgpseti (pp, "minry")) # Label tick marks on axes? call gseti (gp, G_LABELTICKS, btoi (clgpsetb (pp, "ticklabels"))) # Labels call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (hostid, SZ_LINE, TY_CHAR) call salloc (user, SZ_LINE, TY_CHAR) call salloc (xlabel, SZ_LINE, TY_CHAR) call salloc (ylabel, SZ_LINE, TY_CHAR) banner = clgpsetb (pp, "banner") if (banner) { call sysid (Memc[hostid], SZ_LINE) # We must postpone the parameter line until after conrec. call sprintf (Memc[title], IE_SZTITLE, "%s\n\n%s") call pargstr (Memc[hostid]) call pargstr (IM_TITLE(im)) } else Memc[title] = EOS call clgpset (pp, "title", Memc[user], SZ_LINE) if (Memc[user] != EOS) { call strcat ("\n", Memc[title], IE_SZTITLE) call strcat (Memc[user], Memc[title], IE_SZTITLE) } call clgpset (pp, "xlabel", Memc[xlabel], SZ_LINE) call clgpset (pp, "ylabel", Memc[ylabel], SZ_LINE) call glabax (gp, Memc[title], Memc[xlabel], Memc[ylabel]) } } # First of all, intialize conrec's block data before altering any # parameters in common. first = 1 call conbd # Set contour parameters zero = clgpsetr (pp, "zero") floor = clgpsetr (pp, "floor") ceiling = clgpsetr (pp, "ceiling") nhi = clgpseti (pp, "nhi") dashpat = clgpseti (pp, "dashpat") # Resolve INDEF limits. if (IS_INDEF (floor) || IS_INDEF (ceiling)) { call alimr (Memr[data], npts, zmin, zmax) if (IS_INDEF (floor)) floor = zmin if (IS_INDEF (ceiling)) ceiling = zmax } # Apply the zero point shift. if (abs (zero) > EPSILON) { call salloc (data1, npts, TY_REAL) call asubkr (Memr[data], zero, Memr[data1], npts) floor = floor - zero ceiling = ceiling - zero } else data1 = data # Avoid conrec's automatic scaling. if (floor == 0.) floor = EPSILON if (ceiling == 0.) ceiling = EPSILON # The user can suppress the contour labelling by setting the common # parameter "ilab" to zero. if (btoi (clgpsetb (pp, "label")) == NO) ilab = 0 else ilab = 1 # User can specify either the number of contours or the contour # interval, or let conrec pick a nice number. Get params and # encode the FINC param expected by conrec. ncontours = clgpseti (pp, "ncontours") if (ncontours <= 0) { interval = clgpsetr (pp, "interval") if (interval <= 0) finc = 0 else finc = interval } else finc = - abs (ncontours) # Open device and make contour plot. call gopks (STDERR) wkid = 1 call gopwk (wkid, 6, gp) call gacwk (wkid) # Make the contour plot. nset = 1 # No conrec viewport ioffm = 1 # No conrec box call gswind (gp, 1., real (nx), 1., real (ny)) call ggview (gp, vx1, vx2, vy1, vy2) call set (vx1, vx2, vy1, vy2, 1.0, real (nx), 1.0, real (ny), 1) call conrec (Memr[data1], nx, nx, ny, floor, ceiling, finc, nset, nhi, -dashpat) call gdawk (wkid) call gclks () call gswind (gp, xs, xe, ys, ye) if (banner) { if (fp_equalr (hold(5), 1.0)) { call sprintf (Memc[title], IE_SZTITLE, "%s\n%s: Contoured from %g to %g, interval = %g\n%s") call pargstr (Memc[hostid]) call pargstr (IE_IMAGE(ie)) call pargr (hold(1)) call pargr (hold(2)) call pargr (hold(3)) call pargstr (IM_TITLE(im)) } else { call sprintf (Memc[title], IE_SZTITLE, "%s\n%s:contoured from %g to %g, interval = %g, labels scaled by %g\n%s") call pargstr (Memc[xlabel]) call pargstr (IE_IMAGE(ie)) call pargr (hold(1)) call pargr (hold(2)) call pargr (hold(3)) call pargr (hold(5)) call pargstr (IM_TITLE(im)) } if (Memc[user] != EOS) { call strcat ("\n", Memc[user], IE_SZTITLE) call strcat (Memc[user], Memc[title], IE_SZTITLE) } call gseti (gp, G_DRAWAXES, NO) call glabax (gp, Memc[title], "", "") } else call gtext (gp, xs, ys, "", "") call sfree (sp) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iegcur.x�������������������������������������������0000664�0000000�0000000�00000013313�13321663143�0022444�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include "imexam.h" include "mscexam.h" # IE_GCUR -- Get IMEXAM cursor value. # This is an interface between the standard cursor input and IMEXAM. # It reads the appropriate cursor, determines the image index or frame # type, makes the appropriate default coordinate conversions when using # graphics cursor input, and gets any further cursor reads needed. # Missing coordinates default to the last coordinates. int procedure ie_gcur (ie, curtype, x, y, key, strval, maxch) pointer ie #I IMEXAM structure int curtype #I cursor type (0=image, 1=graphics, 2=text) real x, y #O cursor position int key #O keystroke value of cursor event char strval[ARB] #O string value, if any int maxch #I max chars out char ch real x1, y1, x2, y2, dx, dy, r, cosa, sina int temp, k[2], nitems, wcs, ip, i bool streq() char clgetc() int clgcur(), imd_gcur(), ctor(), cctoc() errchk clgcur, imd_gcur begin # Save last cursor value. x1 = x; y1 = y strval[1] = EOS k[1] = clgetc ("defkey") # Get one or more cursor values from the desired cursor parameter. # Check for missing coordinates and substitute the last value. do i = 1, 2 { switch (curtype) { case 'i': nitems = imd_gcur ("imagecur", x, y, wcs, k[i], strval, maxch) call moscoords (wcs, x, y) if (IS_INDEF(x)) x = x1 if (IS_INDEF(y)) y = y1 if (wcs >= 100) IE_NEWFRAME(ie) = wcs / 100 else if (wcs >= 1) IE_NEWFRAME(ie) = wcs if (IE_DFRAME(ie) <= 0) IE_DFRAME(ie) = IE_NEWFRAME(ie) case 'g': nitems = clgcur ("graphcur", x, y, wcs, k[i], strval, maxch) # Make any needed default coordinate conversions from the # graphic coordinates. switch (IE_GTYPE(ie)) { case 'c', 'k': # Column plot y = x x = IE_X1(ie) if (IS_INDEF(y)) y = y1 else if (IE_MW(ie) != NULL) { if (streq (IE_WCSNAME(ie), "logical")) ; else if (streq (IE_WCSNAME(ie), "physical")) call ie_imwctran (ie, x, y, dx, y) else { r = y y = IM_LEN(IE_IM(ie),2) call ie_mwctran (ie, x, 1., dx, y1) call ie_mwctran (ie, x, y, dx, y2) dy = y while (dy > .001) { dy = dy / 2 if (r > y1) { if (r < y2) y = y - dy else y = y + dy } else { if (r < y2) y = y + dy else y = y - dy } call ie_mwctran (ie, x, y, dx, y2) } } } case 'e': # Contour plot if (IS_INDEF(x)) x = x1 if (IS_INDEF(y)) y = y1 case 'j', 'l': # Line plot y = IE_Y1(ie) if (IS_INDEF(x)) x = x1 else if (IE_MW(ie) != NULL) { if (streq (IE_WCSNAME(ie), "logical")) ; else if (streq (IE_WCSNAME(ie), "physical")) call ie_imwctran (ie, x, y, x, dy) else { r = x x = IM_LEN(IE_IM(ie),1) call ie_mwctran (ie, 1., y, x1, dy) call ie_mwctran (ie, x, y, x2, dy) dx = x while (dx > .001) { dx = dx / 2 if (r > x1) { if (r < x2) x = x - dx else x = x + dx } else { if (r < x2) x = x + dx else x = x - dx } call ie_mwctran (ie, x, y, x2, dy) } } } case 'r','.': # Radial profile plot x = IE_X1(ie) y = IE_Y1(ie) case 'h', 's': # Surface plot x = IE_X1(ie) y = IE_Y1(ie) case 'u': # Vector plot if (IS_INDEF(x)) x = x1 y = x * sina + (IE_Y1(ie) + IE_Y2(ie)) / 2 x = x * cosa + (IE_X1(ie) + IE_X2(ie)) / 2 case 'v': # Vector plot if (IS_INDEF(x)) x = x1 y = x * sina + IE_Y1(ie) x = x * cosa + IE_X1(ie) } } key = k[1] switch (key) { case 'v', 'u': if (i == 1) { x1 = x y1 = y call printf ("again:") } else { x2 = x y2 = y r = sqrt (real ((y2-y1)**2 + (x2-x1)**2)) if (r > 0.) { cosa = (x2 - x1) / r sina = (y2 - y1) / r } else { cosa = 0. sina = 0. } call printf ("\n") switch (key) { case 'v': x = x1 y = y1 case 'u': x = 2 * x1 - x2 y = 2 * y1 - y2 } IE_X2(ie) = x2 IE_Y2(ie) = y2 break } case 'b': if (i == 1) { IE_IX1(ie) = x + 0.5 IE_IY1(ie) = y + 0.5 call printf ("again:") } else { IE_IX2(ie) = x + 0.5 IE_IY2(ie) = y + 0.5 call printf ("\n") temp = IE_IX1(ie) IE_IX1(ie) = min (IE_IX1(ie), IE_IX2(ie)) IE_IX2(ie) = max (temp, IE_IX2(ie)) temp = IE_IY1(ie) IE_IY1(ie) = min (IE_IY1(ie), IE_IY2(ie)) IE_IY2(ie) = max (temp, IE_IY2(ie)) break } default: break } } # Map numeric colon sequences (: x [y] key strval) to make them appear # as ordinary "x y key" type cursor reads. This makes it possible for # the user to access any command using typed in rather than positional # cursor coordinates. Special treatment is also given to the syntax # ":lN" and ":cN", provided for compatibility with IMPLOT for simple # line and column plots. if (key == ':') { for (ip=1; IS_WHITE(strval[ip]); ip=ip+1) ; if (IS_DIGIT(strval[ip])) { if (ctor (strval, ip, x) <= 0) ; if (ctor (strval, ip, y) <= 0) y = x for (; IS_WHITE(strval[ip]); ip=ip+1) ; if (cctoc (strval, ip, ch) > 0) key = ch call strcpy (strval[ip], strval, maxch) } else if (strval[ip] == 'l' && IS_DIGIT(strval[ip+1])) { ip = ip + 1 if (ctor (strval, ip, x) > 0) { y = x key = 'l' } } else if (strval[ip] == 'c' && IS_DIGIT(strval[ip+1])) { ip = ip + 1 if (ctor (strval, ip, x) > 0) { y = x key = 'c' } } } return (nitems) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iegdata.x������������������������������������������0000664�0000000�0000000�00000001553�13321663143�0022567�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "mscexam.h" # IE_GDATA -- Get image data with boundary checking. pointer procedure ie_gdata (im, x1, x2, y1, y2) pointer im # IMIO pointer int x1, x2, y1, y2 # Subraster limits (input and output) int i, cx1, cx2, cy1, cy2 pointer mg, imgs2r() errchk imgs2r begin if (im == NULL) call error (1, "No image defined") mg = MI_CMG(im) cx1 = CX1(mg) cx2 = CX2(mg) cy1 = CY1(mg) cy2 = CY2(mg) if (IS_INDEFI (x1)) x1 = cx1 if (IS_INDEFI (x2)) x2 = cx2 if (IS_INDEFI (y1)) y1 = cy1 if (IS_INDEFI (y2)) y2 = cy2 i = max (x1, x2) x1 = min (x1, x2) x2 = i i = max (y1, y2) y1 = min (y1, y2) y2 = i x1 = max (x1, cx1) x2 = min (x2, cx2) y1 = max (y1, cy1) y2 = min (y2, cy2) return (imgs2r (im, x1, x2, y1, y2)) end �����������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iegimage.x�����������������������������������������0000664�0000000�0000000�00000011406�13321663143�0022736�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" include "mscexam.h" # IE_GIMAGE -- Get input image name and return IMIO pointer. # If examining a list of images access the indexed image, displaying it if # not already displayed. Otherwise the image loaded into the current display # frame is displayed, if it can be accessed, or the image frame buffer itself # is examined. If there is neither a list of images nor display access the # user is queried for the name of the image to be examined. # This procedure uses a prototype display interface (IMD/IW). pointer procedure ie_gimage (ie, select) pointer ie #I IMEXAM pointer int select #I select frame? int frame, i pointer sp, image, dimage, imname, im int imtrgetim() bool strne(), streq() pointer imd_mapframe(), immap() errchk imd_mapframe, immap, ie_display, ie_mwinit begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (dimage, SZ_FNAME, TY_CHAR) # Get image name, and display image if using display. If we are # examining a list of images, the list and the current index into # the list determine the image to be examined. If there is no list # we examine the currently displayed images, if any, else the # contents of the image display frame buffers are examined as images. if (IE_LIST(ie) != NULL) { # Get image name. IE_INDEX(ie) = max(1, min(IE_LISTLEN(ie), IE_INDEX(ie))) if (imtrgetim (IE_LIST(ie), IE_INDEX(ie), Memc[image], SZ_FNAME) == EOF) call error (1, "Reference outside of image list") # Display image. if (IE_USEDISPLAY(ie) == YES) { # Is named image currently loaded into the image display? frame = 0 if (streq (Memc[image], IE_IMAGE(ie))) frame = IE_MAPFRAME(ie) else { if (IE_DS(ie) == NULL) IE_DS(ie) = imd_mapframe (max (1, IE_NEWFRAME(ie)), READ_WRITE, NO) do i = 1, IE_NFRAMES(ie) { if (i == IE_MAPFRAME(ie)) next call ie_imname (IE_DS(ie), i, Memc[dimage], SZ_FNAME) if (streq (Memc[image], Memc[dimage])) { frame = i break } } } # Load image into display frame if not already loaded. # If the allframes option is specified cycle through the # available display frames, otherwise resuse the same frame. if (frame == 0) { if (IE_DS(ie) != NULL) call IMUNMAP (IE_DS(ie)) frame = max (1, IE_DFRAME(ie)) call ie_display (ie, Memc[image], frame) IE_MAPFRAME(ie) = 0 if (IE_ALLFRAMES(ie) == YES) { IE_DFRAME(ie) = frame + 1 if (IE_DFRAME(ie) > IE_NFRAMES(ie)) IE_DFRAME(ie) = 1 } } # Map and display-select the frame. if (frame != IE_MAPFRAME(ie) || frame != IE_NEWFRAME(ie)) { if (IE_DS(ie) != NULL) call IMUNMAP (IE_DS(ie)) IE_DS(ie) = imd_mapframe (frame, READ_WRITE, select) IE_MAPFRAME(ie) = frame IE_NEWFRAME(ie) = frame } } } else if (IE_USEDISPLAY(ie) == YES) { # Map the new display frame. if (IE_NEWFRAME(ie) != IE_MAPFRAME(ie)) { if (IE_DS(ie) != NULL) call IMUNMAP (IE_DS(ie)) IE_DS(ie) = imd_mapframe (IE_NEWFRAME(ie), READ_WRITE, select) IE_MAPFRAME(ie) = IE_NEWFRAME(ie) } # Get the image name. call ie_imname (IE_DS(ie), IE_MAPFRAME(ie), Memc[image], SZ_FNAME) } else call clgstr ("image", Memc[image], SZ_FNAME) # Check if the image has not been mapped and if so map it. # Possibly log any change of image. Always map the physical image, # not a section, since we do everything in image coordinates. if (IE_IM(ie) == NULL || strne (Memc[image], IE_IMAGE(ie))) { call imgimage (Memc[image], Memc[imname], SZ_FNAME) iferr (im = immap (Memc[imname], READ_ONLY, 0)) { # # Access the display frame buffer as the data image. # if (IE_USEDISPLAY(ie) == YES && IE_LIST(ie) == NULL) { # if (IE_IM(ie) != NULL && IE_IM(ie) != IE_DS(ie)) # iferr (call imunmap (IE_IM(ie))) # ; # IE_IM(ie) = IE_DS(ie) # call sprintf (IE_IMAGE(ie), IE_SZFNAME, "Frame.%d(%s)") # call pargi (IE_MAPFRAME(ie)) # call pargstr (Memc[image]) # call strcpy ("Contents of raw image frame buffer\n", # IM_TITLE(IE_IM(ie)), SZ_IMTITLE) # } else call erract (EA_WARN) } else { # Make the new image the current one. call strcpy (Memc[image], IE_IMAGE(ie), IE_SZFNAME) if (IE_IM(ie) != NULL && IE_IM(ie) != IE_DS(ie)) iferr (call imunmap (IE_IM(ie))) ; if (IE_MW(ie) != NULL) call mw_close (IE_MW(ie)) IE_IM(ie) = im if (IE_LOGFD(ie) != NULL) { call fprintf (IE_LOGFD(ie), "# [%d] %s - %s\n") call pargi (IE_INDEX(ie)) call pargstr (IE_IMAGE(ie)) call pargstr (IM_TITLE(im)) } } call ie_mwinit (ie, NULL) } call sfree (sp) return (IE_IM(ie)) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iegnfr.x�������������������������������������������0000664�0000000�0000000�00000003255�13321663143�0022444�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "imexam.h" # IE_GETNFRAMES -- Determine the number of image display frames. If the # display can be accessed at all we assume there is always at least one # frame; beyond that presence of a valid WCS is used to test whether we # are interested in looking at a frame. int procedure ie_getnframes (ie) pointer ie #I imexamine descriptor pointer sp, imname, ds, iw int server, nframes, status, i int clgeti(), strncmp() pointer imd_mapframe(), iw_open() errchk imd_mapframe, clgeti begin call smark (sp) call salloc (imname, SZ_FNAME, TY_CHAR) nframes = clgeti ("nframes") if (nframes == 0) { # Try to automatically determine the number of frames. ds = IE_DS(ie) if (ds == NULL) ds = imd_mapframe (1, READ_WRITE, NO) # If we are talking to a simple image display we assume the device # has 4 frames (until more general display interfaces come along). # Servers are more complicated because the number of frames is # dynamically configurable, even while imexamine is running. # We use the WCS query to try to count the current number of # allocated frames in the case of a server device. server = IM_LEN(ds,4) if (server == YES) { nframes = 1 do i = 1, MAX_FRAMES { iferr (iw = iw_open (ds, i, Memc[imname], SZ_FNAME, status)) next call iw_close (iw) if (strncmp (Memc[imname], "[NOSUCHFRAME]", 3) != 0) nframes = max (nframes, i) } } else nframes = 4 if (IE_DS(ie) == NULL) call imunmap (ds) } IE_NFRAMES(ie) = max (nframes, IE_DFRAME(ie)) call sfree (sp) return (nframes) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iegraph.x������������������������������������������0000664�0000000�0000000�00000010263�13321663143�0022606�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "imexam.h" define MTYPES "|point|box|plus|cross|circle|hebar|vebar|hline|vline|diamond|" define IE_GBUF 0.10 # Buffer around data define IE_SZTITLE 512 # Size of multiline title # IE_GRAPH -- Make a graph # This procedure is used by most of the different graph types to provide # consistency in features and parameters. The parameters are read using # the pset pointer. procedure ie_graph (gp, mode, pp, param, x, y, npts, label, format) pointer gp # GIO pointer int mode # Mode pointer pp # PSET pointer char param[ARB] # Parameter string real x[npts] # X data real y[npts] # Y data int npts # Number of points char label # Default x label char format # Default x format int i, marks[10], linepattern, patterns[4], clgpseti(), btoi(), strdic() pointer sp, title, xlabel, ylabel real x1, x2, y1, y2, wx1, wx2, wy1, wy2, temp, szmarker real clgpsetr(), ie_iformatr() bool clgpsetb(), streq() data patterns/GL_SOLID, GL_DASHED, GL_DOTTED, GL_DOTDASH/ data marks/GM_POINT, GM_BOX, GM_PLUS, GM_CROSS, GM_CIRCLE, GM_HEBAR, GM_VEBAR, GM_HLINE, GM_VLINE, GM_DIAMOND/ begin call smark (sp) call salloc (xlabel, SZ_LINE, TY_CHAR) # If a new graph setup all the axes and labeling options and then # make the graph. if (mode == NEW_FILE) { call gclear (gp) linepattern = 0 x1 = ie_iformatr (clgpsetr (pp, "x1"), format) x2 = ie_iformatr (clgpsetr (pp, "x2"), format) y1 = clgpsetr (pp, "y1") y2 = clgpsetr (pp, "y2") if (IS_INDEF (x1) || IS_INDEF (x2)) call gascale (gp, x, npts, 1) if (IS_INDEF (y1) || IS_INDEF (y2)) call gascale (gp, y, npts, 2) call gswind (gp, x1, x2, y1, y2) call ggwind (gp, wx1, wx2, wy1, wy2) temp = wx2 - wx1 if (IS_INDEF (x1)) wx1 = wx1 - IE_GBUF * temp if (IS_INDEF (x2)) wx2 = wx2 + IE_GBUF * temp temp = wy2 - wy1 if (IS_INDEF (y1)) wy1 = wy1 - IE_GBUF * temp if (IS_INDEF (y2)) wy2 = wy2 + IE_GBUF * temp call gswind (gp, wx1, wx2, wy1, wy2) call gsetr (gp, G_ASPECT, 0.) call gseti (gp, G_ROUND, btoi (clgpsetb (pp, "round"))) i = GW_LINEAR if (clgpsetb (pp, "logx")) i = GW_LOG call gseti (gp, G_XTRAN, i) i = GW_LINEAR if (clgpsetb (pp, "logy")) i = GW_LOG call gseti (gp, G_YTRAN, i) if (clgpsetb (pp, "box")) { # Get number of major and minor tick marks. call gseti (gp, G_XNMAJOR, clgpseti (pp, "majrx")) call gseti (gp, G_XNMINOR, clgpseti (pp, "minrx")) call gseti (gp, G_YNMAJOR, clgpseti (pp, "majry")) call gseti (gp, G_YNMINOR, clgpseti (pp, "minry")) # Label tick marks on axes? call gsets (gp, G_XTICKFORMAT, format) call gseti (gp, G_LABELTICKS, btoi (clgpsetb (pp, "ticklabels"))) # Fetch labels and plot title string. call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (ylabel, SZ_LINE, TY_CHAR) if (clgpsetb (pp, "banner")) { call sysid (Memc[title], IE_SZTITLE) call strcat ("\n", Memc[title], IE_SZTITLE) call strcat (param, Memc[title], IE_SZTITLE) } else Memc[title] = EOS call clgpset (pp, "title", Memc[xlabel], SZ_LINE) if (Memc[xlabel] != EOS) { call strcat ("\n", Memc[title], IE_SZTITLE) call strcat (Memc[xlabel], Memc[title], IE_SZTITLE) } call clgpset (pp, "xlabel", Memc[xlabel], SZ_LINE) call clgpset (pp, "ylabel", Memc[ylabel], SZ_LINE) if (streq ("wcslabel", Memc[xlabel])) call strcpy (label, Memc[xlabel], SZ_LINE) call glabax (gp, Memc[title], Memc[xlabel], Memc[ylabel]) } } # Draw the data. if (clgpsetb (pp, "pointmode")) { call clgpset (pp, "marker", Memc[xlabel], SZ_LINE) i = strdic (Memc[xlabel], Memc[xlabel], SZ_LINE, MTYPES) if (i == 0) i = 2 if (marks[i] == GM_POINT) szmarker = 0.0 else szmarker = clgpsetr (pp, "szmarker") call gpmark (gp, x, y, npts, marks[i], szmarker, szmarker) } else { linepattern = min (4, linepattern + 1) call gseti (gp, G_PLTYPE, patterns[linepattern]) call gpline (gp, x, y, npts) } call gflush (gp) call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iehimexam.x����������������������������������������0000664�0000000�0000000�00000011541�13321663143�0023135�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" include "mscexam.h" define HGM_TYPES "|line|box|" define HGM_LINE 1 # line vectors for histogram plot define HGM_BOX 2 # box vectors for histogram plot # IE_HIMEXAM -- Compute and plot or list a histogram. # If the GIO pointer is NULL list the histogram otherwise make a graph. procedure ie_himexam (gp, mode, ie, x, y) pointer gp # GIO pointer (NULL for histogram listing) int mode # Mode pointer ie # Structure pointer real x, y # Center coordinate real z1, z2, dz, zmin, zmax int i, j, x1, x2, y1, y2, nx, ny, npts, nbins, nbins1, nlevels, nwide pointer pp, sp, hgm, title, im, data, xp, yp int clgpseti() real clgpsetr() bool clgpsetb(), fp_equalr() pointer clopset(), ie_gimage(), ie_gdata() begin # Get the image and return on error. iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } # Use last graph coordinate if redrawing. Close last graph pset # pointer if making new graph. if (gp != NULL) { if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y z1 = IE_X1(ie) z2 = IE_Y1(ie) if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) } else { z1 = x z2 = y } # Get the data. pp = clopset ("himexam2") nx = clgpseti (pp, "ncolumns") ny = clgpseti (pp, "nlines") x1 = z1 - (nx - 1) / 2 + 0.5 x2 = z1 + nx / 2 + 0.5 y1 = z2 - (ny - 1) / 2 + 0.5 y2 = z2 + ny / 2 + 0.5 iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny # Get default histogram resolution. nbins = clgpseti (pp, "nbins") # Get histogram range. z1 = clgpsetr (pp, "z1") z2 = clgpsetr (pp, "z2") # Use data limits for INDEF limits. if (IS_INDEFR(z1) || IS_INDEFR(z2)) { call alimr (Memr[data], npts, zmin, zmax) if (IS_INDEFR(z1)) z1 = zmin if (IS_INDEFR(z2)) z2 = zmax } if (z1 > z2) { dz = z1; z1 = z2; z2 = dz } # Adjust the resolution of the histogram and/or the data range # so that an integral number of data values map into each # histogram bin (to avoid aliasing effects). if (clgpsetb (pp, "autoscale")) { switch (IM_PIXTYPE(im)) { case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: nlevels = nint (z2) - nint (z1) nwide = max (1, nint (real (nlevels) / real (nbins))) nbins = max (1, nint (real (nlevels) / real (nwide))) z2 = nint (z1) + nbins * nwide } } # Test for constant valued image, which causes zero divide in ahgm. if (fp_equalr (z1, z2)) { call eprintf ("Warning: Image `%s' has no data range.\n") call pargstr (IE_IMAGE(ie)) return } # The extra bin counts the pixels that equal z2 and shifts the # remaining bins to evenly cover the interval [z1,z2]. # Note that real numbers could be handled better - perhaps # adjust z2 upward by ~ EPSILONR (in ahgm itself). nbins1 = nbins + 1 # Initialize the histogram buffer and image line vector. call smark (sp) call salloc (hgm, nbins1, TY_INT) call aclri (Memi[hgm], nbins1) call ahgmr (Memr[data], npts, Memi[hgm], nbins1, z1, z2) # "Correct" the topmost bin for pixels that equal z2. Each # histogram bin really wants to be half open. if (clgpsetb (pp, "top_closed")) Memi[hgm+nbins-1] = Memi[hgm+nbins-1] + Memi[hgm+nbins1-1] # List or plot the histogram. In list format, the bin value is the # z value of the left side (start) of the bin. dz = (z2 - z1) / real (nbins) if (gp != NULL) { # Draw the plot. if (clgpsetb (pp, "pointmode")) { nbins1 = nbins call salloc (xp, nbins1, TY_REAL) call salloc (yp, nbins1, TY_REAL) call achtir (Memi[hgm], Memr[yp], nbins1) Memr[xp] = z1 + dz / 2. do i = 1, nbins1 - 1 Memr[xp+i] = Memr[xp+i-1] + dz } else { nbins1 = 2 * nbins call salloc (xp, nbins1, TY_REAL) call salloc (yp, nbins1, TY_REAL) Memr[xp] = z1 Memr[yp] = Memi[hgm] j = 0 do i = 1, nbins - 1 { Memr[xp+j+1] = Memr[xp+j] + dz Memr[yp+j+1] = Memr[yp+j] j = j + 1 Memr[xp+j+1] = Memr[xp+j] Memr[yp+j+1] = Memi[hgm+i] j = j + 1 } Memr[xp+j+1] = Memr[xp+j] + dz Memr[yp+j+1] = Memr[yp+j] } call salloc (title, IE_SZTITLE, TY_CHAR) call sprintf (Memc[title], IE_SZTITLE, "%s[%d:%d,%d:%d]: Histogram from z1=%g to z2=%g, nbins=%d\n%s") call pargstr (IE_IMAGE(ie)) call pargi (x1) call pargi (x2) call pargi (y1) call pargi (y2) call pargr (z1) call pargr (z2) call pargi (nbins) call pargstr (IM_TITLE(im)) call ie_graph (gp, mode, pp, Memc[title], Memr[xp], Memr[yp], nbins1, "", "") IE_PP(ie) = pp } else { do i = 1, nbins { call printf ("%g %d\n") call pargr (z1 + (i-1) * dz) call pargi (Memi[hgm+i-1]) } call clcpset (pp) } call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ieimname.x�����������������������������������������0000664�0000000�0000000�00000001205�13321663143�0022747�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. # IE_IMNAME -- Get the name of the image displayed in a display frame. procedure ie_imname (ds, frame, imname, maxch) pointer ds #I display descriptor int frame #I display frame char imname[maxch] #O image name int maxch #I max chars out int status pointer sp, dname, iw pointer iw_open() errchk iw_open begin call smark (sp) call salloc (dname, SZ_LINE, TY_CHAR) iw = iw_open (ds, frame, Memc[dname], SZ_LINE, status) call iw_close (iw) # call imgimage (Memc[dname], imname, maxch) call strcpy (Memc[dname], imname, maxch) call sfree (sp) end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iejimexam.x����������������������������������������0000664�0000000�0000000�00000026300�13321663143�0023136�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include "imexam.h" include "mscexam.h" # IE_JIMEXAM -- 1D profile plot and gaussian fit parameters. # If no GIO pointer is given then only the fit parameters are printed. # The fitting uses a Levenberg-Marquardt nonlinear chi square minimization. procedure ie_jimexam (gp, mode, ie, x, y, axis) pointer gp pointer ie int mode real x, y int axis int navg, order, clgpseti() bool center, background, clgpsetb() real sigma, width, rplot, clgpsetr() int i, j, k, nx, ny, x1, x2, y1, y2, nfit, flag[5] real xc, yc, bkg, r, dr, fit[5], xfit, yfit, asumr(), amedr() pointer sp, title, avstr, im, pp, data, xs, ys, ptr pointer clopset(), ie_gimage(), ie_gdata() errchk ie_gdata, mr_solve begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } # Get parameters if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) if (axis == 1) IE_PP(ie) = clopset ("jimexam2") else IE_PP(ie) = clopset ("kimexam2") pp = IE_PP(ie) navg = clgpseti (pp, "naverage") center = clgpsetb (pp, "center") background = clgpsetb (pp, "background") sigma = clgpsetr (pp, "sigma") rplot = clgpsetr (pp, "rplot") if (background) { order = clgpsetr (pp, "xorder") width = clgpsetr (pp, "width") } # If the initial center is INDEF then use the previous value. if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y if (axis == 1) { xc = IE_X1(ie) yc = IE_Y1(ie) } else { xc = IE_Y1(ie) yc = IE_X1(ie) } # Get data r = max (rplot, 8 * sigma + width) x1 = xc - r x2 = xc + r y1 = nint (yc) - (navg - 1) / 2 y2 = nint (yc) + navg / 2 iferr { if (axis == 1) data = ie_gdata (im, x1, x2, y1, y2) else data = ie_gdata (im, y1, y2, x1, x2) } then { call erract (EA_WARN) return } # Compute average vector nx = x2 - x1 + 1 ny = y2 - y1 + 1 yc = (y1 + y2) / 2. call smark (sp) call salloc (xs, nx, TY_REAL) call salloc (ys, nx, TY_REAL) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (avstr, SZ_LINE, TY_CHAR) ptr = data if (axis == 1) { call sprintf (Memc[avstr], SZ_LINE, "Lines %d-%d") call pargi (y1) call pargi (y2) call amovr (Memr[ptr], Memr[ys], nx) ptr = ptr + nx do i = 2, ny { call aaddr (Memr[ptr], Memr[ys], Memr[ys], nx) ptr = ptr + nx } call adivkr (Memr[ys], real (ny), Memr[ys], nx) } else { call sprintf (Memc[avstr], SZ_LINE, "Columns %d-%d") call pargi (y1) call pargi (y2) do i = 0, nx-1 { Memr[ys+i] = asumr (Memr[ptr], ny) / ny ptr = ptr + ny } } # Set default background bkg = 0. if (background) { r = 4 * sigma ptr = xs do i = 0, nx-1 { if (abs (xc - x1 - i) > r) { Memr[ptr] = Memr[ys+i] ptr = ptr + 1 } } if (ptr > xs) bkg = amedr (Memr[xs], ptr-xs) } # Convert to WCS if (axis == 1) { call ie_mwctran (ie, xc, yc, xfit, yfit) call ie_mwctran (ie, xc+sigma, yc, r, yfit) dr = abs (xfit - r) do i = 0, nx-1 call ie_mwctran (ie, real(x1+i), yc, Memr[xs+i], yfit) } else { call ie_mwctran (ie, yc, xc, yfit, xfit) call ie_mwctran (ie, yc, xc+sigma, yfit, r) dr = abs (xfit - r) do i = 0, nx-1 call ie_mwctran (ie, yc, real(x1+i), yfit, Memr[xs+i]) } # Set initial fit parameters k = max (0, nint (xc - x1)) fit[1] = bkg fit[2] = 0. fit[3] = Memr[ys+k] - fit[1] fit[4] = xfit fit[5] = dr # Do fitting. nfit = 1 flag[1] = 3 # Add centering if desired if (center) { nfit = nfit + 1 flag[nfit] = 4 call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) } # Add sigma nfit = nfit + 1 flag[nfit] = 5 call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) # Now add background if desired if (background) { if (order == 1) { nfit = nfit + 1 flag[nfit] = 1 call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) } else if (order == 2) { nfit = nfit + 2 flag[nfit-1] = 1 flag[nfit] = 2 call ie_gfit (Memr[xs], Memr[ys], nx, fit, flag, nfit) } } # Plot the profile and overplot the gaussian fit. call sprintf (Memc[title], IE_SZTITLE, "%s: %s\n%s") call pargstr (IE_IMAGE(ie)) call pargstr (Memc[avstr]) call pargstr (IM_TITLE(im)) j = max (0, int (xc - x1 - rplot)) k = min (nx-1, nint (xc - x1 + rplot)) if (axis == 1) call ie_graph (gp, mode, pp, Memc[title], Memr[xs+j], Memr[ys+j], k-j+1, IE_XLABEL(ie), IE_XFORMAT(ie)) else call ie_graph (gp, mode, pp, Memc[title], Memr[xs+j], Memr[ys+j], k-j+1, IE_YLABEL(ie), IE_YFORMAT(ie)) call gseti (gp, G_PLTYPE, 2) xfit = min (Memr[xs+j], Memr[xs+k]) r = (xfit - fit[4]) / fit[5] dr = abs ((Memr[xs+k] - Memr[xs+j]) / (k - j)) if (abs (r) < 7.) yfit = fit[1] + fit[2] * xfit + fit[3] * exp (-r**2 / 2.) else yfit = fit[1] + fit[2] * xfit call gamove (gp, xfit, yfit) repeat { xfit = xfit + 0.2 * dr r = (xfit - fit[4]) / fit[5] if (abs (r) < 7.) yfit = fit[1] + fit[2] * xfit + fit[3] * exp (-r**2 / 2.) else yfit = fit[1] + fit[2] * xfit call gadraw (gp, xfit, yfit) } until (xfit >= max (Memr[xs+j], Memr[xs+k])) call gseti (gp, G_PLTYPE, 1) # Print the fit values call printf ("%s: center=%7g peak=%7g sigma=%7.4g fwhm=%7.4g bkg=%7g\n") call pargstr (Memc[avstr]) call pargr (fit[4]) call pargr (fit[3]) call pargr (fit[5]) call pargr (2.35482*fit[5]) call pargr (fit[1]+fit[2]*fit[4]) if (IE_LOGFD(ie) != NULL) { call fprintf (IE_LOGFD(ie), "%s: center=%7g peak=%7g sigma=%5.3f fwhm=%5.3f bkg=%7g\n") call pargstr (Memc[avstr]) call pargr (fit[4]) call pargr (fit[3]) call pargr (fit[5]) call pargr (2.35482*fit[5]) call pargr (fit[1]+fit[2]*fit[4]) } call sfree (sp) end # IE_GFIT -- 1D Gaussian fit. procedure ie_gfit (xs, ys, nx, fit, flag, nfit) real xs[nx], ys[nx] # Vector to be fit int nx # Number of points real fit[5] # Fit parameters int flag[nfit] # Flag for parameters to be fit int nfit # Number of parameters to be fit int i real chi1, chi2, mr begin chi2 = MAX_REAL mr = -1. i = 0 repeat { call mr_solve (xs, ys, nx, fit, flag, 5, nfit, mr, chi1) if (chi2 - chi1 > 1.) i = 0 else i = i + 1 chi2 = chi1 } until (i == 3) mr = 0. call mr_solve (xs, ys, nx, fit, flag, 5, nfit, mr, chi1) fit[5] = abs (fit[5]) end # DERIVS -- Compute model and derivatives for MR_SOLVE procedure. # # I(x) = A1 + A2 * x + A3 exp {-[(x - A4) / A5]**2 / 2.} # # where the params are A1-A5. procedure derivs (x, a, y, dyda, na) real x # X value to be evaluated real a[na] # Parameters real y # Function value real dyda[na] # Derivatives int na # Number of parameters real arg, ex, fac begin arg = (x - a[4]) / a[5] if (abs (arg) < 7.) ex = exp (-arg**2 / 2.) else ex = 0. fac = a[3] * ex * arg y = a[1] + a[2] * x + a[3] * ex dyda[1] = 1. dyda[2] = x dyda[3] = ex dyda[4] = fac / a[5] dyda[5] = fac * arg / a[5] end # MR_SOLVE -- Levenberg-Marquardt nonlinear chi square minimization. # # Use the Levenberg-Marquardt method to minimize the chi squared of a set # of paraemters. The parameters being fit are indexed by the flag array. # To initialize the Marquardt parameter, MR, is less than zero. After that # the parameter is adjusted as needed. To finish set the parameter to zero # to free memory. This procedure requires a subroutine, DERIVS, which # takes the derivatives of the function being fit with respect to the # parameters. There is no limitation on the number of parameters or # data points. For a description of the method see NUMERICAL RECIPES # by Press, Flannery, Teukolsky, and Vetterling, p523. procedure mr_solve (x, y, npts, params, flags, np, nfit, mr, chisq) real x[npts] # X data array real y[npts] # Y data array int npts # Number of data points real params[np] # Parameter array int flags[np] # Flag array indexing parameters to fit int np # Number of parameters int nfit # Number of parameters to fit real mr # MR parameter real chisq # Chi square of fit int i real chisq1 pointer new, a1, a2, delta1, delta2 errchk mr_invert begin # Allocate memory and initialize. if (mr < 0.) { call mfree (new, TY_REAL) call mfree (a1, TY_REAL) call mfree (a2, TY_REAL) call mfree (delta1, TY_REAL) call mfree (delta2, TY_REAL) call malloc (new, np, TY_REAL) call malloc (a1, nfit*nfit, TY_REAL) call malloc (a2, nfit*nfit, TY_REAL) call malloc (delta1, nfit, TY_REAL) call malloc (delta2, nfit, TY_REAL) call amovr (params, Memr[new], np) call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a2], Memr[delta2], nfit, chisq) mr = 0.001 } # Restore last good fit and apply the Marquardt parameter. call amovr (Memr[a2], Memr[a1], nfit * nfit) call amovr (Memr[delta2], Memr[delta1], nfit) do i = 1, nfit Memr[a1+(i-1)*(nfit+1)] = Memr[a2+(i-1)*(nfit+1)] * (1. + mr) # Matrix solution. call mr_invert (Memr[a1], Memr[delta1], nfit) # Compute the new values and curvature matrix. do i = 1, nfit Memr[new+flags[i]-1] = params[flags[i]] + Memr[delta1+i-1] call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a1], Memr[delta1], nfit, chisq1) # Check if chisq has improved. if (chisq1 < chisq) { mr = max (EPSILONR, 0.1 * mr) chisq = chisq1 call amovr (Memr[a1], Memr[a2], nfit * nfit) call amovr (Memr[delta1], Memr[delta2], nfit) call amovr (Memr[new], params, np) } else mr = 10. * mr if (mr == 0.) { call mfree (new, TY_REAL) call mfree (a1, TY_REAL) call mfree (a2, TY_REAL) call mfree (delta1, TY_REAL) call mfree (delta2, TY_REAL) } end # MR_EVAL -- Evaluate curvature matrix. This calls procedure DERIVS. procedure mr_eval (x, y, npts, params, flags, np, a, delta, nfit, chisq) real x[npts] # X data array real y[npts] # Y data array int npts # Number of data points real params[np] # Parameter array int flags[np] # Flag array indexing parameters to fit int np # Number of parameters real a[nfit,nfit] # Curvature matrix real delta[nfit] # Delta array int nfit # Number of parameters to fit real chisq # Chi square of fit int i, j, k real ymod, dy, dydpj, dydpk pointer sp, dydp begin call smark (sp) call salloc (dydp, np, TY_REAL) do j = 1, nfit { do k = 1, j a[j,k] = 0. delta[j] = 0. } chisq = 0. do i = 1, npts { call derivs (x[i], params, ymod, Memr[dydp], np) dy = y[i] - ymod do j = 1, nfit { dydpj = Memr[dydp+flags[j]-1] delta[j] = delta[j] + dy * dydpj do k = 1, j { dydpk = Memr[dydp+flags[k]-1] a[j,k] = a[j,k] + dydpj * dydpk } } chisq = chisq + dy * dy } do j = 2, nfit do k = 1, j-1 a[k,j] = a[j,k] call sfree (sp) end # MR_INVERT -- Solve a set of linear equations using Householder transforms. procedure mr_invert (a, b, n) real a[n,n] # Input matrix and returned inverse real b[n] # Input RHS vector and returned solution int n # Dimension of input matrices int krank real rnorm pointer sp, h, g, ip begin call smark (sp) call salloc (h, n, TY_REAL) call salloc (g, n, TY_REAL) call salloc (ip, n, TY_INT) call hfti (a, n, n, n, b, n, 1, 1E-10, krank, rnorm, Memr[h], Memr[g], Memi[ip]) call sfree (sp) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ielimexam.x����������������������������������������0000664�0000000�0000000�00000003407�13321663143�0023143�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" include "mscexam.h" # IE_LIMEXAM -- Make a line plot # If the line is INDEF then use the last line. procedure ie_limexam (gp, mode, ie, y) pointer gp # GIO pointer int mode # Mode pointer ie # Structure pointer real y # Line real yavg, junk int i, x1, x2, y1, y2, nx, ny, npts pointer sp, title, im, data, ptr, xp, yp int clgpseti() pointer clopset(), ie_gimage(), ie_gdata() begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) IE_PP(ie) = clopset ("limexam2") if (!IS_INDEF(y)) IE_Y1(ie) = y ny = clgpseti (IE_PP(ie), "naverage") x1 = INDEFI x2 = INDEFI y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 y2 = IE_Y1(ie) + ny / 2 + 0.5 yavg = (y1 + y2) / 2. iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny call smark (sp) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (xp, nx, TY_REAL) do i = 1, nx call ie_mwctran (ie, real(i), yavg, Memr[xp+i-1], junk) if (ny > 1) { ptr = data call salloc (yp, nx, TY_REAL) call amovr (Memr[ptr], Memr[yp], nx) do i = 2, ny { ptr = ptr + nx call aaddr (Memr[ptr], Memr[yp], Memr[yp], nx) } call adivkr (Memr[yp], real (ny), Memr[yp], nx) } else yp = data call sprintf (Memc[title], IE_SZTITLE, "%s: Lines %d - %d\n%s") call pargstr (IE_IMAGE(ie)) call pargi (y1) call pargi (y2) call pargstr (IM_TITLE(im)) call ie_graph (gp, mode, IE_PP(ie), Memc[title], Memr[xp], Memr[yp], nx, IE_XLABEL(ie), IE_XFORMAT(ie)) call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iemw.x���������������������������������������������0000664�0000000�0000000�00000013660�13321663143�0022134�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" include "mscexam.h" # IE_MWINIT -- Initialize MWCS procedure ie_mwinit (ie, im1) pointer ie # IMEXAM descriptor pointer im1 # IMIO pointer int i, j, wcsdim, mw_stati(), nowhite(), strldxs() pointer im, mw, wcs, ctlw, ctwl, mw_openim(), mw_sctran() pointer sp, axno, axval, str1, str2 bool streq() errchk mw_openim, mw_sctran pointer lastim common /iemw/ lastim begin if (IE_IM(ie) == NULL) return im = im1 if (im == NULL) im = MI_IM(IE_IM(ie),1) lastim = im mw = IE_MW(ie) if (mw != NULL) { call mw_close (mw) IE_MW(ie) = mw } IE_XLABEL(ie) = EOS IE_YLABEL(ie) = EOS call clgstr ("xformat", IE_XFORMAT(ie), IE_SZFORMAT) call clgstr ("yformat", IE_YFORMAT(ie), IE_SZFORMAT) i = nowhite (IE_XFORMAT(ie), IE_XFORMAT(ie), IE_SZFORMAT) i = nowhite (IE_YFORMAT(ie), IE_YFORMAT(ie), IE_SZFORMAT) if (im == NULL || im == IE_DS(ie)) return call smark (sp) call salloc (axno, IM_MAXDIM, TY_INT) call salloc (axval, IM_MAXDIM, TY_INT) call salloc (str1, SZ_LINE, TY_CHAR) call salloc (str2, SZ_LINE, TY_CHAR) mw = mw_openim (im, wcs) call mw_seti (mw, MW_USEAXMAP, NO) wcsdim = mw_stati (mw, MW_NDIM) call mw_gaxmap (mw, Memi[axno], Memi[axval], wcsdim) IE_P1(ie) = 1 IE_P2(ie) = 2 do i = 1, wcsdim { j = Memi[axno+i-1] if (j == 0) IE_IN(ie,i) = 1 else if (j == 1) IE_P1(ie) = i else if (j == 2) IE_P2(ie) = i } ctlw = mw_sctran (wcs, 1, "logical", IE_WCSNAME(ie), 0) ctwl = mw_sctran (wcs, 2, IE_WCSNAME(ie), "logical", 0) # Set coordinate labels and formats i = IE_P1(ie) j = IE_P2(ie) if (streq (IE_WCSNAME(ie), "logical")) { call strcpy ("Column (pixels)", IE_XLABEL(ie), IE_SZFNAME) call strcpy ("Line (pixels)", IE_YLABEL(ie), IE_SZFNAME) if (strldxs ("HMhm", IE_XFORMAT(ie)) > 0) IE_XFORMAT(ie) = EOS if (strldxs ("HMhm", IE_YFORMAT(ie)) > 0) IE_YFORMAT(ie) = EOS } else if (streq (IE_WCSNAME(ie), "physical")) { if (strldxs ("HMhm", IE_XFORMAT(ie)) > 0) IE_XFORMAT(ie) = EOS if (strldxs ("HMhm", IE_YFORMAT(ie)) > 0) IE_YFORMAT(ie) = EOS if (i == 1) call strcpy ("Column (pixels)", IE_XLABEL(ie), IE_SZFNAME) else if (i == 2) call strcpy ("Line (pixels)", IE_XLABEL(ie), IE_SZFNAME) else call strcpy ("Pixels", IE_XLABEL(ie), IE_SZFNAME) if (j == 1) call strcpy ("Column (pixels)", IE_YLABEL(ie), IE_SZFNAME) else if (j == 2) call strcpy ("Line (pixels)", IE_YLABEL(ie), IE_SZFNAME) else call strcpy ("Pixels", IE_YLABEL(ie), IE_SZFNAME) } else { ifnoerr (call mw_gwattrs (mw, i, "label", Memc[str1], SZ_LINE)) { ifnoerr (call mw_gwattrs (mw, i, "units", Memc[str2],SZ_LINE)) { call sprintf (IE_XLABEL(ie), IE_SZFNAME, "%s (%s)") call pargstr (Memc[str1]) call pargstr (Memc[str2]) } else { call sprintf (IE_XLABEL(ie), IE_SZFNAME, "%s") call pargstr (Memc[str1]) } } if (IE_XFORMAT(ie) != '%') ifnoerr (call mw_gwattrs (mw, i, "format", Memc[str1], SZ_LINE)) call strcpy (Memc[str1], IE_XFORMAT(ie), IE_SZFORMAT) ifnoerr (call mw_gwattrs (mw, j, "label", Memc[str1], SZ_LINE)) { ifnoerr (call mw_gwattrs (mw, j, "units", Memc[str2],SZ_LINE)) { call sprintf (IE_YLABEL(ie), IE_SZFNAME, "%s (%s)") call pargstr (Memc[str1]) call pargstr (Memc[str2]) } else { call sprintf (IE_YLABEL(ie), IE_SZFNAME, "%s") call pargstr (Memc[str1]) } } if (IE_YFORMAT(ie) != '%') ifnoerr (call mw_gwattrs (mw, j, "format", Memc[str1], SZ_LINE)) call strcpy (Memc[str1], IE_YFORMAT(ie), IE_SZFORMAT) # Check for equitorial coordinate and reversed formats. ifnoerr (call mw_gwattrs (mw, i, "axtype", Memc[str1], SZ_LINE)) if ((streq(Memc[str1],"ra")&&strldxs("hm",IE_XFORMAT(ie))>0) || (streq(Memc[str1],"dec")&&strldxs("HM",IE_XFORMAT(ie))>0)) { call strcpy (IE_XFORMAT(ie), Memc[str1], IE_SZFORMAT) call strcpy (IE_YFORMAT(ie), IE_XFORMAT(ie),IE_SZFORMAT) call strcpy (Memc[str1], IE_YFORMAT(ie), IE_SZFORMAT) } } IE_MW(ie) = wcs IE_CTLW(ie) = wcs IE_CTWL(ie) = wcs IE_WCSDIM(ie) = wcsdim call sfree (sp) end # IE_MWCTRAN -- Evaluate MWCS coordinate procedure ie_mwctran (ie, xin, yin, xout, yout) pointer ie # IMEXAM descriptor real xin, yin # Input coordinate real xout, yout # Output coordinate bool strne() real x, y pointer im, lastim common /iemw/ lastim begin if (strne (IE_WCSNAME(ie), "world")) { xout = xin yout = yin return } iferr (call mg_c2im (IE_IM(ie), xin, yin, im, x, y)) im = lastim if (im != lastim) call ie_mwinit (ie, im) if (IE_MW(ie) == NULL) { xout = xin yout = yin return } IE_IN(ie,IE_P1(ie)) = x IE_IN(ie,IE_P2(ie)) = y call mw_ctranr (IE_CTLW(ie), 1, IE_IN(ie,1), IE_OUT(ie,1), IE_WCSDIM(ie)) xout = IE_OUT(ie,IE_P1(ie)) yout = IE_OUT(ie,IE_P2(ie)) end # IE_IMWCTRAN -- Evaluate inverse MWCS coordinate procedure ie_imwctran (ie, xin, yin, xout, yout) pointer ie # IMEXAM descriptor real xin, yin # Input coordinate real xout, yout # Output coordinate bool strne() pointer lastim common /iemw/ lastim begin if (strne (IE_WCSNAME(ie), "world")) { xout = xin yout = yin return } if (IE_MW(ie) == NULL) { xout = xin yout = yin return } IE_OUT(ie,IE_P1(ie)) = xin IE_OUT(ie,IE_P2(ie)) = yin call mw_ctranr (IE_CTWL(ie), 2, IE_OUT(ie,1), IE_IN(ie,1), IE_WCSDIM(ie)) xout = IE_IN(ie,IE_P1(ie)) yout = IE_IN(ie,IE_P2(ie)) call mg_im2c (lastim, xout, yout, IE_IM(ie), xout, yout) end # IE_IFORMATR -- Determine the inverse formatted real value # This temporary routine is used to account for scaling of the H and M formats. real procedure ie_iformatr (value, format) real value # Value to be inverse formated char format[ARB] # Format int strldxs() begin if (!IS_INDEF(value) && strldxs ("HM", format) > 0) return (value * 15.) else return (value) end ��������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ieopenlog.x����������������������������������������0000664�0000000�0000000�00000001475�13321663143�0023155�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" include "mscexam.h" # IE_OPENLOG -- Open the log file. procedure ie_openlog (ie) pointer ie #I imexamine descriptor int nowhite(), open() errchk open, close begin if (IE_LOGFD(ie) != NULL) { call close (IE_LOGFD(ie)) IE_LOGFD(ie) = NULL } if (nowhite (IE_LOGFILE(ie), IE_LOGFILE(ie), SZ_FNAME) > 0) { iferr { IE_LOGFD(ie) = open (IE_LOGFILE(ie), APPEND, TEXT_FILE) call printf ("Log file %s open\n") call pargstr (IE_LOGFILE(ie)) if (IE_IM(ie) != NULL) { call fprintf (IE_LOGFD(ie), "# [%d] %s - %s\n") call pargi (IE_INDEX(ie)) call pargstr (IE_IMAGE(ie)) call pargstr (IM_TITLE(IE_IM(ie))) } } then call erract (EA_WARN) } end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iepos.x��������������������������������������������0000664�0000000�0000000�00000011601�13321663143�0022303�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" # IE_POS -- Print cursor position and pixel value or set new origin. # If the origin is not (0,0) print additional fields. procedure ie_pos (ie, x, y, key) pointer ie # IMEXAM structure real x, y # Center of box int key # Key ('x' positions, 'y' origin) pointer im, data real dx, dy, r, t, wx, wy, xo, yo int x1, x2, y1, y2 pointer ie_gimage(), ie_gdata() begin switch (key) { case 'x': # Print position and pixel value iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } x1 = x + 0.5 x2 = x + 0.5 y1 = y + 0.5 y2 = y + 0.5 iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } call printf ("%7.2f %7.2f %7g") call pargr (x) call pargr (y) call pargr (Memr[data]) # Print additional fields if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { dx = x - IE_XORIGIN(ie) dy = y - IE_YORIGIN(ie) r = sqrt (dx * dx + dy * dy) t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) call printf (" %7.f %7.2f %7.2f %7.2f %7.2f %5.1f") call pargr (IE_XORIGIN(ie)) call pargr (IE_YORIGIN(ie)) call pargr (dx) call pargr (dy) call pargr (r) call pargr (t) } call printf ("\n") case 'y': # Set new origin IE_XORIGIN(ie) = x IE_YORIGIN(ie) = y call printf ("Origin: %.2f %.2f\n") call pargr (IE_XORIGIN(ie)) call pargr (IE_YORIGIN(ie)) } # Print to logfile if needed. if (IE_LOGFD(ie) != NULL) { switch (key) { case 'x': call fprintf (IE_LOGFD(ie), "%7.2f %7.2f %7g") call pargr (x) call pargr (y) call pargr (Memr[data]) if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { dx = x - IE_XORIGIN(ie) dy = y - IE_YORIGIN(ie) r = sqrt (dx * dx + dy * dy) t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) call fprintf (IE_LOGFD(ie), " %7.f %7.2f %7.2f %7.2f %7.2f %5.1f") call pargr (IE_XORIGIN(ie)) call pargr (IE_YORIGIN(ie)) call pargr (dx) call pargr (dy) call pargr (r) call pargr (t) } call fprintf (IE_LOGFD(ie), "\n") case 'y': # Set new origin IE_XORIGIN(ie) = x IE_YORIGIN(ie) = y call fprintf (IE_LOGFD(ie), "Origin: %.2f %.2f\n") call pargr (IE_XORIGIN(ie)) call pargr (IE_YORIGIN(ie)) } } # Print in WCS if necessary. call ie_mwctran (ie, x, y, wx, wy) if (x == wx && y == wy) return call ie_mwctran (ie, IE_XORIGIN(ie), IE_YORIGIN(ie), xo, yo) switch (key) { case 'x': # Print position and pixel value if (IE_XFORMAT(ie) == '%') call printf (IE_XFORMAT(ie)) else call printf ("%7g") call pargr (wx) call printf (" ") if (IE_YFORMAT(ie) == '%') call printf (IE_YFORMAT(ie)) else call printf ("%7g") call pargr (wy) call printf (" %7g") call pargr (Memr[data]) # Print additional fields if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { dx = wx - xo dy = wy - yo r = sqrt (dx * dx + dy * dy) t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) call printf (" %7g %7g %7g %7g %7g %5.1f") call pargr (xo) call pargr (yo) call pargr (dx) call pargr (dy) call pargr (r) call pargr (t) } call printf ("\n") case 'y': # Set new origin call printf ("Origin: %7g %7g\n") call pargr (xo) call pargr (yo) } # Print to logfile if needed. if (IE_LOGFD(ie) != NULL) { switch (key) { case 'x': if (IE_XFORMAT(ie) == '%') call fprintf (IE_LOGFD(ie), IE_XFORMAT(ie)) else call fprintf (IE_LOGFD(ie), "%7g") call pargr (wx) call fprintf (IE_LOGFD(ie), " ") if (IE_YFORMAT(ie) == '%') call fprintf (IE_LOGFD(ie), IE_YFORMAT(ie)) else call fprintf (IE_LOGFD(ie), "%7g") call pargr (wy) call fprintf (IE_LOGFD(ie), " %7g") call pargr (Memr[data]) if (IE_XORIGIN(ie) != 0. || IE_YORIGIN(ie) != 0.) { dx = wx - xo dy = wy - yo r = sqrt (dx * dx + dy * dy) t = mod (360. + RADTODEG (atan2 (dy, dx)), 360.) call fprintf (IE_LOGFD(ie), " %7g %7g %7g %7g %7g %5.1f") call pargr (xo) call pargr (yo) call pargr (dx) call pargr (dy) call pargr (r) call pargr (t) } call fprintf (IE_LOGFD(ie), "\n") case 'y': # Set new origin call fprintf (IE_LOGFD(ie), "Origin: %7g %7g\n") call pargr (xo) call pargr (yo) } } end �������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ieprint.x������������������������������������������0000664�0000000�0000000�00000002525�13321663143�0022643�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "imexam.h" # IE_PRINT -- Print box of pixel values procedure ie_print (ie, x, y) pointer ie # IMEXAM structure real x, y # Center of box int i, j, x1, x2, y1, y2, nx pointer im, data, ie_gimage(), ie_gdata() begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } x1 = x - 5 + 0.5 x2 = x + 5 + 0.5 y1 = y - 5 + 0.5 y2 = y + 5 + 0.5 iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } nx = x2 - x1 + 1 call printf ("%4w") do i = x1, x2 { call printf (" %4d ") call pargi (i) } call printf ("\n") do j = y2, y1, -1 { call printf ("%4d") call pargi (j) do i = x1, x2 { call printf (" %5g") call pargr (Memr[data+(j-y1)*nx+(i-x1)]) } call printf ("\n") } if (IE_LOGFD(ie) != NULL) { call fprintf (IE_LOGFD(ie), "%4w") do i = x1, x2 { call fprintf (IE_LOGFD(ie), " %4d ") call pargi (i) } call fprintf (IE_LOGFD(ie), "\n") do j = y2, y1, -1 { call fprintf (IE_LOGFD(ie), "%4d") call pargi (j) do i = x1, x2 { call fprintf (IE_LOGFD(ie), " %5g") call pargr (Memr[data+(j-y1)*nx+(i-x1)]) } call fprintf (IE_LOGFD(ie), "\n") } } end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ieqrimexam.x���������������������������������������0000664�0000000�0000000�00000027357�13321663143�0023344�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include "imexam.h" include "mscexam.h" define FITTYPES "|gaussian|moffat|" define FITGAUSS 1 define FITMOFFAT 2 # IE_QRIMEXAM -- Radial profile plot and photometry parameters. # If no GIO pointer is given then only the photometry parameters are printed. # First find the center using the marginal distributions. Then subtract # a fit to the background. Compute the moments within the aperture and # fit a gaussian of fixed center and zero background. Make the plot # and print the photometry values. procedure ie_qrimexam (gp, mode, ie, x, y) pointer gp pointer ie int mode real x, y bool center, background, medsky, fitplot, clgpsetb() real radius, buffer, width, magzero, rplot, beta, clgpsetr() int fittype, xorder, yorder, clgpseti(), strdic() int i, j, ns, no, np, nx, ny, npts, x1, x2, y1, y2 int plist[3], nplist real bkg, xcntr, ycntr, mag, e, pa, zcntr, wxcntr, wycntr real params[3] real fwhm, dfwhm pointer sp, fittypes, title, coords, im, data, pp, ws, xs, ys, zs, gs, ptr, nl double sumo, sums, sumxx, sumyy, sumxy real r, r1, r2, r3, dx, dy, gseval(), amedr() pointer clopset(), ie_gimage(), ie_gdata(), locpr() extern ie_gauss(), ie_dgauss(), ie_moffat(), ie_dmoffat() errchk nlinit, nlfit string glabel "#\ COL LINE RMAG FLUX SKY N RMOM ELLIP PA PEAK GFWHM\n" string mlabel "#\ COL LINE RMAG FLUX SKY N RMOM ELLIP PA PEAK MFWHM\n" begin call smark (sp) call salloc (fittypes, SZ_FNAME, TY_CHAR) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (coords, IE_SZTITLE, TY_CHAR) iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) call sfree (sp) return } # Open parameter set. if (gp != NULL) { if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) } pp = clopset ("rimexam2") center = clgpsetb (pp, "center") background = clgpsetb (pp, "background") radius = clgpsetr (pp, "radius") buffer = clgpsetr (pp, "buffer") width = clgpsetr (pp, "width") xorder = clgpseti (pp, "xorder") yorder = clgpseti (pp, "yorder") medsky = (xorder <= 0 || yorder <= 0) magzero = clgpsetr (pp, "magzero") rplot = clgpsetr (pp, "rplot") fitplot = clgpsetb (pp, "fitplot") call clgpseta (pp, "fittype", Memc[fittypes], SZ_FNAME) fittype = strdic (Memc[fittypes], Memc[fittypes], SZ_FNAME, FITTYPES) if (fittype == 0) { call eprintf ("WARNING: Unknown profile fit type `%s'.\n") call pargstr (Memc[fittypes]) call sfree (sp) return } beta = clgpsetr (pp, "beta") # If the initial center is INDEF then use the previous value. if (gp != NULL) { if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y xcntr = IE_X1(ie) ycntr = IE_Y1(ie) } else { xcntr = x ycntr = y } # Center if (center) iferr (call ie_center (im, radius, xcntr, ycntr)) { call erract (EA_WARN) return } # Crude estimage of FHWM. dfwhm = radius # Get data including a buffer and background annulus. if (!background) { buffer = 0. width = 0. } r = max (rplot, radius + buffer + width) x1 = xcntr - r x2 = xcntr + r y1 = ycntr - r y2 = ycntr + r iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) call sfree (sp) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny call salloc (xs, npts, TY_REAL) call salloc (ys, npts, TY_REAL) call salloc (ws, npts, TY_REAL) # Extract the background data if background subtracting. ns = 0 if (background && width > 0.) { call salloc (zs, npts, TY_REAL) r1 = radius ** 2 r2 = (radius + buffer) ** 2 r3 = (radius + buffer + width) ** 2 ptr = data do j = y1, y2 { dy = (ycntr - j) ** 2 do i = x1, x2 { r = (xcntr - i) ** 2 + dy if (r <= r1) ; else if (r >= r2 && r <= r3) { Memr[xs+ns] = i Memr[ys+ns] = j Memr[zs+ns] = Memr[ptr] ns = ns + 1 } ptr = ptr + 1 } } } # Accumulate the various sums for the moments and the gaussian fit. no = 0 np = 0 zcntr = 0. sumo = 0.; sums = 0.; sumxx = 0.; sumyy = 0.; sumxy = 0. ptr = data gs = NULL if (ns > 0) { # Background subtraction # If background points are defined fit a surface and subtract # the fitted background from within the object aperture. if (medsky) bkg = amedr (Memr[zs], ns) else { repeat { call gsinit (gs, GS_POLYNOMIAL, xorder, yorder, YES, real (x1), real (x2), real (y1), real (y2)) call gsfit (gs, Memr[xs], Memr[ys], Memr[zs], Memr[ws], ns, WTS_UNIFORM, i) if (i == OK) break xorder = max (1, xorder - 1) yorder = max (1, yorder - 1) call gsfree (gs) } bkg = gseval (gs, real(x1), real(y1)) } do j = y1, y2 { dy = j - ycntr do i = x1, x2 { dx = i - xcntr r = sqrt (dx ** 2 + dy ** 2) r3 = max (0., min (5., 2 * r / dfwhm - 1.)) if (medsky) r2 = bkg else { r2 = gseval (gs, real(i), real(j)) bkg = min (bkg, r2) } r1 = Memr[ptr] - r2 if (r <= radius) { sumo = sumo + r1 sums = sums + r2 sumxx = sumxx + dx * dx * r1 sumyy = sumyy + dy * dy * r1 sumxy = sumxy + dx * dy * r1 zcntr = max (r1, zcntr) if (r <= rplot) { Memr[xs+no] = r Memr[ys+no] = r1 Memr[ws+no] = exp (-r3**2) / max (.1, r**2) no = no + 1 } else { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) } } else if (r <= rplot) { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 } ptr = ptr + 1 } } if (gs != NULL) call gsfree (gs) } else { # No background subtraction bkg = 0. do j = y1, y2 { dy = j - ycntr do i = x1, x2 { dx = i - xcntr r = sqrt (dx ** 2 + dy ** 2) r3 = max (0., min (5., 2 * r / dfwhm - 1.)) r1 = Memr[ptr] if (r <= radius) { sumo = sumo + r1 sumxx = sumxx + dx * dx * r1 sumyy = sumyy + dy * dy * r1 sumxy = sumxy + dx * dy * r1 zcntr = max (r1, zcntr) if (r <= rplot) { Memr[xs+no] = r Memr[ys+no] = r1 Memr[ws+no] = exp (-r3**2) / max (.1, r**2) no = no + 1 } else { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) } } else if (r <= rplot) { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 } ptr = ptr + 1 } } } if (np > 0) { call amovr (Memr[xs+npts-np], Memr[xs+no], np) call amovr (Memr[ys+npts-np], Memr[ys+no], np) call amovr (Memr[ws+npts-np], Memr[ws+no], np) } if (rplot <= radius) { no = no + np np = no - np } else np = no + np # Compute the photometry and gaussian fit parameters. switch (fittype) { case FITGAUSS: plist[1] = 1 plist[2] = 2 nplist = 2 params[2] = dfwhm**2 / (8 * log(2.)) params[1] = zcntr call nlinitr (nl, locpr (ie_gauss), locpr (ie_dgauss), params, params, 2, plist, nplist, .001, 100) call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) if (i == SINGULAR || i == NO_DEG_FREEDOM) { call eprintf ("WARNING: Gaussian fit did not converge\n") call tsleep (5) zcntr = INDEF fwhm = INDEF } else { call nlpgetr (nl, params, i) if (params[2] < 0.) { zcntr = INDEF fwhm = INDEF } else { zcntr = params[1] fwhm = sqrt (8 * log (2.) * params[2]) } } case FITMOFFAT: plist[1] = 1 plist[2] = 2 if (IS_INDEF(beta)) { params[3] = -3.0 plist[3] = 3 nplist = 3 } else { params[3] = -beta nplist = 2 } params[2] = dfwhm / 2. / sqrt (2.**(-1./params[3]) - 1.) params[1] = zcntr call nlinitr (nl, locpr (ie_moffat), locpr (ie_dmoffat), params, params, 3, plist, nplist, .001, 100) call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) if (i == SINGULAR || i == NO_DEG_FREEDOM) { call eprintf ("WARNING: Moffat fit did not converge\n") call tsleep (5) zcntr = INDEF fwhm = INDEF beta = INDEF } else { call nlpgetr (nl, params, i) if (params[2] < 0.) { zcntr = INDEF fwhm = INDEF beta = INDEF } else { zcntr = params[1] beta = -params[3] fwhm = abs (params[2])*2.*sqrt (2.**(-1./params[3]) - 1.) } } } mag = INDEF r = INDEF e = INDEF pa = INDEF if (sumo > 0.) { mag = magzero - 2.5 * log10 (sumo) r2 = sumxx + sumyy if (r2 > 0.) { switch (fittype) { case FITGAUSS: r = 2 * sqrt (log (2.) * r2 / sumo) case FITMOFFAT: if (beta > 2.) r = 2 * sqrt ((beta-2.)*(2.**(1./beta)-1) * r2 / sumo) } r1 =(sumxx-sumyy)**2+(2*sumxy)**2 if (r1 > 0.) e = sqrt (r1) / r2 else e = 0. } if (e < 0.01) e = 0. else pa = RADTODEG (0.5 * atan2 (2*sumxy, sumxx-sumyy)) } call ie_mwctran (ie, xcntr, ycntr, wxcntr, wycntr) if (xcntr == wxcntr && ycntr == wycntr) call strcpy ("%.2f %.2f", Memc[title], IE_SZTITLE) else { call sprintf (Memc[title], IE_SZTITLE, "%s %s") if (IE_XFORMAT(ie) == '%') call pargstr (IE_XFORMAT(ie)) else call pargstr ("%g") if (IE_YFORMAT(ie) == '%') call pargstr (IE_YFORMAT(ie)) else call pargstr ("%g") } call sprintf (Memc[coords], IE_SZTITLE, Memc[title]) call pargr (wxcntr) call pargr (wycntr) # Plot the radial profile and overplot the fit. if (gp != NULL) { call sprintf (Memc[title], IE_SZTITLE, "%s: Radial profile at %s\n%s") call pargstr (IE_IMAGE(ie)) call pargstr (Memc[coords]) call pargstr (IM_TITLE(im)) call ie_graph (gp, mode, pp, Memc[title], Memr[xs], Memr[ys], np, "", "") if (fitplot && !IS_INDEF (fwhm)) { np = 51 dx = rplot / (np - 1) do i = 0, np - 1 Memr[xs+i] = i * dx call nlvectorr (nl, Memr[xs], Memr[ys], np, 1) call gseti (gp, G_PLTYPE, 2) call gpline (gp, Memr[xs], Memr[ys], np) call gseti (gp, G_PLTYPE, 1) } } if (IE_LASTKEY(ie) != ',') { switch (fittype) { case FITGAUSS: call printf (glabel) case FITMOFFAT: call printf (mlabel) } } # Print the photometry values. call printf ( "%7.2f %7.2f %7.2f %8.1f %8.2f %3d %5.2f %5.3f %5.1f %8.2f %5.2f\n") call pargr (xcntr) call pargr (ycntr) call pargr (mag) call pargd (sumo) call pargd (sums / no) call pargi (no) call pargr (r) call pargr (e) call pargr (pa) call pargr (zcntr) call pargr (fwhm) if (gp == NULL) { if (xcntr != wxcntr || ycntr != wycntr) { call printf ("%s: %s\n") call pargstr (IE_WCSNAME(ie)) call pargstr (Memc[coords]) } } if (IE_LOGFD(ie) != NULL) { if (IE_LASTKEY(ie) != ',') { switch (fittype) { case FITGAUSS: call fprintf (IE_LOGFD(ie), glabel) case FITMOFFAT: call fprintf (IE_LOGFD(ie), mlabel) } } call fprintf (IE_LOGFD(ie), "%7.2f %7.2f %7.2f %8.1f %8.2f %3d %5.2f %5.3f %5.1f %8.2f %5.2f\n") call pargr (xcntr) call pargr (ycntr) call pargr (mag) call pargd (sumo) call pargd (sums / no) call pargi (no) call pargr (r) call pargr (e) call pargr (pa) call pargr (zcntr) call pargr (fwhm) if (xcntr != wxcntr || ycntr != wycntr) { call fprintf (IE_LOGFD(ie), "%s: %s\n") call pargstr (IE_WCSNAME(ie)) call pargstr (Memc[coords]) } } if (gp == NULL) call clcpset (pp) else IE_PP(ie) = pp call nlfreer (nl) call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ierimexam.x����������������������������������������0000664�0000000�0000000�00000043606�13321663143�0023156�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include "imexam.h" include "mscexam.h" define FITTYPES "|gaussian|moffat|" define FITGAUSS 1 define FITMOFFAT 2 # IE_RIMEXAM -- Radial profile plot and photometry parameters. # If no GIO pointer is given then only the photometry parameters are printed. # First find the center using the marginal distributions. Then subtract # a fit to the background. Compute the moments within the aperture and # fit a gaussian of fixed center and zero background. Make the plot # and print the photometry values. procedure ie_rimexam (gp, mode, ie, x, y) pointer gp pointer ie int mode real x, y bool center, background, medsky, fitplot, clgpsetb() real radius, buffer, width, magzero, rplot, beta, clgpsetr() int nit, fittype, xorder, yorder, clgpseti(), strdic() int i, j, ns, no, np, nx, ny, npts, x1, x2, y1, y2 int coordlen, plist[3], nplist, strlen() real bkg, xcntr, ycntr, mag, e, pa, zcntr, wxcntr, wycntr real params[3] real fwhm, dbkg, dfwhm, gfwhm, efwhm pointer sp, fittypes, title, coords, im, data, pp, ws, xs, ys, zs, gs, ptr, nl double sumo, sums, sumxx, sumyy, sumxy real r, r1, r2, r3, dx, dy, gseval(), amedr() pointer clopset(), ie_gimage(), ie_gdata(), locpr() extern ie_gauss(), ie_dgauss(), ie_moffat(), ie_dmoffat() errchk stf_measure, nlinit, nlfit begin call smark (sp) call salloc (fittypes, SZ_FNAME, TY_CHAR) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (coords, IE_SZTITLE, TY_CHAR) iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) call sfree (sp) return } # Open parameter set. if (gp != NULL) { if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) } pp = clopset ("rimexam2") center = clgpsetb (pp, "center") background = clgpsetb (pp, "background") radius = clgpsetr (pp, "radius") buffer = clgpsetr (pp, "buffer") width = clgpsetr (pp, "width") xorder = clgpseti (pp, "xorder") yorder = clgpseti (pp, "yorder") medsky = (xorder <= 0 || yorder <= 0) nit = clgpseti (pp, "iterations") magzero = clgpsetr (pp, "magzero") rplot = clgpsetr (pp, "rplot") fitplot = clgpsetb (pp, "fitplot") call clgpseta (pp, "fittype", Memc[fittypes], SZ_FNAME) fittype = strdic (Memc[fittypes], Memc[fittypes], SZ_FNAME, FITTYPES) if (fittype == 0) { call eprintf ("WARNING: Unknown profile fit type `%s'.\n") call pargstr (Memc[fittypes]) call sfree (sp) return } beta = clgpsetr (pp, "beta") # If the initial center is INDEF then use the previous value. if (gp != NULL) { if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y xcntr = IE_X1(ie) ycntr = IE_Y1(ie) } else { xcntr = x ycntr = y } # Center if (center) iferr (call ie_center (im, radius, xcntr, ycntr)) { call erract (EA_WARN) call sfree (sp) return } # Do the enclosed flux and direct FWHM measurments using the # PSFMEASURE routines. call stf_measure (im, xcntr, ycntr, beta, 0.5, radius, nit, buffer, width, INDEF, NULL, NULL, dbkg, r, dfwhm, gfwhm, efwhm) if (fittype == FITGAUSS) efwhm = gfwhm # Get data including a buffer and background annulus. if (!background) { buffer = 0. width = 0. } r = max (rplot, radius + buffer + width) x1 = xcntr - r x2 = xcntr + r y1 = ycntr - r y2 = ycntr + r iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) call sfree (sp) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny call salloc (xs, npts, TY_REAL) call salloc (ys, npts, TY_REAL) call salloc (ws, npts, TY_REAL) # Extract the background data if background subtracting. ns = 0 if (background && width > 0.) { call salloc (zs, npts, TY_REAL) r1 = radius ** 2 r2 = (radius + buffer) ** 2 r3 = (radius + buffer + width) ** 2 ptr = data do j = y1, y2 { dy = (ycntr - j) ** 2 do i = x1, x2 { r = (xcntr - i) ** 2 + dy if (r <= r1) ; else if (r >= r2 && r <= r3) { Memr[xs+ns] = i Memr[ys+ns] = j Memr[zs+ns] = Memr[ptr] ns = ns + 1 } ptr = ptr + 1 } } } # Accumulate the various sums for the moments and the gaussian fit. no = 0 np = 0 zcntr = 0. sumo = 0.; sums = 0.; sumxx = 0.; sumyy = 0.; sumxy = 0. ptr = data gs = NULL if (ns > 0) { # Background subtraction # If background points are defined fit a surface and subtract # the fitted background from within the object aperture. if (medsky) bkg = amedr (Memr[zs], ns) else { repeat { call gsinit (gs, GS_POLYNOMIAL, xorder, yorder, YES, real (x1), real (x2), real (y1), real (y2)) call gsfit (gs, Memr[xs], Memr[ys], Memr[zs], Memr[ws], ns, WTS_UNIFORM, i) if (i == OK) break xorder = max (1, xorder - 1) yorder = max (1, yorder - 1) call gsfree (gs) } bkg = gseval (gs, real(x1), real(y1)) } do j = y1, y2 { dy = j - ycntr do i = x1, x2 { dx = i - xcntr r = sqrt (dx ** 2 + dy ** 2) r3 = max (0., min (5., 2 * r / dfwhm - 1.)) if (medsky) r2 = bkg else { r2 = gseval (gs, real(i), real(j)) bkg = min (bkg, r2) } r1 = Memr[ptr] - r2 if (r <= radius) { sumo = sumo + r1 sums = sums + r2 sumxx = sumxx + dx * dx * r1 sumyy = sumyy + dy * dy * r1 sumxy = sumxy + dx * dy * r1 zcntr = max (r1, zcntr) if (r <= rplot) { Memr[xs+no] = r Memr[ys+no] = r1 Memr[ws+no] = exp (-r3**2) / max (.1, r**2) no = no + 1 } else { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) } } else if (r <= rplot) { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 } ptr = ptr + 1 } } if (gs != NULL) call gsfree (gs) } else { # No background subtraction bkg = 0. do j = y1, y2 { dy = j - ycntr do i = x1, x2 { dx = i - xcntr r = sqrt (dx ** 2 + dy ** 2) r3 = max (0., min (5., 2 * r / dfwhm - 1.)) r1 = Memr[ptr] if (r <= radius) { sumo = sumo + r1 sumxx = sumxx + dx * dx * r1 sumyy = sumyy + dy * dy * r1 sumxy = sumxy + dx * dy * r1 zcntr = max (r1, zcntr) if (r <= rplot) { Memr[xs+no] = r Memr[ys+no] = r1 Memr[ws+no] = exp (-r3**2) / max (.1, r**2) no = no + 1 } else { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 Memr[ws+npts-np] = exp (-r3**2) / max (.1, r**2) } } else if (r <= rplot) { np = np + 1 Memr[xs+npts-np] = r Memr[ys+npts-np] = r1 } ptr = ptr + 1 } } } if (np > 0) { call amovr (Memr[xs+npts-np], Memr[xs+no], np) call amovr (Memr[ys+npts-np], Memr[ys+no], np) call amovr (Memr[ws+npts-np], Memr[ws+no], np) } if (rplot <= radius) { no = no + np np = no - np } else np = no + np # Compute the photometry and profile fit parameters. switch (fittype) { case FITGAUSS: plist[1] = 1 plist[2] = 2 nplist = 2 params[2] = dfwhm**2 / (8 * log(2.)) params[1] = zcntr call nlinitr (nl, locpr (ie_gauss), locpr (ie_dgauss), params, params, 2, plist, nplist, .001, 100) call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) if (i == SINGULAR || i == NO_DEG_FREEDOM) { call eprintf ("WARNING: Gaussian fit did not converge\n") call tsleep (5) zcntr = INDEF fwhm = INDEF } else { call nlpgetr (nl, params, i) if (params[2] < 0.) { zcntr = INDEF fwhm = INDEF } else { zcntr = params[1] fwhm = sqrt (8 * log (2.) * params[2]) } } case FITMOFFAT: plist[1] = 1 plist[2] = 2 if (IS_INDEF(beta)) { params[3] = -3.0 plist[3] = 3 nplist = 3 } else { params[3] = -beta nplist = 2 } params[2] = dfwhm / 2. / sqrt (2.**(-1./params[3]) - 1.) params[1] = zcntr call nlinitr (nl, locpr (ie_moffat), locpr (ie_dmoffat), params, params, 3, plist, nplist, .001, 100) call nlfitr (nl, Memr[xs], Memr[ys], Memr[ws], no, 1, WTS_USER, i) if (i == SINGULAR || i == NO_DEG_FREEDOM) { call eprintf ("WARNING: Moffat fit did not converge\n") call tsleep (5) zcntr = INDEF fwhm = INDEF beta = INDEF } else { call nlpgetr (nl, params, i) if (params[2] < 0.) { zcntr = INDEF fwhm = INDEF beta = INDEF } else { zcntr = params[1] beta = -params[3] fwhm = abs (params[2])*2.*sqrt (2.**(-1./params[3]) - 1.) } } } mag = INDEF r = INDEF e = INDEF pa = INDEF if (sumo > 0.) { mag = magzero - 2.5 * log10 (sumo) r2 = sumxx + sumyy if (r2 > 0.) { switch (fittype) { case FITGAUSS: r = 2 * sqrt (log (2.) * r2 / sumo) case FITMOFFAT: if (beta > 2.) r = 2 * sqrt ((beta-2.)*(2.**(1./beta)-1) * r2 / sumo) } r1 =(sumxx-sumyy)**2+(2*sumxy)**2 if (r1 > 0.) e = sqrt (r1) / r2 else e = 0. } if (e < 0.01) e = 0. else pa = RADTODEG (0.5 * atan2 (2*sumxy, sumxx-sumyy)) } call ie_mwctran (ie, xcntr, ycntr, wxcntr, wycntr) if (xcntr == wxcntr && ycntr == wycntr) call strcpy ("%.2f %.2f", Memc[title], IE_SZTITLE) else { call sprintf (Memc[title], IE_SZTITLE, "%s %s") if (IE_XFORMAT(ie) == '%') call pargstr (IE_XFORMAT(ie)) else call pargstr ("%g") if (IE_YFORMAT(ie) == '%') call pargstr (IE_YFORMAT(ie)) else call pargstr ("%g") } call sprintf (Memc[coords], IE_SZTITLE, Memc[title]) call pargr (wxcntr) call pargr (wycntr) # Plot the radial profile and overplot the gaussian fit. if (gp != NULL) { call sprintf (Memc[title], IE_SZTITLE, "%s: Radial profile at %s\n%s") call pargstr (IE_IMAGE(ie)) call pargstr (Memc[coords]) call pargstr (IM_TITLE(im)) call ie_graph (gp, mode, pp, Memc[title], Memr[xs], Memr[ys], np, "", "") if (fitplot && !IS_INDEF (fwhm)) { np = 51 dx = rplot / (np - 1) do i = 0, np - 1 Memr[xs+i] = i * dx call nlvectorr (nl, Memr[xs], Memr[ys], np, 1) call gseti (gp, G_PLTYPE, 2) call gpline (gp, Memr[xs], Memr[ys], np) call gseti (gp, G_PLTYPE, 1) } call gseti (gp, G_PLTYPE, 2) call printf ("%6.2f %6.2f %7.4g %7.4g %7.4g %4.2f %4d") call pargr (radius) call pargr (mag) call pargd (sumo) call pargd (sums / no) call pargr (zcntr) call pargr (e) call pargr (pa) switch (fittype) { case FITGAUSS: call printf (" %4w %8.2f %8.2f %6.2f\n") call pargr (efwhm) call pargr (fwhm) call pargr (dfwhm) case FITMOFFAT: call printf (" %4.2f %8.2f %8.2f %6.2f\n") call pargr (beta) call pargr (efwhm) call pargr (fwhm) call pargr (dfwhm) } } else { if (IE_LASTKEY(ie) != 'a') { coordlen = max (11, strlen (Memc[coords])) call printf ("# %5s %7s %-*s\n# %5s %6s %7s %7s %7s %4s %4s") call pargstr ("COL") call pargstr ("LINE") call pargi (coordlen) call pargstr ("COORDINATES") call pargstr ("R") call pargstr ("MAG") call pargstr ("FLUX") call pargstr ("SKY") call pargstr ("PEAK") call pargstr ("E") call pargstr ("PA") switch (fittype) { case FITGAUSS: call printf (" %4w %8s %8s %6s\n") call pargstr ("ENCLOSED") call pargstr ("GAUSSIAN") call pargstr ("DIRECT") case FITMOFFAT: call printf (" %4s %8s %8s %6s\n") call pargstr ("BETA") call pargstr ("ENCLOSED") call pargstr ("MOFFAT") call pargstr ("DIRECT") } } call printf ( "%7.2f %7.2f %-*s\n %6.2f %6.2f %7.4g %7.4g %7.4g %4.2f %4d") call pargr (xcntr) call pargr (ycntr) call pargi (coordlen) call pargstr (Memc[coords]) call pargr (radius) call pargr (mag) call pargd (sumo) call pargd (sums / no) call pargr (zcntr) call pargr (e) call pargr (pa) switch (fittype) { case FITGAUSS: call printf (" %4w %8.2f %8.2f %6.2f\n") call pargr (efwhm) call pargr (fwhm) call pargr (dfwhm) case FITMOFFAT: call printf (" %4.2f %8.2f %8.2f %6.2f\n") call pargr (beta) call pargr (efwhm) call pargr (fwhm) call pargr (dfwhm) } } if (IE_LOGFD(ie) != NULL) { if (IE_LASTKEY(ie) != 'a') { coordlen = max (11, strlen (Memc[coords])) call fprintf (IE_LOGFD(ie), "# %5s %7s %-*s %6s %6s %7s %7s %7s %4s %4s") call pargstr ("COL") call pargstr ("LINE") call pargi (coordlen) call pargstr ("COORDINATES") call pargstr ("R") call pargstr ("MAG") call pargstr ("FLUX") call pargstr ("SKY") call pargstr ("PEAK") call pargstr ("E") call pargstr ("PA") switch (fittype) { case FITGAUSS: call fprintf (IE_LOGFD(ie), " %4w %8s %8s %6s\n") call pargstr ("ENCLOSED") call pargstr ("GAUSSIAN") call pargstr ("DIRECT") case FITMOFFAT: call fprintf (IE_LOGFD(ie), " %4s %8s %8s %6s\n") call pargstr ("BETA") call pargstr ("ENCLOSED") call pargstr ("MOFFAT") call pargstr ("DIRECT") } } call fprintf (IE_LOGFD(ie), "%7.2f %7.2f %-*s %6.2f %6.2f %7.4g %7.4g %7.4g %4.2f %4d") call pargr (xcntr) call pargr (ycntr) call pargi (coordlen) call pargstr (Memc[coords]) call pargr (radius) call pargr (mag) call pargd (sumo) call pargd (sums / no) call pargr (zcntr) call pargr (e) call pargr (pa) switch (fittype) { case FITGAUSS: call fprintf (IE_LOGFD(ie), " %4w %8.2f %8.2f %6.2f\n") call pargr (efwhm) call pargr (fwhm) call pargr (dfwhm) case FITMOFFAT: call fprintf (IE_LOGFD(ie), " %4.2f %8.2f %8.2f %6.2f\n") call pargr (beta) call pargr (efwhm) call pargr (fwhm) call pargr (dfwhm) } } if (gp == NULL) call clcpset (pp) else IE_PP(ie) = pp call nlfreer (nl) call sfree (sp) end # IE_CENTER -- Find the center of gravity from the marginal distributions. procedure ie_center (im, radius, xcntr, ycntr) pointer im real radius real xcntr, ycntr int i, j, k, x1, x2, y1, y2, nx, ny, npts real xlast, ylast real mean, sum, sum1, sum2, sum3, asumr() pointer data, ptr, ie_gdata() errchk ie_gdata begin # Find the center of a star image given approximate coords. Uses # Mountain Photometry Code Algorithm as outlined in Stellar Magnitudes # from Digital Images. do k = 1, 3 { # Extract region around center xlast = xcntr ylast = ycntr x1 = xcntr - radius + 0.5 x2 = xcntr + radius + 0.5 y1 = ycntr - radius + 0.5 y2 = ycntr + radius + 0.5 data = ie_gdata (im, x1, x2, y1, y2) nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny # Find center of gravity for marginal distributions above mean. sum = asumr (Memr[data], npts) mean = sum / nx sum1 = 0. sum2 = 0. do i = x1, x2 { ptr = data + i - x1 sum3 = 0. do j = y1, y2 { sum3 = sum3 + Memr[ptr] ptr = ptr + nx } sum3 = sum3 - mean if (sum3 > 0.) { sum1 = sum1 + i * sum3 sum2 = sum2 + sum3 } } xcntr = sum1 / sum2 ptr = data mean = sum / ny sum1 = 0. sum2 = 0. do j = y1, y2 { sum3 = 0. do i = x1, x2 { sum3 = sum3 + Memr[ptr] ptr = ptr + 1 } sum3 = sum3 - mean if (sum3 > 0.) { sum1 = sum1 + j * sum3 sum2 = sum2 + sum3 } } ycntr = sum1 / sum2 if (int(xcntr) == int(xlast) && int(ycntr) == int(ylast)) break } end # IE_GAUSS -- Gaussian function used in NLFIT. The parameters are the # amplitude and sigma squared and the input variable is the radius. procedure ie_gauss (x, nvars, p, np, z) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector int np #I Number of parameters real z #O Function return real r2 begin r2 = x[1]**2 / (2 * p[2]) if (abs (r2) > 20.) z = 0. else z = p[1] * exp (-r2) end # IE_DGAUSS -- Gaussian function and derivatives used in NLFIT. The parameters # are the amplitude and sigma squared and the input variable is the radius. procedure ie_dgauss (x, nvars, p, dp, np, z, der) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector real dp[np] #I Dummy array of parameters increments int np #I Number of parameters real z #O Function return real der[np] #O Derivatives real r2 begin r2 = x[1]**2 / (2 * p[2]) if (abs (r2) > 20.) { z = 0. der[1] = 0. der[2] = 0. } else { der[1] = exp (-r2) z = p[1] * der[1] der[2] = z * r2 / p[2] } end # IE_MOFFAT -- Moffat function used in NLFIT. The parameters are the # amplitude, alpha squared, and beta and the input variable is the radius. procedure ie_moffat (x, nvars, p, np, z) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector int np #I Number of parameters real z #O Function return real y begin y = 1 + (x[1] / p[2]) ** 2 if (abs (y) > 20.) z = 0. else z = p[1] * y ** p[3] end # IE_DMOFFAT -- Moffat function and derivatives used in NLFIT. The parameters # are the amplitude, alpha squared, and beta and the input variable is the # radius. procedure ie_dmoffat (x, nvars, p, dp, np, z, der) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector real dp[np] #I Dummy array of parameters increments int np #I Number of parameters real z #O Function return real der[np] #O Derivatives real y begin y = 1 + (x[1] / p[2]) ** 2 if (abs (y) > 20.) { z = 0. der[1] = 0. der[2] = 0. der[3] = 0. } else { der[1] = y ** p[3] z = p[1] * der[1] der[2] = -2 * z / y * p[3] / p[2] * (x[1] / p[2]) ** 2 der[3] = z * log (y) } end ��������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iesimexam.x����������������������������������������0000664�0000000�0000000�00000031466�13321663143�0023160�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include "imexam.h" include "mscexam.h" define CSIZE 24 # IE_SIMEXAM -- Draw a perspective view of a surface. The altitude # and azimuth of the viewing angle are variable. procedure ie_simexam (gp, mode, ie, x, y) pointer gp # GIO pointer int mode # Mode pointer ie # IMEXAM pointer real x, y # Center real angh, angv # Orientation of surface (degrees) real floor, ceiling # Range limits int wkid int x1, x2, y1, y2, nx, ny, npts pointer pp, sp, title, str, sdata, work, im, data, ie_gimage(), ie_gdata() bool clgpsetb() int clgpseti() real clgpsetr() pointer clopset() int first real vpx1, vpx2, vpy1, vpy2 common /frstfg/ first common /noaovp/ vpx1, vpx2, vpy1, vpy2 begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } pp = IE_PP(ie) if (pp != NULL) call clcpset (pp) pp = clopset ("simexam2") IE_PP(ie) = pp nx = clgpseti (pp, "ncolumns") ny = clgpseti (pp, "nlines") angh = clgpsetr (pp, "angh") angv = clgpsetr (pp, "angv") floor = clgpsetr (pp, "floor") ceiling = clgpsetr (pp, "ceiling") if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 x2 = IE_X1(ie) + nx / 2 + 0.5 y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 y2 = IE_Y1(ie) + ny / 2 + 0.5 iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny call smark (sp) # Take floor and ceiling if enabled (nonzero). if (IS_INDEF (floor) && IS_INDEF (ceiling)) sdata = data else { call salloc (sdata, npts, TY_REAL) call amovr (Memr[data], Memr[sdata], npts) if (!IS_INDEF (floor) && !IS_INDEF (ceiling)) { floor = min (floor, ceiling) ceiling = max (floor, ceiling) } } iferr (call ie_surf_limits (Memr[sdata], npts, floor, ceiling)) { call sfree (sp) call erract (EA_WARN) return } if (mode != APPEND) { call gclear (gp) # Set the viewport. call gsview (gp, 0.1, 0.9, 0.1, 0.9) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) if (clgpsetb (pp, "banner")) { call sysid (Memc[str], SZ_LINE) call sprintf (Memc[title], IE_SZTITLE, "%s\n%s: Surface plot of [%d:%d,%d:%d]\n%s") call pargstr (Memc[str]) call pargstr (IE_IMAGE(ie)) call pargi (x1) call pargi (x2) call pargi (y1) call pargi (y2) call pargstr (IM_TITLE(im)) } else Memc[title] = EOS call clgpset (pp, "title", Memc[str], SZ_LINE) if (Memc[str] != EOS) { call strcat ("\n", Memc[title], IE_SZTITLE) call strcat (Memc[str], Memc[title], IE_SZTITLE) } call gseti (gp, G_DRAWAXES, NO) call glabax (gp, Memc[title], "", "") } # Open graphics device and make plot. call gopks (STDERR) wkid = 1 call gopwk (wkid, 6, gp) call gacwk (wkid) first = 1 call srfabd() call ggview (gp, vpx1, vpx2, vpy1, vpy2) call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) call salloc (work, 2*(2*nx*ny+nx+ny), TY_REAL) call ezsrfc (Memr[sdata], nx, ny, angh, angv, Memr[work]) if (mode != APPEND) { if (clgpsetb (pp, "axes")) { call gswind (gp, real (x1), real (x2), real (y1), real (y2)) call gseti (gp, G_CLIP, NO) call ie_perimeter (gp, Memr[sdata], nx, ny, angh, angv) } } call gdawk (wkid) call gclks () call sfree (sp) end # IE_PERIMETER -- draw and label axes around the surface plot. procedure ie_perimeter (gp, z, ncols, nlines, angh, angv) pointer gp # Graphics pointer int ncols # Number of image columns int nlines # Number of image lines real z[ncols, nlines] # Array of intensity values real angh # Angle of horizontal inclination real angv # Angle of vertical inclination pointer sp, x_val, y_val, kvec char tlabel[10] real xmin, ymin, delta, fact1, flo, hi, xcen, ycen real x1_perim, x2_perim, y1_perim, y2_perim, z1, z2 real wc1, wc2, wl1, wl2, del int i, j, junk int itoc() data fact1 /2.0/ real vpx1, vpx2, vpy1, vpy2 common /noaovp/ vpx1, vpx2, vpy1, vpy2 begin call smark (sp) call salloc (x_val, ncols + 2, TY_REAL) call salloc (y_val, nlines + 2, TY_REAL) call salloc (kvec, max (ncols, nlines) + 2, TY_REAL) # Get window coordinates set up in calling procedure. call ggwind (gp, wc1, wc2, wl1, wl2) # Set up window, viewport for output. The coordinates returned # from trn32s are in the range [1-1024]. call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1) # Find range of z for determining perspective flo = MAX_REAL hi = -flo do j = 1, nlines { call alimr (z[1,j], ncols, z1, z2) flo = min (flo, z1) hi = max (hi, z2) } # Set up linear endpoints and spacing as used in surface. delta = (hi-flo) / (max (ncols,nlines) -1.) * fact1 xmin = -(real (ncols/2) * delta + real (mod (ncols+1, 2)) * delta) ymin = -(real (nlines/2) * delta + real (mod (nlines+1, 2)) * delta) del = 2.0 * delta # The perimeter is separated from the surface plot by the # width of delta. x1_perim = xmin - delta y1_perim = ymin - delta x2_perim = xmin + (real (ncols) * delta) y2_perim = ymin + (real (nlines) * delta) # Set up linear arrays over full perimeter range do i = 1, ncols + 2 Memr[x_val+i-1] = x1_perim + (i-1) * delta do i = 1, nlines + 2 Memr[y_val+i-1] = y1_perim + (i-1) * delta # Draw and label axes and tick marks. # It is important that frame has not been called after calling srface. # First to draw the perimeter. Which axes get drawn depends on the # values of angh and angv. Get angles in the range [-180, 180]. if (angh > 180.) angh = angh - 360. else if (angh < -180.) angh = angh + 360. if (angv > 180.) angv = angv - 360. else if (angv < -180.) angv = angv + 360. # Calculate positions for the axis labels xcen = 0.5 * (x1_perim + x2_perim) ycen = 0.5 * (y1_perim + y2_perim) if (angh >= 0) { if (angv >= 0) { # Case 1: xy rotation positive, looking down from above mid Z # First draw x axis call amovkr (y2_perim, Memr[kvec], ncols + 2) call ie_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1) call ie_label_axis (xcen, y2_perim+del, flo, "X-AXIS", -1, -2) call ie_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta, flo, ncols) junk = itoc (int (wc1), tlabel, 10) call ie_label_axis (xmin, y2_perim+del, flo, tlabel, -1, -2) junk = itoc (int (wc2), tlabel, 10) call ie_label_axis (Memr[x_val+ncols], y2_perim+del, flo, tlabel, -1, -2) # Now draw y axis call amovkr (x2_perim, Memr[kvec], nlines + 2) call ie_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1) call ie_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1) call ie_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1], flo, nlines) junk = itoc (int (wl1), tlabel, 10) call ie_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1) junk = itoc (int (wl2), tlabel, 10) call ie_label_axis (x2_perim+del, Memr[y_val+nlines], flo, tlabel, 2, -1) } else { # Case 2: xy rotation positive, looking up from below mid Z # First draw x axis call amovkr (y1_perim, Memr[kvec], ncols + 2) call ie_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1) call ie_label_axis (xcen, y1_perim-del, flo, "X-AXIS", -1, 2) call ie_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta, flo, ncols) junk = itoc (int (wc1), tlabel, 10) call ie_label_axis (xmin, y1_perim-del, flo, tlabel, -1, 2) junk = itoc (int (wc2), tlabel, 10) call ie_label_axis (Memr[x_val+ncols], y1_perim-del, flo, tlabel, -1, 2) # Now draw y axis call amovkr (x1_perim, Memr[kvec], nlines + 2) call ie_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1) call ie_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1) call ie_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1], flo, nlines) junk = itoc (int (wl1), tlabel, 10) call ie_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1) junk = itoc (int (wl2), tlabel, 10) call ie_label_axis (x1_perim-del, Memr[y_val+nlines], flo, tlabel, 2, 1) } } if (angh < 0) { if (angv > 0) { # Case 3: xy rotation negative, looking down from above mid Z # (default). First draw x axis call amovkr (y1_perim, Memr[kvec], ncols + 2) call ie_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1) call ie_label_axis (xcen, y1_perim-del, flo, "X-AXIS", 1, 2) call ie_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta, flo, ncols) junk = itoc (int (wc1), tlabel, 10) call ie_label_axis (xmin, y1_perim-del, flo, tlabel, 1, 2) junk = itoc (int (wc2), tlabel, 10) call ie_label_axis (Memr[x_val+ncols], y1_perim-del, flo, tlabel, 1, 2) # Now draw y axis call amovkr (x2_perim, Memr[kvec], nlines + 2) call ie_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1) call ie_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1) call ie_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1], flo, nlines) junk = itoc (int (wl1), tlabel, 10) call ie_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1) junk = itoc (int (wl2), tlabel, 10) call ie_label_axis (x2_perim+del, Memr[y_val+nlines], flo, tlabel, 2, -1) } else { # Case 4: xy rotation negative, looking up from below mid Z # First draw x axis call amovkr (y2_perim, Memr[kvec], ncols + 2) call ie_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1) call ie_label_axis (xcen, y2_perim+del, flo, "X-AXIS", 1, -2) call ie_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta, flo, ncols) junk = itoc (int (wc1), tlabel, 10) call ie_label_axis (xmin, y2_perim+del, flo, tlabel, 1, -2) junk = itoc (int (wc2), tlabel, 10) call ie_label_axis (Memr[x_val+ncols], y2_perim+del, flo, tlabel, 1, -2) # Now draw y axis call amovkr (x1_perim, Memr[kvec], nlines + 2) call ie_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1) call ie_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1) call ie_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1], flo, nlines) junk = itoc (int (wl1), tlabel, 10) call ie_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1) junk = itoc (int (wl2), tlabel, 10) call ie_label_axis (x1_perim-del, Memr[y_val+nlines], flo, tlabel, 2, 1) } } # Flush plotit buffer before returning call plotit (0, 0, 2) call sfree (sp) end # ?? procedure ie_draw_axis (xvals, yvals, zval, nvals) int nvals real xvals[nvals] real yvals[nvals] real zval pointer sp, xt, yt int i real dum begin call smark (sp) call salloc (xt, nvals, TY_REAL) call salloc (yt, nvals, TY_REAL) do i = 1, nvals call trn32s (xvals[i], yvals[i], zval, Memr[xt+i-1], Memr[yt+i-1], dum, 1) call gpl (nvals, Memr[xt], Memr[yt]) call sfree (sp) end # ?? procedure ie_label_axis (xval, yval, zval, sppstr, path, up) real xval real yval real zval char sppstr[SZ_LINE] int path int up int nchars int strlen() % character*64 fstr begin nchars = strlen (sppstr) % call f77pak (sppstr, fstr, 64) call pwrzs (xval, yval, zval, fstr, nchars, CSIZE, path, up, 0) end # ?? procedure ie_draw_ticksx (x, y1, y2, zval, nvals) int nvals real x[nvals] real y1, y2 real zval int i real tkx[2], tky[2], dum begin do i = 1, nvals { call trn32s (x[i], y1, zval, tkx[1], tky[1], dum, 1) call trn32s (x[i], y2, zval, tkx[2], tky[2], dum, 1) call gpl (2, tkx[1], tky[1]) } end # ?? procedure ie_draw_ticksy (x1, x2, y, zval, nvals) int nvals real x1, x2 real y[nvals] real zval int i real tkx[2], tky[2], dum begin do i = 1, nvals { call trn32s (x1, y[i], zval, tkx[1], tky[1], dum, 1) call trn32s (x2, y[i], zval, tkx[2], tky[2], dum, 1) call gpl (2, tkx[1], tky[1]) } end # IE_SURF_LIMITS -- Apply the floor and ceiling constraints to the subraster. # If either value is exactly zero, it is not applied. procedure ie_surf_limits (ras, m, floor, ceiling) real ras[m] int m real floor, ceiling real val1_1 # value at ras[1] int k bool const_val # true if data are constant bool bad_floor # true if no value is above floor bool bad_ceiling # true if no value is below ceiling begin const_val = true # initial values bad_floor = true bad_ceiling = true val1_1 = ras[1] do k = 1, m if (ras[k] != val1_1) { const_val = false break } if (!IS_INDEF(floor)) { do k = 1, m { if (ras[k] <= floor) ras[k] = floor else bad_floor = false } } if (!IS_INDEF(ceiling)) { do k = 1, m { if (ras[k] >= ceiling) ras[k] = ceiling else bad_ceiling = false } } if (bad_floor && !IS_INDEF(floor)) call error (1, "entire image is below (or at) specified floor") if (bad_ceiling && !IS_INDEF(ceiling)) call error (1, "entire image is above (or at) specified ceiling") if (const_val) call error (1, "all data values are the same; can't plot it") end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/iestatistics.x�������������������������������������0000664�0000000�0000000�00000004151�13321663143�0023676�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include "imexam.h" # IE_STATISTICS -- Compute and print statistics. procedure ie_statistics (ie, x, y) pointer ie # IMEXAM structure real x, y # Aperture coordinates double mean, median, std int ncstat, nlstat, x1, x2,y1, y2, npts, clgeti() pointer sp, imname, im, data, sortdata, ie_gimage(), ie_gdata() string label "\ # SECTION NPIX MEAN MEDIAN STDDEV MIN MAX\n" begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } ncstat = clgeti ("ncstat") nlstat = clgeti ("nlstat") x1 = x - (ncstat-1) / 2 + 0.5 x2 = x + ncstat / 2 + 0.5 y1 = y - (nlstat-1) / 2 + 0.5 y2 = y + nlstat / 2 + 0.5 iferr (data = ie_gdata (im, x1, x2, y1, y2)) { call erract (EA_WARN) return } npts = (x2-x1+1) * (y2-y1+1) call smark (sp) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (sortdata, npts, TY_DOUBLE) call achtrd (Memr[data], Memd[sortdata], npts) call asrtd (Memd[sortdata], Memd[sortdata], npts) call aavgd (Memd[sortdata], npts, mean, std) if (mod (npts, 2) == 0) median = (Memd[sortdata+npts/2-1] + Memd[sortdata+npts/2]) / 2 else median = Memd[sortdata+npts/2] call sprintf (Memc[imname], SZ_FNAME, "[%d:%d,%d:%d]") call pargi (x1) call pargi (x2) call pargi (y1) call pargi (y2) if (IE_LASTKEY(ie) != 'm') call printf (label) call printf ("%20s %8d %8.4g %8.4g %8.4g %8.4g %8.4g\n") call pargstr (Memc[imname]) call pargi (npts) call pargd (mean) call pargd (median) call pargd (std) call pargd (Memd[sortdata]) call pargd (Memd[sortdata+npts-1]) if (IE_LOGFD(ie) != NULL) { if (IE_LASTKEY(ie) != 'm') call fprintf (IE_LOGFD(ie), label) call fprintf (IE_LOGFD(ie), "%20s %8d %8.4g %8.4g %8.4g %8.4g %8.4g\n") call pargstr (Memc[imname]) call pargi (npts) call pargd (mean) call pargd (median) call pargd (std) call pargd (Memd[sortdata]) call pargd (Memd[sortdata+npts-1]) } call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ietimexam.x����������������������������������������0000664�0000000�0000000�00000005332�13321663143�0023152�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "imexam.h" include "../mosim.h" # IE_TIMEXAM -- Extract a subraster image. # This routine does not currently update the WCS but it does clear it. procedure ie_timexam (ie, x, y) pointer ie # IE pointer real x, y # Center int i, x1, x2, y1, y2, nx, ny pointer sp, root, extn, output pointer im, out, data, outbuf, mw int clgeti(), fnextn(), iki_validextn(), strlen(), imaccess() pointer ie_gimage(), ie_gdata(), immap(), impl2r(), mw_open() errchk impl2r begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } call smark (sp) call salloc (root, SZ_FNAME, TY_CHAR) call salloc (extn, SZ_FNAME, TY_CHAR) call salloc (output, SZ_FNAME, TY_CHAR) # Get parameters. call clgstr ("output", Memc[root], SZ_FNAME) nx = clgeti ("ncoutput") ny = clgeti ("nloutput") # Strip the extension. call imgimage (Memc[root], Memc[root], SZ_FNAME) if (Memc[root] == EOS) call strcpy (IE_IMAGE(ie), Memc[root], SZ_FNAME) i = fnextn (Memc[root], Memc[extn+1], SZ_FNAME) Memc[extn] = EOS if (i > 0) { call iki_init() if (iki_validextn (0, Memc[extn+1]) != 0) { Memc[root+strlen(Memc[root])-i-1] = EOS Memc[extn] = '.' } } do i = 1, ARB { call sprintf (Memc[output], SZ_FNAME, "%s.%03d%s") call pargstr (Memc[root]) call pargi (i) call pargstr (Memc[extn]) if (imaccess (Memc[output], 0) == NO) break } # Set section to be extracted. if (!IS_INDEF(x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y x1 = IE_X1(ie) - (nx - 1) / 2 + 0.5 x2 = IE_X1(ie) + nx / 2 + 0.5 y1 = IE_Y1(ie) - (ny - 1) / 2 + 0.5 y2 = IE_Y1(ie) + ny / 2 + 0.5 nx = x2 - x1 + 1 ny = y2 - y1 + 1 # Set output. iferr (out = immap (Memc[output], NEW_COPY, MI_IM(im,1))) { call erract (EA_WARN) return } IM_NDIM(out) = 2 IM_LEN(out,1) = nx IM_LEN(out,2) = ny # Extract the section. iferr { do i = y1, y2 { data = ie_gdata (im, x1, x2, i, i) outbuf = impl2r (out, i-y1+1) call amovr (Memr[data], Memr[outbuf], nx) } mw = mw_open (NULL, 2) call mw_saveim (mw, out) call imunmap (out) } then { call imunmap (out) iferr (call imdelete (Memc[output])) ; call sfree (sp) call erract (EA_WARN) return } call printf ("%s[%d:%d,%d:%d] -> %s\n") call pargstr (IE_IMAGE(ie)) call pargi (x1) call pargi (x2) call pargi (y1) call pargi (y2) call pargstr (Memc[output]) if (IE_LOGFD(ie) != NULL) { call fprintf (IE_LOGFD(ie), "%s[%d:%d,%d:%d] -> %s\n") call pargstr (IE_IMAGE(ie)) call pargi (x1) call pargi (x2) call pargi (y1) call pargi (y2) } call sfree (sp) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/ievimexam.x����������������������������������������0000664�0000000�0000000�00000042152�13321663143�0023155�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include include include include include "imexam.h" include "mscexam.h" define BTYPES "|constant|nearest|reflect|wrap|project|" define SZ_BTYPE 8 # Length of boundary type string define NLINES 16 # Number of image lines in the buffer # IE_VIMEXAM -- Plot the vector of image data between two pixels. # There are two types of plot selected by the key argument. The # second cursor position is passed in the IMEXAM data structure. # The first position is either the middle of the vector or the starting # point. procedure ie_vimexam (gp, mode, ie, x, y, key) pointer gp # GIO pointer int mode # Graph mode pointer ie # IMEXAM pointer real x, y # Starting or center coordinate int key # 'u' centered vector, 'v' two endpoint vector int btype, nxvals, nyvals, nzvals, width pointer sp, title, boundary, im, x_vec, y_vec, pp real x1, y1, x2, y2, zmin, zmax, bconstant bool fp_equalr() int clgpseti(), clgwrd(), clopset() real clgpsetr() pointer ie_gimage() errchk malloc begin iferr (im = ie_gimage (ie, NO)) { call erract (EA_WARN) return } call smark (sp) call salloc (title, IE_SZTITLE, TY_CHAR) call salloc (boundary, SZ_BTYPE, TY_CHAR) # Get boundary extension parameters. if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) IE_PP(ie) = clopset ("vimexam2") pp = IE_PP(ie) btype = clgwrd ("vimexam2.boundary", Memc[boundary], SZ_BTYPE, BTYPES) bconstant = clgpsetr (pp, "constant") nxvals = IM_LEN(im,1) nyvals = IM_LEN(im,2) if (!IS_INDEF (x)) IE_X1(ie) = x if (!IS_INDEF(y)) IE_Y1(ie) = y x1 = IE_X1(ie) x2 = IE_X2(ie) y1 = IE_Y1(ie) y2 = IE_Y2(ie) width = clgpseti (pp, "naverage") # Check the boundary and compute the length of the output vector. x1 = max (1.0, min (x1, real (nxvals))) x2 = min (real(nxvals), max (1.0, x2)) y1 = max (1.0, min (y1, real (nyvals))) y2 = min (real(nyvals), max (1.0, y2)) nzvals = int (sqrt ((x2 - x1) * (x2 - x1) + (y2 - y1) * (y2 - y1))) + 1 # Check for cases which should be handled by pcols or prows. call malloc (x_vec, nzvals, TY_REAL) call malloc (y_vec, nzvals, TY_REAL) if (fp_equalr (x1, x2)) call ie_get_col (im, x1, y1, x2, y2, nzvals, width, btype, bconstant, Memr[x_vec], Memr[y_vec], zmin, zmax) else if (fp_equalr (y1, y2)) call ie_get_row (im, x1, y1, x2, y2, nzvals, width, btype, bconstant, Memr[x_vec], Memr[y_vec], zmin, zmax) else call ie_get_vector (im, x1, y1, x2, y2, nzvals, width, btype, bconstant, Memr[x_vec], Memr[y_vec], zmin, zmax) # Convert endpoint plot coordinates to centered coordinates. if (key == 'u') { zmin = (IE_X1(ie) + IE_X2(ie)) / 2 zmax = (IE_Y1(ie) + IE_Y2(ie)) / 2 zmin = sqrt ((zmin-x1)**2 + (zmax-y1)**2) call asubkr (Memr[x_vec], zmin, Memr[x_vec], nzvals) } call sprintf (Memc[title], IE_SZTITLE, "%s: Vector %.1f,%.1f to %.1f,%.1f naverage: %d\n%s") call pargstr (IE_IMAGE(ie)) call pargr (x1) call pargr (y1) call pargr (x2) call pargr (y2) call pargi (width) call pargstr (IM_TITLE(im)) call ie_graph (gp, mode, pp, Memc[title], Memr[x_vec], Memr[y_vec], nzvals, "", "") # Finish up call mfree (x_vec, TY_REAL) call mfree (y_vec, TY_REAL) call sfree (sp) end # IE_GET_VECTOR -- Average a strip perpendicular to a given vector and return # vectors of point number and average pixel value. Also returned is the min # and max value in the data vector. procedure ie_get_vector (im, x1, y1, x2, y2, nvals, width, btype, bconstant, x_vector, y_vector, zmin, zmax) pointer im # pointer to image header real x1, y1 # starting pixel of vector real x2, y2 # ending pixel of pixel real bconstant # Boundary extension constant int btype # Boundary extension type int nvals # number of samples along the vector int width # width of strip to average over real x_vector[ARB] # Pixel numbers real y_vector[ARB] # Average pixel values (returned) real zmin, zmax # min, max of data vector double dx, dy, dpx, dpy, ratio, xoff, yoff, noff, xv, yv int i, j, k, nedge, col1, col2, line1, line2 int colb, colc, line, linea, lineb, linec pointer sp, oxs, oys, xs, ys, yvals, msi, buf real sum , lim1, lim2, lim3, lim4 pointer imgs2r() errchk msiinit begin call smark (sp) call salloc (oxs, width, TY_REAL) call salloc (oys, width, TY_REAL) call salloc (xs, width, TY_REAL) call salloc (ys, width, TY_REAL) call salloc (yvals, width, TY_REAL) # Determine sampling perpendicular to vector. dx = (x2 - x1) / (nvals - 1) dy = (y2 - y1) / (nvals - 1) if (x1 < x2) { dpx = -dy dpy = dx } else { dpx = dy dpy = -dx } # Compute offset from the nominal vector to the first sample point. ratio = dx / dy nedge = width + 1 noff = (real (width) - 1.0) / 2.0 xoff = noff * dpx yoff = noff * dpy # Initialize the interpolator and the image data buffer. call msiinit (msi, II_BILINEAR] buf = NULL # # Set the boundary. # col1 = int (min (x1, x2)) - nedge # col2 = nint (max (x1, x2)) + nedge # line1 = int (min (y1, y2)) - nedge # line2 = nint (max (y2, y1)) + nedge # call ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) # We can't (easily) handle boundary extension. Clip ends of vector # instead. col1 = int (min (x1, x2)) col2 = nint (max (x1, x2)) line1 = int (min (y1, y2)) line2 = nint (max (y2, y1)) col1 = max (col1, CX1(MI_CMG(im))) col2 = min (col2, CX2(MI_CMG(im))) line1 = max (line1, CY1(MI_CMG(im))) line2 = min (line2, CY2(MI_CMG(im))) # Initialize. xv = x1 - xoff yv = y1 - yoff do j = 1, width { Memr[oxs+j-1] = double (j - 1) * dpx Memr[oys+j-1] = double (j - 1) * dpy } # Loop over the output image lines. do i = 1, nvals { x_vector[i] = real (i) line = yv # Get the input image data and fit an interpolator to the data. # The input data is buffered in a section of size NLINES + 2 * # NEDGE. if (dy >= 0.0 && (buf == NULL || line > (linea))) { linea = min (line2, line + NLINES - 1) lineb = max (line1, line - nedge) linec = min (line2, linea + nedge) lim1 = xv lim2 = lim1 + double (width - 1) * dpx lim3 = xv + double (linea - line + 1) * ratio lim4 = lim3 + double (width - 1) * dpx colb = max (col1, int (min (lim1, lim2, lim3, lim4)) - 1) colc = min (col2, nint (max (lim1, lim2, lim3, lim4)) + 1) buf = imgs2r (im, colb, colc, lineb, linec) call msifit (msi, Memr[buf], colc - colb + 1, linec - lineb + 1, colc - colb + 1) } else if (dy < 0.0 && (buf == NULL || line < linea)) { linea = max (line1, line - NLINES + 1) lineb = max (line1, linea - nedge) linec = min (line2, line + nedge) lim1 = xv lim2 = lim1 + double (width - 1) * dpx lim3 = xv + double (linea - line - 1) * ratio lim4 = lim3 + double (width - 1) * dpx colb = max (col1, int (min (lim1, lim2, lim3, lim4)) - 1) colc = min (col2, nint (max (lim1, lim2, lim3, lim4)) + 1) buf = imgs2r (im, colb, colc, lineb, linec) call msifit (msi, Memr[buf], colc - colb + 1, linec - lineb + 1, colc - colb + 1) } # Evaluate the interpolant. call aaddkr (Memr[oxs], real (xv - colb + 1), Memr[xs], width) call aaddkr (Memr[oys], real (yv - lineb + 1), Memr[ys], width) call msivector (msi, Memr[xs], Memr[ys], Memr[yvals], width) if (width == 1) y_vector[i] = Memr[yvals] else { sum = 0.0 do k = 1, width sum = sum + Memr[yvals+k-1] y_vector[i] = sum / width } xv = xv + dx yv = yv + dy } # Compute min and max values. call alimr (y_vector, nvals, zmin, zmax) # Free memory . call msifree (msi) call sfree (sp) end # IE_GET_COL -- Average a strip perpendicular to a column vector and return # vectors of point number and average pixel value. Also returned is the min # and max value in the data vector. procedure ie_get_col (im, x1, y1, x2, y2, nvals, width, btype, bconstant, x_vector, y_vector, zmin, zmax) pointer im # pointer to image header real x1, y1 # starting pixel of vector real x2, y2 # ending pixel of pixel int nvals # number of samples along the vector int width # width of strip to average over int btype # Boundary extension type real bconstant # Boundary extension constant real x_vector[ARB] # Pixel numbers real y_vector[ARB] # Average pixel values (returned) real zmin, zmax # min, max of data vector real sum int line, linea, lineb, linec pointer sp, xs, ys, msi, yvals, buf double dx, dy, xoff, noff, xv, yv int i, j, k, nedge, col1, col2, line1, line2 pointer imgs2r() errchk msiinit begin call smark (sp) call salloc (xs, width, TY_REAL) call salloc (ys, width, TY_REAL) call salloc (yvals, width, TY_REAL) # Initialize the interpolator and the image data buffer. call msiinit (msi, II_BILINEAR] buf = NULL # Set the boundary. nedge = max (2, width / 2 + 1) # col1 = int (x1) - nedge # col2 = nint (x1) + nedge # line1 = int (min (y1, y2)) - nedge # line2 = nint (max (y1, y2)) + nedge # call ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) # We can't (easily) handle boundary extension. Clip ends of vector # instead. col1 = int (min (x1, x2)) col2 = nint (max (x1, x2)) line1 = int (min (y1, y2)) line2 = nint (max (y2, y1)) col1 = max (col1, CX1(MI_CMG(im))) col2 = min (col2, CX2(MI_CMG(im))) line1 = max (line1, CY1(MI_CMG(im))) line2 = min (line2, CY2(MI_CMG(im))) # Determine sampling perpendicular to vector. dx = 1.0d0 if (nvals == 1) dy = 0.0d0 else dy = (y2 - y1) / (nvals - 1) # Compute offset from the nominal vector to the first sample point. noff = (real (width) - 1.0) / 2.0 xoff = noff * dx xv = x1 - xoff do j = 1, width Memr[xs+j-1] = xv + double (j - col1) yv = y1 # Loop over the output image lines. do i = 1, nvals { x_vector[i] = real (i) line = yv # Get the input image data and fit an interpolator to the data. # The input data is buffered in a section of size NLINES + 2 * # NEDGE. if (dy >= 0.0 && (buf == NULL || line > (linea))) { linea = min (line2, line + NLINES - 1) lineb = max (line1, line - nedge) linec = min (line2, linea + nedge) buf = imgs2r (im, col1, col2, lineb, linec) call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + 1, col2 - col1 + 1) } else if (dy < 0.0 && (buf == NULL || line < linea)) { linea = max (line1, line - NLINES + 1) lineb = max (line1, linea - nedge) linec = min (line2, line + nedge) buf = imgs2r (im, col1, col2, lineb, linec) call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + 1, col2 - col1 + 1) } # Evaluate the interpolant. call amovkr (real (yv - lineb + 1), Memr[ys], width) call msivector (msi, Memr[xs], Memr[ys], Memr[yvals], width) if (width == 1) y_vector[i] = Memr[yvals] else { sum = 0.0 do k = 1, width sum = sum + Memr[yvals+k-1] y_vector[i] = sum / width } yv = yv + dy } # Compute min and max values. call alimr (y_vector, nvals, zmin, zmax) # Free memory . call msifree (msi) call sfree (sp) end # IE_GET_ROW -- Average a strip parallel to a row vector and return # vectors of point number and average pixel value. Also returned is the min # and max value in the data vector. procedure ie_get_row (im, x1, y1, x2, y2, nvals, width, btype, bconstant, x_vector, y_vector, zmin, zmax) pointer im # pointer to image header real x1, y1 # starting pixel of vector real x2, y2 # ending pixel of pixel int nvals # number of samples along the vector int width # width of strip to average over int btype # Boundary extension type real bconstant # Boundary extension constant real x_vector[ARB] # Pixel numbers real y_vector[ARB] # Average pixel values (returned) real zmin, zmax # min, max of data vector double dx, dy, yoff, noff, xv, yv int i, j, nedge, col1, col2, line1, line2 int line, linea, lineb, linec pointer sp, oys, xs, ys, yvals, msi, buf errchk imgs2r, msifit, msiinit pointer imgs2r() begin call smark (sp) call salloc (oys, width, TY_REAL) call salloc (xs, nvals, TY_REAL) call salloc (ys, nvals, TY_REAL) call salloc (yvals, nvals, TY_REAL) # Initialize the interpolator and the image data buffer. call msiinit (msi, II_BILINEAR] buf = NULL # Set the boundary. nedge = max (2, width / 2 + 1) col1 = int (min (x1, x2)) - nedge col2 = nint (max (x1, x2)) + nedge line1 = int (y1) - nedge line2 = nint (y1) + nedge call ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) # Determine sampling perpendicular to vector. if (nvals == 1) dx = 0.0d0 else dx = (x2 - x1) / (nvals - 1) dy = 1.0 # Compute offset from the nominal vector to the first sample point. noff = (real (width) - 1.0) / 2.0 xv = x1 - col1 + 1 do i = 1, nvals { Memr[xs+i-1] = xv xv = xv + dx } yoff = noff * dy yv = y1 - yoff do j = 1, width Memr[oys+j-1] = yv + double (j - 1) # Clear the accululator. call aclrr (y_vector, nvals) # Loop over the output image lines. do i = 1, width { line = yv # Get the input image data and fit an interpolator to the data. # The input data is buffered in a section of size NLINES + 2 * # NEDGE. if (dy >= 0.0 && (buf == NULL || line > (linea))) { linea = min (line2, line + NLINES - 1) lineb = max (line1, line - nedge) linec = min (line2, linea + nedge) buf = imgs2r (im, col1, col2, lineb, linec) if (buf == NULL) call error (0, "Error reading input image.") call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + 1, col2 - col1 + 1) } else if (dy < 0.0 && (buf == NULL || line < linea)) { linea = max (line1, line - NLINES + 1) lineb = max (line1, linea - nedge) linec = min (line2, line + nedge) buf = imgs2r (im, col1, col2, lineb, linec) if (buf == NULL) call error (0, "Error reading input image.") call msifit (msi, Memr[buf], col2 - col1 + 1, linec - lineb + 1, col2 - col1 + 1) } # Evaluate the interpolant. call amovkr (real (Memr[oys+i-1] - lineb + 1), Memr[ys], nvals) call msivector (msi, Memr[xs], Memr[ys], Memr[yvals], nvals) if (width == 1) call amovr (Memr[yvals], y_vector, nvals) else call aaddr (Memr[yvals], y_vector, y_vector, nvals) yv = yv + dy } # Compute the x and y vectors. do i = 1, nvals x_vector[i] = real (i) if (width > 1) call adivkr (y_vector, real (width), y_vector, nvals) # Compute min and max values. call alimr (y_vector, nvals, zmin, zmax) # Free memory . call msifree (msi) call sfree (sp) end # IE_SETBOUNDARY -- Set boundary extension. procedure ie_setboundary (im, col1, col2, line1, line2, btype, bconstant) pointer im # IMIO pointer int col1, col2 # Range of columns int line1, line2 # Range of lines int btype # Boundary extension type real bconstant # Constant for constant boundary extension int btypes[5] int i, nbndrypix data btypes /BT_CONSTANT, BT_NEAREST, BT_REFLECT, BT_WRAP, BT_PROJECT/ begin nbndrypix = 0 nbndrypix = max (nbndrypix, 1 - col1) nbndrypix = max (nbndrypix, col2 - IM_LEN(im,1)) nbndrypix = max (nbndrypix, 1 - line1) nbndrypix = max (nbndrypix, line2 - IM_LEN(im,2)) do i = 1, MI_NIMS(im) { call imseti (MI_IM(im,i), IM_TYBNDRY, btypes[btype]) call imseti (MI_IM(im,i), IM_NBNDRYPIX, nbndrypix + 1) if (btypes[btype] == BT_CONSTANT) call imsetr (MI_IM(im,i), IM_BNDRYPIXVAL, bconstant) } end # IE_BUFL2R -- Maintain buffer of image lines. A new buffer is created when # the buffer pointer is null or if the number of lines requested is changed. # The minimum number of image reads is used. procedure ie_bufl2r (im, col1, col2, line1, line2, buf) pointer im # Image pointer int col1 # First image column of buffer int col2 # Last image column of buffer int line1 # First image line of buffer int line2 # Last image line of buffer pointer buf # Buffer pointer buf1, buf2 int i, ncols, nlines, nclast, llast1, llast2, nllast errchk malloc, realloc, imgs2r pointer imgs2r() begin ncols = col2 - col1 + 1 nlines = line2 - line1 + 1 # If the buffer pointer is undefined then allocate memory for the # buffer. If the number of columns or lines requested changes # reallocate the buffer. Initialize the last line values to force # a full buffer image read. if (buf == NULL) { call malloc (buf, ncols * nlines, TY_REAL) llast1 = line1 - nlines llast2 = line2 - nlines } else if ((nlines != nllast) || (ncols != nclast)) { call realloc (buf, ncols * nlines, TY_REAL) llast1 = line1 - nlines llast2 = line2 - nlines } # Read only the image lines with are different from the last buffer. if (line1 < llast1) { do i = line2, line1, -1 { if (i > llast1) buf1 = buf + (i - llast1) * ncols else buf1 = imgs2r (im, col1, col2, i, i) buf2 = buf + (i - line1) * ncols call amovr (Memr[buf1], Memr[buf2], ncols) } } else if (line2 > llast2) { do i = line1, line2 { if (i < llast2) buf1 = buf + (i - llast1) * ncols else buf1 = imgs2r (im, col1, col2, i, i) buf2 = buf + (i - line1) * ncols call amovr (Memr[buf1], Memr[buf2], ncols) } } # Save the buffer parameters. llast1 = line1 llast2 = line2 nclast = ncols nllast = nlines end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/imexam.h�������������������������������������������0000664�0000000�0000000�00000004676�13321663143�0022442�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# IMEXAM.H -- IMEXAMINE global definitions. define MAX_FRAMES 4 # max display frames # IMEXAMINE data structure. define IE_LEN 320 # length of IE structure define IE_SZFNAME 99 # length of file name define IE_SZFORMAT 9 # length of format strings define IE_SZTITLE 512 # length of multiline title define IE_IM Memi[$1] # IMIO pointer define IE_MW Memi[$1+1] # MWCS pointer define IE_CTLW Memi[$1+2] # CT-MWCS pointer (L -> W) define IE_CTWL Memi[$1+3] # CT-MWCS pointer (W -> L) define IE_DS Memi[$1+4] # display frame pointer define IE_GP Memi[$1+5] # GIO pointer define IE_PP Memi[$1+6] # pset pointer define IE_LIST Memi[$1+7] # image list define IE_LISTLEN Memi[$1+8] # number of images in list define IE_USEDISPLAY Memi[$1+9] # use image display? define IE_INDEX Memi[$1+10] # image index define IE_DFRAME Memi[$1+11] # frame used to display images define IE_MAPFRAME Memi[$1+12] # mapped display frame define IE_NEWFRAME Memi[$1+13] # new (current) display frame define IE_NFRAMES Memi[$1+14] # number of image frames define IE_ALLFRAMES Memi[$1+15] # use all frames for display? define IE_LOGFD Memi[$1+16] # log file descriptor define IE_MAGZERO Memr[P2R($1+17)] # magnitude zero point define IE_XORIGIN Memr[P2R($1+18)] # X origin define IE_YORIGIN Memr[P2R($1+19)] # Y origin define IE_GTYPE Memi[$1+20] # current graph type define IE_X1 Memr[P2R($1+21)] # current graph x1 define IE_X2 Memr[P2R($1+22)] # current graph x2 define IE_Y1 Memr[P2R($1+23)] # current graph y1 define IE_Y2 Memr[P2R($1+24)] # current graph y2 define IE_IX1 Memi[$1+25] # image section coordinate define IE_IX2 Memi[$1+26] # image section coordinate define IE_IY1 Memi[$1+27] # image section coordinate define IE_IY2 Memi[$1+28] # image section coordinate define IE_P1 Memi[$1+29] # Physical axis for logical x define IE_P2 Memi[$1+30] # Physical axis for logical y define IE_IN Memr[P2R($1+31)+$2-1] # Input coordinate vector define IE_OUT Memr[P2R($1+38)+$2-1] # Output coordinate vector define IE_WCSDIM Memi[$1+45] # WCS dimension define IE_LASTKEY Memi[$1+46] # last type of keyed output # (available) define IE_IMAGE Memc[P2C($1+50)] # image name define IE_LOGFILE Memc[P2C($1+100)] # logfile name define IE_WCSNAME Memc[P2C($1+150)] # WCS name define IE_XLABEL Memc[P2C($1+200)] # WCS label define IE_YLABEL Memc[P2C($1+250)] # WCS label define IE_XFORMAT Memc[P2C($1+300)] # WCS format define IE_YFORMAT Memc[P2C($1+310)] # WCS format ������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/imexamine.key��������������������������������������0000664�0000000�0000000�00000020060�13321663143�0023460�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ -- IMEXAMINE COMMANDS -- CURSOR KEY COMMAND SUMMARY ? Help h Histogram p Previous frame x Coordinates a Aperture Sum i Image cursor q Quit y Set origin b Box coords j Line gauss fit r Radial plot z Print grid c Column plot k Col gauss fit s Surface plot , Quick phot d Load display l Line plot t Output image . Quick prof fit e Contour plot m Statistics u Vector plot f Redraw n Next frame v Vector plot g Graphics cursor o Overplot w Toggle logfile COLON COMMAND SUMMARY allframes ceiling iterations naverage pointmode width angh center label nbins radius x angv constant logfile ncolumns round xformat autoredraw dashpat logx ncontours rplot xlabel autoscale defkey logy ncoutput select xorder background eparam magzero ncstat szmarker y banner fill majrx nhi ticklabel yformat beta fitplot majry nlines title ylabel boundary fittype marker nloutput top_closed yorder box floor minrx nlstat unlearn z1,z2 buffer interval minry output wcs zero OUTPUT OF 'a' AND 'r' KEYS The 'a' key and logfile output has column labels and each object has one line of measurements in the logfile and two lines on the terminal. The 'r' key shows only the second line on the status line and the information from the first line is in the graph title. The first line contains the x and y center coordinates and optional world coordinates. The second line contains the aperture magnitude and flux, the estimated background sky, the profile fit peak, the ellipticity and position angle from the moment analysis, and four estimates of the profile width. The four estimates are from the moment analysis, the full-width enclosing half the flux, the profile fit, and a direct estimate of the full width at half-maximum. CURSOR KEY COMMANDS ? Print help a Aperture radial photometry measurement (see above for output) b Box coordinates for two cursor positions - c1 c2 l1 l2 c Column plot d Load the image display e Contour plot f Redraw the last graph g Graphics cursor h Histogram plot i Image cursor j Fit 1D gaussian to image lines k Fit 1D gaussian to image columns l Line plot m Statistics image[section] npixels mean median stddev min max n Next frame or image o Overplot p Previous frame or image q Quit r Radial profile plot (see above for output) s Surface plot t Output image centered on cursor (parameters output, ncoutput, nloutput) u Centered vector plot from two cursor positions v Vector plot between two cursor positions w Toggle write to logfile x Print coordinates col line pixval [xorign yorigin dx dy r theta] y Set origin for relative positions z Print grid of pixel values - 10 x 10 grid , Quick profile photometry measurement (Gaussian or Moffat) . Quick radial profile plot and fit (Gaussian or Moffat) COLON COMMANDS Explicit image coordinates may be entered using the colon command syntax: :column line key where column and line are the image coordinates and the key is one of the cursor keys. A special syntax for line or column plots is also available as :c# or :l# where # is a column or line and no space is allowed. Other colon commands set or show parameters governing the plots and other features of the task. Each graph type has it's own set of parameters. When a parameter applies to more than one graph the current graph is assumed. If the current graph is not applicable then a warning is given. The "eparam" and "unlearn" commands may be used to change many parameters and without an argument the current graph parameters are modified while with the graph key as an argument the appropriate parameter set is modified. In the list below the graph key(s) to which a parameter applies are shown. allframes Cycle through all display frames to display images angh s Horizontal angle for surface plot angv s Vertical angle for surface plot autoredraw cehlrsuv. Automatically redraw graph after colon command? autoscale h Adjust number of histogram bins to avoid aliasing axes s Draw axes in surface plot? background jkr. Subtract background for radial plot and photometry? banner cehjklrsuv. Include standard banner on plots? beta ar Moffat beta parameter (INDEF to fit or value to fix) boundary uv Boundary extension type for vector plots box cehjklruv. Draw box around graph? buffer r. Buffer distance for background subtraction ceiling es Data ceiling for contour and surface plots center jkr. Find center for radial plot and photometry? constant uv Constant value for boundry extension in vector plots dashpat e Dash pattern for contour plot eparam cehjklrsuv. Edit parameters fill e Fill viewport vs enforce unity aspect ratio? fitplot r Overplot profile fit on data? fittype ar Profile fitting type (gaussian|moffat) floor es Data floor for contour and surface plots interval e Contour interval (0 for default) iterations ar Iterations on fitting radius label e Draw axis labels for contour plot? logfile Log file name logx chjklruv. Plot x axis logrithmically? logy chjklruv. Plot y axis logrithmically? magzero r. Magnitude zero for photometry majrx cehjklruv. Number of major tick marks on x axis majry cehjklruv. Number of major tick marks on y axis marker chjklruv. Marker type for graph minrx cehjklruv. Number of minor tick marks on x axis minry cehjklruv. Number of minor tick marks on y axis naverage cjkluv Number of columns, lines, vectors to average nbins h Number of histogram bins ncolumns ehs Number of columns in contour, histogram, or surface plot ncontours e Number of contours (0 for default) ncoutput Number of columns in output image ncstat Number of columns in statistics box nhi e hi/low marking option for contours nlines ehs Number of lines in contour, histogram, or surface plot nloutput Number of lines in output image nlstat Number of lines in statistics box output Output image root name pointmode chjkluv Plot points instead of lines? radius r. Radius of object aperture for radial plot and photmetry round cehjklruv. Round axes to nice values? rplot jkr. Radius to plot in 1D and radial profile plots select Select image or display frame sigma jk Initial sigma for 1D gaussian fits szmarker chjklruv. Size of marks for point mode ticklabels cehjklruv. Label ticks? title cehjklrsuv. Optional title for graph top_closed h Close last bin of histogram unlearn cehjklrsuv. Unlearn parameters to default values wcs World coordinate system for axis labels and readback width jkr. Width of background region x [min max] chjklruv. Range of x to be plotted (no values for autoscaling) xformat Coordinate format for column world coordinates xlabel cehjklrsuv. Optional label for x axis xorder jkr. X order of surface for background subtraction y [min max] chjklruv. Range of y to be plotted (no values for autoscaling) yformat Coordinate format for line world coordinates ylabel cehjklrsuv. Optional label for y axis yorder r. Y order of surface for background subtraction z1 h Lower intensity value limit of histogram z2 h Upper intensity value limit of histogram zero e Zero level for contour plot ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/jimexam2.par���������������������������������������0000664�0000000�0000000�00000002156�13321663143�0023220�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������banner,b,h,yes,,,"Standard banner" title,s,h,"",,,"Title" xlabel,s,h,"wcslabel",,,"X-axis label" ylabel,s,h,"Pixel Value",,,"Y-axis label" naverage,i,h,5,1,,"Number of liness or columns to average" center,b,h,yes,,,"Solve for center?" background,b,h,yes,,,"Solve for background?" sigma,r,h,1.,0.1,,"Initial sigma (pixels)" width,r,h,10.,1.,,Background width (pixels) xorder,i,h,0,0,2,Background terms to fit (0=median) rplot,r,h,10.,1.,,"Plotting radius (pixels)" x1,r,h,INDEF,,,X-axis window limit x2,r,h,INDEF,,,X-axis window limit y1,r,h,INDEF,,,Y-axis window limit y2,r,h,INDEF,,,Y-axis window limit pointmode,b,h,yes,,,plot points instead of lines? marker,s,h,"plus",,,point marker character? szmarker,r,h,1.,,,marker size logx,b,h,no,,,log scale x-axis logy,b,h,no,,,log scale y-axis box,b,h,yes,,,draw box around periphery of window ticklabels,b,h,yes,,,label tick marks majrx,i,h,5,,,number of major divisions along x grid minrx,i,h,5,,,number of minor divisions along x grid majry,i,h,5,,,number of major divisions along y grid minry,i,h,5,,,number of minor divisions along y grid round,b,h,no,,,round axes to nice values? ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/kimexam2.par���������������������������������������0000664�0000000�0000000�00000002156�13321663143�0023221�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������banner,b,h,yes,,,"Standard banner" title,s,h,"",,,"Title" xlabel,s,h,"wcslabel",,,"X-axis label" ylabel,s,h,"Pixel Value",,,"Y-axis label" naverage,i,h,5,1,,"Number of liness or columns to average" center,b,h,yes,,,"Solve for center?" background,b,h,yes,,,"Solve for background?" sigma,r,h,1.,0.1,,"Initial sigma (pixels)" width,r,h,10.,1.,,Background width (pixels) xorder,i,h,0,0,2,Background terms to fit (0=median) rplot,r,h,10.,1.,,"Plotting radius (pixels)" x1,r,h,INDEF,,,X-axis window limit x2,r,h,INDEF,,,X-axis window limit y1,r,h,INDEF,,,Y-axis window limit y2,r,h,INDEF,,,Y-axis window limit pointmode,b,h,yes,,,plot points instead of lines? marker,s,h,"plus",,,point marker character? szmarker,r,h,1.,,,marker size logx,b,h,no,,,log scale x-axis logy,b,h,no,,,log scale y-axis box,b,h,yes,,,draw box around periphery of window ticklabels,b,h,yes,,,label tick marks majrx,i,h,5,,,number of major divisions along x grid minrx,i,h,5,,,number of minor divisions along x grid majry,i,h,5,,,number of major divisions along y grid minry,i,h,5,,,number of minor divisions along y grid round,b,h,no,,,round axes to nice values? ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/limexam2.par���������������������������������������0000664�0000000�0000000�00000001523�13321663143�0023217�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������banner,b,h,yes,,,"Standard banner" title,s,h,"",,,"Title" xlabel,s,h,"wcslabel",,,"X-axis label" ylabel,s,h,"Pixel Value",,,"Y-axis label" naverage,i,h,1,,,Number of lines to average x1,r,h,INDEF,,,X-axis window limit x2,r,h,INDEF,,,X-axis window limit y1,r,h,INDEF,,,Y-axis window limit y2,r,h,INDEF,,,Y-axis window limit pointmode,b,h,no,,,plot points instead of lines? marker,s,h,"plus",,,point marker character? szmarker,r,h,1.,,,marker size logx,b,h,no,,,log scale x-axis logy,b,h,no,,,log scale y-axis box,b,h,yes,,,draw box around periphery of window ticklabels,b,h,yes,,,label tick marks majrx,i,h,5,,,number of major divisions along x grid minrx,i,h,5,,,number of minor divisions along x grid majry,i,h,5,,,number of major divisions along y grid minry,i,h,5,,,number of minor divisions along y grid round,b,h,no,,,round axes to nice values? �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/mkpkg����������������������������������������������0000664�0000000�0000000�00000003201�13321663143�0022024�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# IMEXAMINE update: $call limexam ; limexam: $checkout libimexam.a mscbin$ $update libimexam.a $checkin libimexam.a mscbin$ ; libimexam.a: iecimexam.x imexam.h mscexam.h iecolon.x imexam.h iedisplay.x mscexam.h ieeimexam.x imexam.h mscexam.h \ iegcur.x imexam.h mscexam.h iegdata.x mscexam.h iegimage.x imexam.h mscexam.h iegnfr.x imexam.h iegraph.x imexam.h iehimexam.x imexam.h mscexam.h ieimname.x iejimexam.x imexam.h mscexam.h ielimexam.x imexam.h mscexam.h iemw.x imexam.h mscexam.h ieopenlog.x imexam.h mscexam.h iepos.x imexam.h ieprint.x imexam.h ieqrimexam.x imexam.h mscexam.h \ ierimexam.x imexam.h mscexam.h \ iesimexam.x imexam.h mscexam.h iestatistics.x imexam.h ietimexam.x imexam.h ../mosim.h ievimexam.x imexam.h mscexam.h \ stfmeasure.x mscexam.h starfocus.h \ stfprofile.x mscexam.h starfocus.h \ t_imexam.x imexam.h mscexam.h ; �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/mscexam.h������������������������������������������0000664�0000000�0000000�00000000731�13321663143�0022603�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "../mosim.h" include "../mosgeom.h" define IM_TITLE Memc[MI_RNAME($1)] define MI_LEN1 NX(MI_CMG($1)) define MI_LEN2 NY(MI_CMG($1)) define IM_LEN MI_LEN$2($1) define immap mimap define imunmap miunmap define imgs2r migs2r #define imtopen mitopen #define imtrgetim mitrgetim #define imtlen mitlen #define imtclose mitclose define dsunmap imunmap define mw_openim msc_openim define mw_close msc_close define mw_sctran msc_sctran define mw_ctranr msc_ctranr ���������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/mscexamine.par�������������������������������������0000664�0000000�0000000�00000002414�13321663143�0023632�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,images to be examined output,s,h,"",,,output root image name zero,f,h,"",,,root name for sky subtraction frame,i,q,1,1,,display frame mimpars,pset,h,"",,,"mosaic image parameters (extensions, gaps, processing)" image,s,q,,,,image name ncoutput,i,h,101,1,,Number of columns in image output nloutput,i,h,101,1,,Number of lines in image output logfile,s,h,"",,,logfile keeplog,b,h,no,,,log output results defkey,s,h,"a",,,default key for cursor list input autoredraw,b,h,yes,,,automatically redraw graph allframes,b,h,yes,,,use all frames for displaying new images nframes,i,h,0,,,number of display frames (0 to autosense) ncstat,i,h,5,1,,number of columns for statistics nlstat,i,h,5,1,,number of lines for statistics graphcur,*gcur,h,"",,,graphics cursor input imagecur,*imcur,h,"",,,image display cursor input wcs,s,h,"logical",,,Coordinate system xformat,s,h,"%.2H",,,X axis coordinate format yformat,s,h,"%.1h",,,Y axis coordinate format graphics,s,h,"stdgraph",,,graphics device display,s,h,"mscdisplay(image='$1',frame=$2)",,,display command template use_display,b,h,yes,,,enable direct display interaction ## PROCESSING PARAMETERS" #procpars,pset,h,"",,,"Processing parameters # ## AMPLIFIER INFORMATION" #ampinfo,pset,h,"",,,"Amplifier Information pset #" mode,s,h,"a",,, ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/rimexam2.par���������������������������������������0000664�0000000�0000000�00000002523�13321663143�0023226�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������banner,b,h,yes,,,"Standard banner" title,s,h,"",,,"Title" xlabel,s,h,"Radius",,,"X-axis label" ylabel,s,h,"Pixel Value",,,"Y-axis label" fitplot,b,h,yes,,,"Overplot profile fit?" fittype,s,h,"moffat","gaussian|moffat",,"Profile type to fit" center,b,h,yes,,,"Center object in aperture?" background,b,h,yes,,,"Fit and subtract background?" radius,r,h,5.,1.,,"Object radius" buffer,r,h,5.,0.,,Background buffer width width,r,h,5.,1.,,Background width iterations,i,h,3,1,,"Number of radius adjustment iterations" xorder,i,h,0,0,,Background x order yorder,i,h,0,0,,Background y order magzero,r,h,25.,,,Magnitude zero point beta,r,h,INDEF,,,Moffat beta parameter rplot,r,h,8.,1.,,"Plotting radius" x1,r,h,INDEF,,,X-axis window limit x2,r,h,INDEF,,,X-axis window limit y1,r,h,INDEF,,,Y-axis window limit y2,r,h,INDEF,,,Y-axis window limit pointmode,b,h,yes,,,plot points instead of lines? marker,s,h,"plus",,,point marker character? szmarker,r,h,1.,,,marker size logx,b,h,no,,,log scale x-axis logy,b,h,no,,,log scale y-axis box,b,h,yes,,,draw box around periphery of window ticklabels,b,h,yes,,,label tick marks majrx,i,h,5,,,number of major divisions along x grid minrx,i,h,5,,,number of minor divisions along x grid majry,i,h,5,,,number of major divisions along y grid minry,i,h,5,,,number of minor divisions along y grid round,b,h,no,,,round axes to nice values? �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/simexam2.par���������������������������������������0000664�0000000�0000000�00000000541�13321663143�0023225�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������banner,b,h,yes,,,"Standard banner" title,s,h,"",,,"Title" axes,b,h,yes,,,Draw axes? ncolumns,i,h,21,2,,"Number of columns" nlines,i,h,21,2,,"Number of lines" angh,r,h, -33.,,,Horizontal viewing angle (degrees) angv,r,h,25.,,,Vertical viewing angle (degrees) floor,r,h,INDEF,,,Minimum value to be plotted ceiling,r,h,INDEF,,,Maximum value to be plotted ���������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/starfocus.h����������������������������������������0000664�0000000�0000000�00000013200�13321663143�0023152�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# STARFOCUS # Types of coordinates define SF_TYPES "|center|mark1|markall|" define SF_CENTER 1 # Star at center of image define SF_MARK1 2 # Mark stars in first image define SF_MARKALL 3 # Mark stars in all images # Task type define STARFOCUS 1 define PSFMEASURE 2 # Radius types define SF_WTYPES "|Radius|FWHM|GFWHM|MFWHM|" define SF_RMIN 16 # Minimum centering search radius define MAX_FRAMES 8 # Maximum number of display frames # Data structures for STARFOCUS define NBNDRYPIX 0 # Number of boundary pixels define TYBNDRY BT_REFLECT # Type of boundary extension define SAMPLE .2 # Subpixel sampling size define SF_SZFNAME 79 # Length of file names define SF_SZWTYPE 7 # Length of width type string # Main data structure define SF 40 define SF_TASK Memi[$1] # Task type define SF_WTYPE Memc[P2C($1+1)] # Width type string define SF_WCODE Memi[$1+5] # Width code define SF_BETA Memr[P2R($1+6)] # Moffat beta define SF_SCALE Memr[P2R($1+7)] # Pixel scale define SF_LEVEL Memr[P2R($1+8)] # Profile measurement level define SF_RADIUS Memr[P2R($1+9)] # Profile radius define SF_SBUF Memr[P2R($1+10)]# Sky region buffer define SF_SWIDTH Memr[P2R($1+11)]# Sky region width define SF_SAT Memr[P2R($1+12)]# Saturation define SF_NIT Memi[$1+13] # Number of iterations for radius define SF_OVRPLT Memi[$1+14] # Overplot the best profile? define SF_NCOLS Memi[$1+15] # Number of image columns define SF_NLINES Memi[$1+16] # Number of image lines define SF_XF Memr[P2R($1+17)]# X field center define SF_YF Memr[P2R($1+18)]# Y field center define SF_GP Memi[$1+19] # GIO pointer define SF_F Memr[P2R($1+20)]# Best focus define SF_W Memr[P2R($1+21)]# Width at best focus define SF_M Memr[P2R($1+22)]# Brightest star magnitude define SF_XP1 Memr[P2R($1+23)]# First derivative point to plot define SF_XP2 Memr[P2R($1+24)]# Last derivative point to plot define SF_YP1 Memr[P2R($1+25)]# Minimum of derivative profile define SF_YP2 Memr[P2R($1+26)]# Maximum of derivative profile define SF_N Memi[$1+27] # Number of points not deleted define SF_NSFD Memi[$1+28] # Number of data points define SF_SFDS Memi[$1+29] # Pointer to data structures define SF_NS Memi[$1+30] # Number of stars not deleted define SF_NSTARS Memi[$1+31] # Number of stars define SF_STARS Memi[$1+32] # Pointer to star groups define SF_NF Memi[$1+33] # Number of focuses not deleted define SF_NFOCUS Memi[$1+34] # Number of different focus values define SF_FOCUS Memi[$1+35] # Pointer to focus groups define SF_NI Memi[$1+36] # Number of images not deleted define SF_NIMAGES Memi[$1+37] # Number of images define SF_IMAGES Memi[$1+38] # Pointer to image groups define SF_BEST Memi[$1+39] # Pointer to best focus star define SF_SFD Memi[SF_SFDS($1)+$2-1] define SF_SFS Memi[SF_STARS($1)+$2-1] define SF_SFF Memi[SF_FOCUS($1)+$2-1] define SF_SFI Memi[SF_IMAGES($1)+$2-1] # Basic data structure. define SFD 94 define SFD_IMAGE Memc[P2C($1)] # Image name define SFD_DATA Memi[$1+40] # Pointer to real image raster define SFD_RADIUS Memr[P2R($1+41)]# Profile radius define SFD_NP Memi[$1+42] # Number of profile points define SFD_NPMAX Memi[$1+43] # Maximum number of profile points define SFD_X1 Memi[$1+44] # Image raster limits define SFD_X2 Memi[$1+45] define SFD_Y1 Memi[$1+46] define SFD_Y2 Memi[$1+47] define SFD_ID Memi[$1+48] # Star ID define SFD_X Memr[P2R($1+49)]# Star X position define SFD_Y Memr[P2R($1+50)]# Star Y position define SFD_F Memr[P2R($1+51)]# Focus define SFD_W Memr[P2R($1+52)]# Width to use define SFD_M Memr[P2R($1+53)]# Magnitude define SFD_E Memr[P2R($1+54)]# Ellipticity define SFD_PA Memr[P2R($1+55)]# Position angle define SFD_R Memr[P2R($1+56)]# Radius at given level define SFD_DFWHM Memr[P2R($1+57)]# Direct FWHM define SFD_GFWHM Memr[P2R($1+58)]# Gaussian FWHM define SFD_MFWHM Memr[P2R($1+59)]# Moffat FWHM define SFD_ASI1 Memi[$1+60] # Pointer to enclosed flux profile define SFD_ASI2 Memi[$1+61] # Pointer to derivative profile define SFD_YP1 Memr[P2R($1+62)]# Minimum of derivative profile define SFD_YP2 Memr[P2R($1+63)]# Maximum of derivative profile define SFD_FWHM Memr[P2R($1+$2+63)]# FWHM vs level=0.5*i (i=1-19) define SFD_BKGD Memr[P2R($1+83)]# Background value define SFD_BKGD1 Memr[P2R($1+84)]# Original background value define SFD_MISO Memr[P2R($1+85)]# Moment isophote define SFD_SIGMA Memr[P2R($1+86)]# Moffat alpha define SFD_ALPHA Memr[P2R($1+87)]# Moffat alpha define SFD_BETA Memr[P2R($1+88)]# Moffat beta define SFD_STATUS Memi[$1+89] # Status define SFD_NSAT Memi[$1+90] # Number of saturated pixels define SFD_SFS Memi[$1+91] # Pointer to star group define SFD_SFF Memi[$1+92] # Pointer to focus group define SFD_SFI Memi[$1+93] # Pointer to image group # Structure grouping data by star. define SFS ($1+7) define SFS_ID Memi[$1] # Star ID define SFS_F Memr[P2R($1+1)] # Best focus define SFS_W Memr[P2R($1+2)] # Best width define SFS_M Memr[P2R($1+3)] # Average magnitude define SFS_N Memi[$1+4] # Number of points used define SFS_NF Memi[$1+5] # Number of focuses define SFS_NSFD Memi[$1+6] # Number of data points define SFS_SFD Memi[$1+$2+6] # Array of data structures # Structure grouping stars by focus values. define SFF ($1+5) define SFF_F Memr[P2R($1)] # Focus define SFF_W Memr[P2R($1+1)] # Average width define SFF_N Memi[$1+2] # Number in average define SFF_NI Memi[$1+3] # Number of images define SFF_NSFD Memi[$1+4] # Number of data points define SFF_SFD Memi[$1+$2+4] # Array of data structures # Structure grouping stars by image. define SFI ($1+42) define SFI_IMAGE Memc[P2C($1)] # Image define SFI_N Memi[$1+40] # Number in imagE define SFI_NSFD Memi[$1+41] # Number of data points define SFI_SFD Memi[$1+$2+41] # Array of data structures ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/stfmeasure.x���������������������������������������0000664�0000000�0000000�00000007162�13321663143�0023351�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include "starfocus.h" include "mscexam.h" # STF_MEASURE -- PSF measuring routine. # This is a stand-alone routine that can be called to return the FWHM. # It is a greatly abbreviated version of starfocus. procedure stf_measure (im, xc, yc, beta, level, radius, nit, sbuffer, swidth, saturation, gp, logfd, bkg, renclosed, dfwhm, gfwhm, mfwhm) pointer im #I Image pointer real xc #I Initial X center real yc #I Initial Y center real beta #I Moffat beta real level #I Measurement level real radius #U Profile radius int nit #I Number of iterations on radius real sbuffer #I Sky buffer (pixels) real swidth #I Sky width (pixels) real saturation #I Saturation pointer gp #I Graphics output if not NULL int logfd #I Log output if not NULL real bkg #O Background used real renclosed #O Enclosed flux radius real dfwhm #O Direct FWHM real gfwhm #O Gaussian FWHM real mfwhm #O Moffat FWHM int i bool ignore_sat pointer sp, str, sf, sfd, sfds int strdic() real stf_r2i() errchk stf_find, stf_bkgd, stf_profile, stf_widths, stf_fwhms, stf_organize begin call smark (sp) call salloc (str, SZ_FNAME, TY_CHAR) call salloc (sf, SF, TY_STRUCT) call salloc (sfd, SFD, TY_STRUCT) call salloc (sfds, 1, TY_POINTER) call aclri (Memi[sf], SF) call aclri (Memi[sfd], SFD) Memi[sfds] = sfd # Initialize parameters. SF_TASK(sf) = PSFMEASURE SF_WCODE(sf) = strdic ("FWHM", SF_WTYPE(sf), SF_SZWTYPE, SF_WTYPES) SF_SCALE(sf) = 1. SF_LEVEL(sf) = level SF_BETA(sf) = beta SF_RADIUS(sf) = radius SF_SBUF(sf) = sbuffer SF_SWIDTH(sf) = swidth SF_SAT(sf) = saturation SF_NIT(sf) = nit SF_OVRPLT(sf) = NO SF_NCOLS(sf) = IM_LEN(im,1) SF_NLINES(sf) = IM_LEN(im,2) SF_XF(sf) = (IM_LEN(im,1) + 1) / 2. SF_YF(sf) = (IM_LEN(im,2) + 1) / 2. ignore_sat = false #call imstats (im, IM_IMAGENAME, SFD_IMAGE(sfd), SF_SZFNAME) call strcpy (im, IM_TITLE(im), SFD_IMAGE(sfd), SF_SZFNAME) SFD_ID(sfd) = 1 SFD_X(sfd) = xc SFD_Y(sfd) = yc SFD_F(sfd) = INDEF SFD_STATUS(sfd) = 0 SFD_SFS(sfd) = NULL SFD_SFF(sfd) = NULL SFD_SFI(sfd) = NULL if (SF_LEVEL(sf) > 1.) SF_LEVEL(sf) = SF_LEVEL(sf) / 100. SF_LEVEL(sf) = max (0.05, min (0.95, SF_LEVEL(sf))) # Evaluate PSF data. iferr { do i = 1, SF_NIT(sf) { if (i == 1) SFD_RADIUS(sfd) = SF_RADIUS(sf) else SFD_RADIUS(sfd) = 3. * SFD_DFWHM(sfd) SFD_NPMAX(sfd) = stf_r2i (SFD_RADIUS(sfd)) + 1 SFD_NP(sfd) = SFD_NPMAX(sfd) call stf_find (sf, sfd, im) call stf_bkgd (sf, sfd) if (SFD_NSAT(sfd) > 0 && i == 1) { if (ignore_sat) call error (0, "Saturated pixels found - ignoring object") else call eprintf ( "WARNING: Saturated pixels found.\n") } call stf_profile (sf, sfd) call stf_widths (sf, sfd) call stf_fwhms (sf, sfd) } # Set output results. radius = SFD_RADIUS(sfd) bkg = SFD_BKGD(sfd) renclosed = SFD_R(sfd) dfwhm = SFD_DFWHM(sfd) mfwhm = SFD_MFWHM(sfd) gfwhm = SFD_GFWHM(sfd) call asifree (SFD_ASI1(sfd)) call asifree (SFD_ASI2(sfd)) } then call erract (EA_WARN) # Finish up call stf_free (sf) call sfree (sp) end # STF_FREE -- Free the starfocus data structures. procedure stf_free (sf) pointer sf #I Starfocus structure int i begin do i = 1, SF_NSTARS(sf) call mfree (SF_SFS(sf,i), TY_STRUCT) do i = 1, SF_NFOCUS(sf) call mfree (SF_SFF(sf,i), TY_STRUCT) do i = 1, SF_NIMAGES(sf) call mfree (SF_SFI(sf,i), TY_STRUCT) call mfree (SF_STARS(sf), TY_POINTER) call mfree (SF_FOCUS(sf), TY_POINTER) call mfree (SF_IMAGES(sf), TY_POINTER) SF_NSTARS(sf) = 0 SF_NFOCUS(sf) = 0 SF_NIMAGES(sf) = 0 end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/stfprofile.x���������������������������������������0000664�0000000�0000000�00000064053�13321663143�0023352�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include include "starfocus.h" include "mscexam.h" # STF_FIND -- Find the object and return the data raster and object center. # STF_BKGD -- Compute the background. # STF_PROFILE -- Compute enclosed flux profile, derivative, and moments. # STF_NORM -- Renormalized enclosed flux profile # STF_WIDTHS -- Set widths. # STF_I2R -- Radius from sample index. # STF_R2I -- Sample index from radius. # STF_R2N -- Number of subsamples from radius. # STF_MODEL -- Return model values. # STF_DFWHM -- Direct FWHM from profile. # STF_FWHMS -- Measure FWHM vs level. # STF_RADIUS -- Measure the radius at the specified level. # STF_FIT -- Fit model. # STF_GAUSS1 -- Gaussian function used in NLFIT. # STF_GAUSS2 -- Gaussian function and derivatives used in NLFIT. # STF_MOFFAT1 -- Moffat function used in NLFIT. # STF_MOFFAT2 -- Moffat function and derivatives used in NLFIT. # STF_FIND -- Find the object and return the data raster and object center. # Centering uses centroid of marginal distributions of data above the mean. procedure stf_find (sf, sfd, im) pointer sf #I Starfocus pointer pointer sfd #I Object pointer pointer im #I Image pointer long lseed int i, j, k, x1, x2, y1, y2, nx, ny, npts real radius, buffer, width, xc, yc, xlast, ylast, r1, r2 real mean, sum, sum1, sum2, sum3, asumr(), urand() pointer data, ptr, imgs2r() errchk imgs2r begin radius = max (3., SFD_RADIUS(sfd)) buffer = SF_SBUF(sf) width = SF_SWIDTH(sf) xc = SFD_X(sfd) yc = SFD_Y(sfd) r1 = radius + buffer + width r2 = radius # Iterate on the center finding. do k = 1, 3 { # Extract region around current center. xlast = xc ylast = yc x1 = max (1-NBNDRYPIX, nint (xc - r2)) x2 = min (IM_LEN(im,1)+NBNDRYPIX, nint (xc + r2)) nx = x2 - x1 + 1 y1 = max (1-NBNDRYPIX, nint (yc - r2)) y2 = min (IM_LEN(im,2)+NBNDRYPIX, nint (yc + r2)) ny = y2 - y1 + 1 npts = nx * ny data = imgs2r (im, x1, x2, y1, y2) # Find center of gravity of marginal distributions above mean. npts = nx * ny sum = asumr (Memr[data], npts) mean = sum / nx sum1 = 0. sum2 = 0. do i = x1, x2 { ptr = data + i - x1 sum3 = 0. do j = y1, y2 { sum3 = sum3 + Memr[ptr] ptr = ptr + nx } sum3 = sum3 - mean if (sum3 > 0.) { sum1 = sum1 + i * sum3 sum2 = sum2 + sum3 } } if (sum2 <= 0) call error (1, "Centering failed to converge") xc = sum1 / sum2 if (xlast - xc > 0.2 * nx) xc = xlast - 0.2 * nx if (xc - xlast > 0.2 * nx) xc = xlast + 0.2 * nx ptr = data mean = sum / ny sum1 = 0. sum2 = 0. do j = y1, y2 { sum3 = 0. do i = x1, x2 { sum3 = sum3 + Memr[ptr] ptr = ptr + 1 } sum3 = sum3 - mean if (sum3 > 0.) { sum1 = sum1 + j * sum3 sum2 = sum2 + sum3 } } if (sum2 <= 0) call error (1, "Centering failed to converge") yc = sum1 / sum2 if (ylast - yc > 0.2 * ny) yc = ylast - 0.2 * ny if (yc - ylast > 0.2 * ny) yc = ylast + 0.2 * ny if (nint(xc) == nint(xlast) && nint(yc) == nint(ylast)) break } # Get a new centered raster if necessary. if (nint(xc) != nint(xlast) || nint(yc) != nint(ylast) || r2 < r1) { x1 = max (1-NBNDRYPIX, nint (xc - r1)) x2 = min (IM_LEN(im,1)+NBNDRYPIX, nint (xc + r1)) nx = x2 - x1 + 1 y1 = max (1-NBNDRYPIX, nint (yc - r1)) y2 = min (IM_LEN(im,2)+NBNDRYPIX, nint (yc + r1)) ny = y2 - y1 + 1 npts = nx * ny data = imgs2r (im, x1, x2, y1, y2) } # We make a copy of the data in the mosim buffer since we will be # modifying its content. This should really be done internal to # mosim! call malloc (ptr, npts, TY_REAL) call amovr (Memr[data], Memr[ptr], npts) data = ptr # Add a dither for integer data. The random numbers are always # the same to provide reproducibility. i = IM_PIXTYPE(im) if (i == TY_SHORT || i == TY_INT || i == TY_LONG) { lseed = 1 do i = 0, npts-1 Memr[data+i] = Memr[data+i] + urand(lseed) - 0.5 } SFD_DATA(sfd) = data SFD_X1(sfd) = x1 SFD_X2(sfd) = x2 SFD_Y1(sfd) = y1 SFD_Y2(sfd) = y2 SFD_X(sfd) = xc SFD_Y(sfd) = yc end # STF_BKGD -- Compute the background. # A mode is estimated from the minimum slope in the sorted background pixels # with a bin width of 5%. procedure stf_bkgd (sf, sfd) pointer sf #I Parameter structure pointer sfd #I Star structure int i, j, x1, x2, y1, y2, xc, yc, nx, ny, npts, ns, nsat real sat, bkgd, miso real r, r1, r2, r3, dx, dy, dz pointer sp, data, bdata, ptr begin data = SFD_DATA(sfd) x1 = SFD_X1(sfd) x2 = SFD_X2(sfd) y1 = SFD_Y1(sfd) y2 = SFD_Y2(sfd) xc = SFD_X(sfd) yc = SFD_Y(sfd) nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny ns = 0 nsat = 0 r1 = SFD_RADIUS(sfd) ** 2 r2 = (SFD_RADIUS(sfd) + SF_SBUF(sf)) ** 2 r3 = (SFD_RADIUS(sfd) + SF_SBUF(sf) + SF_SWIDTH(sf)) ** 2 sat = SF_SAT(sf) if (IS_INDEF(sat)) sat = MAX_REAL call smark (sp) call salloc (bdata, npts, TY_REAL) ptr = data do j = y1, y2 { dy = (yc - j) ** 2 do i = x1, x2 { dx = (xc - i) ** 2 r = dx + dy if (r <= r1) { if (Memr[ptr] >= sat) nsat = nsat + 1 } else if (r >= r2 && r <= r3) { Memr[bdata+ns] = Memr[ptr] ns = ns + 1 } ptr = ptr + 1 } } if (ns > 9) { call asrtr (Memr[bdata], Memr[bdata], ns) r = Memr[bdata+ns-1] - Memr[bdata] bkgd = Memr[bdata] + r / 2 miso = r / 2 j = 1 + 0.50 * ns do i = 0, ns - j { dz = Memr[bdata+i+j-1] - Memr[bdata+i] if (dz < r) { r = dz bkgd = Memr[bdata+i] + dz / 2 miso = dz / 2 } } } else { bkgd = 0. miso = 0. } SFD_BKGD1(sfd) = bkgd SFD_BKGD(sfd) = bkgd SFD_MISO(sfd) = miso SFD_NSAT(sfd) = nsat call sfree (sp) end # STF_PROFILE -- Compute enclosed flux profile, derivative, direct FWHM, and # profile moments.. # 1. The flux profile is normalized at the maximum value. # 2. The radial profile is computed from the numerical derivative of the # enclose flux profile. procedure stf_profile (sf, sfd) pointer sf #I Parameter structure pointer sfd #I Star structure int np real radius, xc, yc int i, j, k, l, m, ns, nx, ny, x1, x2, y1, y2 real bkgd, miso, sigma, peak real r, r1, r2, r3, dx, dy, dx1, dx2, dy1, dy2, dz, xx, yy, xy, ds, da pointer sp, data, profile, ptr, asi, msi, gs int stf_r2n() real asieval(), msieval(), gseval(), stf_i2r(), stf_r2i() errchk asiinit, asifit, msiinit, msifit, gsrestore real gsdata[24] data gsdata/ 1., 4., 4., 1., 0., 0.6726812, 1., 2., 1.630641, 0.088787, 0.00389378, -0.001457133, 0.3932125, -0.1267456, -0.004864541, 0.00249941, 0.03078612, 0.02731274, -4.875850E-4, 2.307464E-4, -0.002134843, 0.007603908, -0.002552385, -8.010564E-4/ begin data = SFD_DATA(sfd) x1 = SFD_X1(sfd) x2 = SFD_X2(sfd) y1 = SFD_Y1(sfd) y2 = SFD_Y2(sfd) xc = SFD_X(sfd) yc = SFD_Y(sfd) bkgd = SFD_BKGD(sfd) miso = SFD_MISO(sfd) radius = SFD_RADIUS(sfd) np = SFD_NP(sfd) nx = x2 - x1 + 1 ny = y2 - y1 + 1 # Use an image interpolator fit to the data. call msiinit (msi, II_BISPLINE3) call msifit (msi, Memr[data], nx, ny, nx) # To avoid trying to interpolate outside the center of the # edge pixels, a requirement of the interpolator functions, # we reset the data limits. x1 = x1 + 1 x2 = x2 - 1 y1 = y1 + 1 y2 = y2 - 1 # Compute the enclosed flux profile, its derivative, and moments. call smark (sp) call salloc (profile, np, TY_REAL) call aclrr (Memr[profile], np) xx = 0. yy = 0. xy = 0. do j = y1, y2 { ptr = data + (j-y1+1)*nx + 1 dy = j - yc do i = x1, x2 { dx = i - xc # Set the subpixel sampling which may be a function of radius. r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds # Sum the interpolator values over the subpixels and compute # an offset to give the correct total for the pixel. r2 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) r2 = r2 + r1 } } r1 = Memr[ptr] - bkgd ptr = ptr + 1 r2 = r1 - r2 * da # Accumulate the enclosed flux over the sub pixels. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r = max (0., sqrt (dx2 + dy2) - ds / 2) if (r < radius) { r1 = da * (msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) + r2) # Use approximation for fractions of a subpixel. for (m=stf_r2i(r)+1; m<=np; m=m+1) { r3 = (stf_i2r (real(m)) - r) / ds if (r3 >= 1.) break Memr[profile+m-1] = Memr[profile+m-1] + r3 * r1 } # The subpixel is completely within these radii. for (; m<=np; m=m+1) Memr[profile+m-1] = Memr[profile+m-1] + r1 # Accumulate the moments above an isophote. if (r1 > miso) { xx = xx + dx2 * r1 yy = yy + dy2 * r1 xy = xy + dx1 * dy1 * r1 } } } } } } call msifree (msi) # Compute the ellipticity and position angle from the moments. r = (xx + yy) if (r > 0.) { r1 = (xx - yy) / r r2 = 2 * xy / r SFD_E(sfd) = sqrt (r1**2 + r2**2) SFD_PA(sfd) = RADTODEG (atan2 (r2, r1) / 2.) } else { SFD_E(sfd) = 0. SFD_PA(sfd) = 0. } # The magnitude and profile normalization is from the max enclosed flux. call alimr (Memr[profile], np, r, SFD_M(sfd)) if (SFD_M(sfd) <= 0.) call error (1, "Invalid flux profile") call adivkr (Memr[profile], SFD_M(sfd), Memr[profile], np) # Fit interpolator to the enclosed flux profile. call asiinit (asi, II_SPLINE3) call asifit (asi, Memr[profile], np) SFD_ASI1(sfd) = asi # Estimate a gaussian sigma (actually sqrt(2)*sigma) and if it is # it is small subtract the gaussian so that the image interpolator # can more accurately estimate subpixel values. #call stf_radius (sf, sfd, SF_LEVEL(sf), r) #sigma = r / sqrt (log (1/(1-SF_LEVEL(sf)))) call stf_radius (sf, sfd, 0.8, r) r = r / SF_SCALE(sf) sigma = 2 * r * sqrt (log(2.) / log (1/(1-0.8))) if (sigma < 5.) { if (sigma <= 2.) { call gsrestore (gs, gsdata) dx = xc - nint (xc) dy = yc - nint (yc) r = sqrt (dx * dx + dy * dy) dx = 1. ds = abs (sigma - gseval (gs, r, dx)) for (da = 1.; da <= 2.; da = da + .01) { dz = abs (sigma - gseval (gs, r, da)) if (dz < ds) { ds = dz dx = da } } sigma = dx call gsfree (gs) } sigma = sigma / (2 * sqrt (log(2.))) sigma = sigma * sigma # Compute the peak that gives the correct central pixel value. i = nint (xc) j = nint (yc) dx = i - xc dy = j - yc r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds r1 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r2 = (dx2 + dy2) / sigma if (r2 < 25.) r1 = r1 + exp (-r2) } } ptr = data + (j - y1 + 1) * nx + (i - x1 + 1) peak = (Memr[ptr] - bkgd) / (r1 * da) # Subtract the gaussian from the data. do j = y1, y2 { ptr = data + (j - y1 + 1) * nx + 1 dy = j - yc do i = x1, x2 { dx = i - xc r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds r1 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r2 = (dx2 + dy2) / sigma if (r2 < 25.) r1 = r1 + peak * exp (-r2) } } Memr[ptr] = Memr[ptr] - r1 * da ptr = ptr + 1 } } # Fit the image interpolator to the residual data. call msiinit (msi, II_BISPLINE3) call msifit (msi, Memr[data], nx, ny, nx) # Recompute the enclosed flux profile and moments # using the gaussian plus image interpolator fit to the residuals. call aclrr (Memr[profile], np) xx = 0. yy = 0. xy = 0. do j = y1, y2 { ptr = data + (j - y1 + 1) * nx + 1 dy = j - yc do i = x1, x2 { dx = i - xc r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds # Compute interpolator correction. r2 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) r2 = r2 + r1 } } r1 = Memr[ptr] - bkgd ptr = ptr + 1 r2 = r1 - r2 * da # Accumulate the enclosed flux and moments. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r3 = (dx2 + dy2) / sigma if (r3 < 25.) r3 = peak * exp (-r3) else r3 = 0. r = max (0., sqrt (dx2 + dy2) - ds / 2) if (r < radius) { r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) r1 = da * (r1 + r2 + r3) for (m=stf_r2i(r)+1; m<=np; m=m+1) { r3 = (stf_i2r (real(m)) - r) / ds if (r3 >= 1.) break Memr[profile+m-1] = Memr[profile+m-1] + r3 * r1 } for (; m<=np; m=m+1) Memr[profile+m-1] = Memr[profile+m-1] + r1 if (r1 > miso) { xx = xx + dx2 * r1 yy = yy + dy2 * r1 xy = xy + dx1 * dy1 * r1 } } } } } } call msifree (msi) # Recompute the moments, magnitude, normalized flux, and interp. r = (xx + yy) if (r > 0.) { r1 = (xx - yy) / r r2 = 2 * xy / r SFD_E(sfd) = sqrt (r1**2 + r2**2) SFD_PA(sfd) = RADTODEG (atan2 (r2, r1) / 2.) } else { SFD_E(sfd) = 0. SFD_PA(sfd) = 0. } call alimr (Memr[profile], np, r, SFD_M(sfd)) if (SFD_M(sfd) <= 0.) call error (1, "Invalid flux profile") call adivkr (Memr[profile], SFD_M(sfd), Memr[profile], np) call asifit (asi, Memr[profile], np) SFD_ASI1(sfd) = asi } # Compute derivative of enclosed flux profile and fit an image # interpolator. dx = 0.25 Memr[profile] = 0. ns = 0 do i = 1, np { r = stf_i2r (real(i)) r2 = stf_r2i (r + dx) if (r2 > np) { k = i break } r1 = stf_r2i (r - dx) if (r1 < 1) { if (i > 1) { dy = asieval (asi, real(i)) / r**2 Memr[profile] = (ns * Memr[profile] + dy) / (ns + 1) ns = ns + 1 } j = i } else { dy = (asieval (asi, r2) - asieval (asi, r1)) / (4 * r * dx) Memr[profile+i-1] = dy } } do i = 2, j Memr[profile+i-1] = (Memr[profile+j] - Memr[profile]) / j * (i - 1) + Memr[profile] do i = k, np Memr[profile+i-1] = Memr[profile+k-2] call adivkr (Memr[profile], SF_SCALE(sf)**2, Memr[profile], np) call alimr (Memr[profile], np, SFD_YP1(sfd), SFD_YP2(sfd)) call asiinit (asi, II_SPLINE3) call asifit (asi, Memr[profile], np) SFD_ASI2(sfd) = asi #SF_XP1(sf) = j+1 SF_XP1(sf) = 1 SF_XP2(sf) = k-1 call sfree (sp) end # STF_NORM -- Renormalize the enclosed flux profile. procedure stf_norm (sf, sfd, x, y) pointer sf #I Parameter structure pointer sfd #I Star structure real x #I Radius real y #I Flux int npmax, np pointer asi int i, j, k real r, r1, r2, dx, dy pointer sp, profile real asieval(), stf_i2r(), stf_r2i() errchk asifit begin npmax = SFD_NPMAX(sfd) np = SFD_NP(sfd) asi = SFD_ASI1(sfd) call smark (sp) call salloc (profile, npmax, TY_REAL) # Renormalize the enclosed flux profile. if (IS_INDEF(x) || x <= 0.) { dy = SFD_BKGD(sfd) - SFD_BKGD1(sfd) SFD_BKGD(sfd) = SFD_BKGD(sfd) - dy do i = 1, npmax Memr[profile+i-1] = asieval (asi, real(i)) + dy * stf_i2r(real(i)) ** 2 call alimr (Memr[profile], np, r1, r2) call adivkr (Memr[profile], r2, Memr[profile], npmax) } else if (IS_INDEF(y)) { r = max (1., min (real(np), stf_r2i (x))) r2 = asieval (asi, r) if (r2 <= 0.) return do i = 1, npmax Memr[profile+i-1] = asieval (asi, real(i)) call adivkr (Memr[profile], r2, Memr[profile], npmax) } else { r = max (1., min (real(np), stf_r2i (x))) r1 = asieval (asi, r) dy = (y - r1) / x ** 2 SFD_BKGD(sfd) = SFD_BKGD(sfd) - dy do i = 1, npmax Memr[profile+i-1] = asieval (asi, real(i)) + dy * stf_i2r(real(i)) ** 2 } call asifit (asi, Memr[profile], npmax) SFD_ASI1(sfd) = asi # Compute derivative of enclosed flux profile and fit an image # interpolator. dx = 0.25 do i = 1, npmax { r = stf_i2r (real(i)) r2 = stf_r2i (r + dx) if (r2 > np) { k = i break } r1 = stf_r2i (r - dx) if (r1 < 1) { if (i > 1) { dy = asieval (asi, real(i)) / r**2 Memr[profile] = dy } j = i } else { dy = (asieval (asi, r2) - asieval (asi, r1)) / (4 * r * dx) Memr[profile+i-1] = dy } } do i = 2, j Memr[profile+i-1] = (Memr[profile+j] - Memr[profile]) / j * (i - 1) + Memr[profile] do i = k, npmax Memr[profile+i-1] = Memr[profile+k-2] call adivkr (Memr[profile], SF_SCALE(sf)**2, Memr[profile], np) call alimr (Memr[profile], np, SFD_YP1(sfd), SFD_YP2(sfd)) asi = SFD_ASI2(sfd) call asifit (asi, Memr[profile], np) SFD_ASI2(sfd) = asi #SF_XP1(sf) = min (j+1, np) SF_XP1(sf) = 1 SF_XP2(sf) = min (k-1, np) call sfree (sp) end # STF_WIDTHS -- Set the widhts. procedure stf_widths (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure errchk stf_radius, stf_dfwhm, stf_fit begin call stf_radius (sf, sfd, SF_LEVEL(sf), SFD_R(sfd)) call stf_dfwhm (sf, sfd) call stf_fit (sf, sfd) switch (SF_WCODE(sf)) { case 1: SFD_W(sfd) = SFD_R(sfd) case 2: SFD_W(sfd) = SFD_DFWHM(sfd) case 3: SFD_W(sfd) = SFD_GFWHM(sfd) case 4: SFD_W(sfd) = SFD_MFWHM(sfd) } end # STF_I2R -- Compute radius from sample index. real procedure stf_i2r (i) real i #I Index real r #O Radius begin if (i < 20) r = 0.05 * i else if (i < 30) r = 0.1 * i - 1 else if (i < 40) r = 0.2 * i - 4 else if (i < 50) r = 0.5 * i - 16 else r = i - 41 return (r) end # STF_R2I -- Compute sample index from radius. real procedure stf_r2i (r) real r #I Radius real i #O Index begin if (r < 1) i = 20 * r else if (r < 2) i = 10 * (r + 1) else if (r < 4) i = 5 * (r + 4) else if (r < 9) i = 2 * (r + 16) else i = r + 41 return (i) end # STF_R2N -- Compute number of subsamples from radius. int procedure stf_r2n (r) real r #I Radius int n #O Number of subsamples begin if (r < 1) n = 20 else if (r < 2) n = 10 else if (r < 4) n = 5 else if (r < 9) n = 2 else n = 1 return (n) end # STF_MODEL -- Return model value. procedure stf_model (sf, sfd, r, profile, flux) pointer sf #I Main data structure pointer sfd #I Star data structure real r #I Radius at level real profile #I Profile value real flux #I Enclosed flux value real x, x1, x2, r1, r2, dr begin dr = 0.25 * SF_SCALE(sf) r1 = r - dr r2 = r + dr if (r1 < 0.) { r1 = dr r2 = r1 + dr } switch (SF_WCODE(sf)) { case 3: x = r**2 / (2. * SFD_SIGMA(sfd)**2) if (x < 20.) flux = 1 - exp (-x) else flux = 0. x1 = r1**2 / (2. * SFD_SIGMA(sfd)**2) x2 = r2**2 / (2. * SFD_SIGMA(sfd)**2) if (x2 < 20.) { x1 = 1 - exp (-x1) x2 = 1 - exp (-x2) } else { x1 = 1. x2 = 1. } if (r <= dr) { x1 = x1 / dr ** 2 x2 = x2 / (4 * dr ** 2) profile = (x2 - x1) / dr * r + x1 } else { profile = (x2 - x1) / (4 * r * dr) } default: x = 1 + (r / SFD_ALPHA(sfd)) ** 2 flux = 1 - x ** (1 - SFD_BETA(sfd)) x1 = 1 + (r1 / SFD_ALPHA(sfd)) ** 2 x2 = 1 + (r2 / SFD_ALPHA(sfd)) ** 2 x1 = 1 - x1 ** (1 - SFD_BETA(sfd)) x2 = 1 - x2 ** (1 - SFD_BETA(sfd)) if (r <= dr) { x1 = x1 / dr ** 2 x2 = x2 / (4 * dr ** 2) profile = (x2 - x1) / dr * r + x1 } else { profile = (x2 - x1) / (4 * r * dr) } } end # STF_DFWHM -- Direct FWHM from profile. procedure stf_dfwhm (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure int np real r, rpeak, profile, peak, asieval(), stf_i2r() pointer asi begin asi = SFD_ASI2(sfd) np = SFD_NP(sfd) rpeak = 1. peak = 0. for (r=1.; r <= np; r = r + 0.01) { profile = asieval (asi, r) if (profile > peak) { rpeak = r peak = profile } } peak = peak / 2. for (r=rpeak; r <= np && asieval (asi, r) > peak; r = r + 0.01) ; SFD_DFWHM(sfd) = 2 * stf_i2r (r) * SF_SCALE(sf) end # STF_FWHMS -- Measure FWHM vs level. procedure stf_fwhms (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure int i real level, r begin do i = 1, 19 { level = i * 0.05 call stf_radius (sf, sfd, level, r) switch (SF_WCODE(sf)) { case 3: SFD_FWHM(sfd,i) = 2 * r * sqrt (log (2.) / log (1/(1-level))) default: r = r / sqrt ((1.-level)**(1./(1.-SFD_BETA(sfd))) - 1.) SFD_FWHM(sfd,i) = 2 * r * sqrt (2.**(1./SFD_BETA(sfd))-1.) } } end # STF_RADIUS -- Measure the radius at the specified level. procedure stf_radius (sf, sfd, level, r) pointer sf #I Main data structure pointer sfd #I Star data structure real level #I Level to measure real r #O Radius int np pointer asi real f, fmax, rmax, asieval(), stf_i2r() begin np = SFD_NP(sfd) asi = SFD_ASI1(sfd) for (r=1; r <= np && asieval (asi, r) < level; r = r + 0.01) ; if (r > np) { fmax = 0. rmax = 0. for (r=1; r <= np; r = r + 0.01) { f = asieval (asi, r) if (f > fmax) { fmax = f rmax = r } } r = rmax } r = stf_i2r (r) * SF_SCALE(sf) end # STF_FIT -- Fit models to enclosed flux. procedure stf_fit (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure int i, j, n, np, pfit[2] real beta, z, params[3] pointer asi, nl pointer sp, x, y, w int locpr() real asieval(), stf_i2r() extern stf_gauss1(), stf_gauss2(), stf_moffat1(), stf_moffat2() errchk nlinitr, nlfitr data pfit/2,3/ begin np = SFD_NP(sfd) asi = SFD_ASI1(sfd) call smark (sp) call salloc (x, np, TY_REAL) call salloc (y, np, TY_REAL) call salloc (w, np, TY_REAL) n = 0 j = 0 do i = 1, np { z = 1. - max (0., asieval (asi, real(i))) if (n > np/3 && z < 0.5) break if ((n < np/3 && z > 0.01) || z > 0.5) j = n Memr[x+n] = stf_i2r (real(i)) * SF_SCALE(sf) Memr[y+n] = z Memr[w+n] = 1. n = n + 1 } # Gaussian. np = 1 params[2] = Memr[x+j] / sqrt (2. * log (1./min(0.99,Memr[y+j]))) params[1] = 1 call nlinitr (nl, locpr (stf_gauss1), locpr (stf_gauss2), params, params, 2, pfit, np, .001, 100) call nlfitr (nl, Memr[x], Memr[y], Memr[w], n, 1, WTS_USER, i) if (i != SINGULAR && i != NO_DEG_FREEDOM) { call nlpgetr (nl, params, i) if (params[2] < 0.) params[2] = Memr[x+j] / sqrt (2. * log (1./min(0.99,Memr[y+j]))) } SFD_SIGMA(sfd) = params[2] SFD_GFWHM(sfd) = 2 * SFD_SIGMA(sfd) * sqrt (2. * log (2.)) # Moffat. if (SF_BETA(sf) < 1.1) { call nlfreer (nl) call sfree (sp) call error (1, "Cannot measure FWHM - Moffat beta too small") } beta = SF_BETA(sf) if (IS_INDEFR(beta)) { beta = 2.5 np = 2 } else { np = 1 } params[3] = 1 - beta params[2] = Memr[x+j] / sqrt (min(0.99,Memr[y+j])**(1./params[3]) - 1.) params[1] = 1 call nlinitr (nl, locpr (stf_moffat1), locpr (stf_moffat2), params, params, 3, pfit, np, .001, 100) call nlfitr (nl, Memr[x], Memr[y], Memr[w], n, 1, WTS_USER, i) if (i != SINGULAR && i != NO_DEG_FREEDOM) { call nlpgetr (nl, params, i) if (params[2] < 0.) { params[3] = 1. - beta params[2] = Memr[x+j] / sqrt (min(0.99,Memr[y+j])**(1./params[3]) - 1.) } } SFD_ALPHA(sfd) = params[2] SFD_BETA(sfd) = 1 - params[3] SFD_MFWHM(sfd) = 2 * SFD_ALPHA(sfd) * sqrt (2.**(1./SFD_BETA(sfd))-1.) call nlfreer (nl) call sfree (sp) end # STF_GAUSS1 -- Gaussian function used in NLFIT. The parameters are the # amplitude and sigma and the input variable is the radius. procedure stf_gauss1 (x, nvars, p, np, z) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector int np #I Number of parameters real z #O Function return real r2 begin r2 = x[1]**2 / (2 * p[2]**2) if (abs (r2) > 20.) z = 0. else z = p[1] * exp (-r2) end # STF_GAUSS2 -- Gaussian function and derivatives used in NLFIT. The parameters # are the amplitude and sigma and the input variable is the radius. procedure stf_gauss2 (x, nvars, p, dp, np, z, der) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector real dp[np] #I Dummy array of parameters increments int np #I Number of parameters real z #O Function return real der[np] #O Derivatives real r2 begin r2 = x[1]**2 / (2 * p[2]**2) if (abs (r2) > 20.) { z = 0. der[1] = 0. der[2] = 0. } else { der[1] = exp (-r2) z = p[1] * der[1] der[2] = z * 2 * r2 / p[2] } end # STF_MOFFAT1 -- Moffat function used in NLFIT. The parameters are the # amplitude, alpha squared, and beta and the input variable is the radius. procedure stf_moffat1 (x, nvars, p, np, z) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector int np #I Number of parameters real z #O Function return real y begin y = 1 + (x[1] / p[2]) ** 2 if (abs (y) > 20.) z = 0. else z = p[1] * y ** p[3] end # STF_MOFFAT2 -- Moffat function and derivatives used in NLFIT. The # parameters are the amplitude, alpha squared, and beta and the input # variable is the radius. procedure stf_moffat2 (x, nvars, p, dp, np, z, der) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector real dp[np] #I Dummy array of parameters increments int np #I Number of parameters real z #O Function return real der[np] #O Derivatives real y begin y = 1 + (x[1] / p[2]) ** 2 if (abs (y) > 20.) { z = 0. der[1] = 0. der[2] = 0. der[3] = 0. } else { der[1] = y ** p[3] z = p[1] * der[1] der[2] = -2 * z / y * p[3] / p[2] * (x[1] / p[2]) ** 2 der[3] = z * log (y) } end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/t_imexam.x�����������������������������������������0000664�0000000�0000000�00000022336�13321663143�0022776�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include include "imexam.h" include "mscexam.h" define HELP "mscdisplay$src/imexam/imexamine.key" define PROMPT "imexamine options" define SZ_IMLIST 512 # T_IMEXAMINE -- Examine images using image display, graphics, and text output. procedure t_imexamine () real x, y pointer sp, cmd, imname, imlist, gp, ie, im, instrument int curtype, key, redraw, mode, nframes, nargs bool clgetb() pointer gopen(), ie_gimage() int imtopen(), ie_gcur(), ie_getnframes() int btoi(), clgeti(), imtlen() int imtgetim() begin call smark (sp) call salloc (ie, IE_LEN, TY_STRUCT) call salloc (cmd, SZ_LINE, TY_CHAR) call salloc (imname, SZ_FNAME, TY_CHAR) call salloc (imlist, SZ_IMLIST, TY_CHAR) call salloc (instrument, SZ_FNAME, TY_CHAR) # Initilize mosaic stuff: instrument file, amp, and processing stuff. #call clgstr ("instrument", Memc[instrument], SZ_FNAME) Memc[instrument] = EOS call hdmopen (Memc[instrument]) call ampset() call procset() # Initialize the imexamine descriptor. call aclri (Memi[ie], IE_LEN) # Determine if we will be accessing the image display, and if so, # the maximum number of frames to be accessed. IE_USEDISPLAY(ie) = btoi (clgetb ("use_display")) if (IE_USEDISPLAY(ie) == YES) iferr (nframes = ie_getnframes (ie)) { call eprintf ("cannot access display\n") IE_USEDISPLAY(ie) = NO } # Get the list of images to be examined, if given on the command # line. If no images are explicitly listed use the display to # determine the images to be examined. nargs = clgeti ("$nargs") if (nargs > 0) { call clgstr ("input", Memc[imlist], SZ_IMLIST) IE_LIST(ie) = imtopen (Memc[imlist]) IE_LISTLEN(ie) = imtlen (IE_LIST(ie)) IE_INDEX(ie) = 1 if (nargs > 1) { # Set user specified display frame. IE_DFRAME(ie) = clgeti ("frame") IE_NEWFRAME(ie) = IE_DFRAME(ie) if (IE_USEDISPLAY(ie) == YES) { nframes = max (IE_NEWFRAME(ie), nframes) IE_NFRAMES(ie) = nframes } } else { # If we have to display an image and no frame was specified, # default to frame 1 (should use the current display frame # but we don't have a cursor read yet to tell us what it is). IE_DFRAME(ie) = 1 IE_NEWFRAME(ie) = 1 } } else { IE_INDEX(ie) = 1 IE_DFRAME(ie) = 1 IE_NEWFRAME(ie) = 1 } # Set the wcs, logfile and graphics. call clgstr ("wcs", IE_WCSNAME(ie), IE_SZFNAME) IE_LOGFD(ie) = NULL call clgstr ("logfile", IE_LOGFILE(ie), IE_SZFNAME) if (clgetb ("keeplog")) iferr (call ie_openlog (ie)) call erract (EA_WARN) call clgstr ("graphics", Memc[cmd], SZ_LINE) gp = gopen (Memc[cmd], NEW_FILE+AW_DEFER, STDGRAPH) # Initialize the data structure. IE_IM(ie) = NULL IE_DS(ie) = NULL IE_PP(ie) = NULL IE_MAPFRAME(ie) = 0 IE_NFRAMES(ie) = nframes IE_ALLFRAMES(ie) = btoi (clgetb ("allframes")) IE_GTYPE(ie) = NULL IE_XORIGIN(ie) = 0. IE_YORIGIN(ie) = 0. # Access the first image. If an image list was specified and the # display is being used, this will set the display frame to the first # image listed, or display the first image if not already loaded into # the display. if (IE_LIST(ie) != NULL) im = ie_gimage (ie, YES) # Enter the cursor loop. The commands are returned by the # IE_GCUR procedure. x = 1. y = 1. redraw = NO curtype = 'i' mode = NEW_FILE while (ie_gcur (ie, curtype, x,y, key, Memc[cmd], SZ_LINE) != EOF) { # Check to see if the user has changed frames on us while in # examine-image-list mode. if (IE_USEDISPLAY(ie) == YES && IE_LIST(ie) != NULL && IE_NEWFRAME(ie) != IE_MAPFRAME(ie)) { call ie_imname (IE_DS(ie), IE_NEWFRAME(ie), Memc[imname], SZ_FNAME) call ie_addimage (ie, Memc[imname], imlist) } # Set workstation state. switch (key) { case 'a', 'b', 'd', 'm', 't', 'w', 'x', 'y', 'z', ',': call gdeactivate (gp, 0) } # Act on the command key. switch (key) { case '?': # Print help call gpagefile (gp, HELP, PROMPT) case ':': # Process colon commands call ie_colon (ie, Memc[cmd], gp, redraw) if (redraw == YES) { x = INDEF y = INDEF } case 'f': # Redraw frame redraw = YES x = INDEF y = INDEF case 'a': # Aperture photometry call ie_rimexam (NULL, NULL, ie, x, y) case ',': # Aperture photometry call ie_qrimexam (NULL, NULL, ie, x, y) case 'b': # Print image region coordinates call printf ("%4d %4d %4d %4d\n") call pargi (IE_IX1(ie)) call pargi (IE_IX2(ie)) call pargi (IE_IY1(ie)) call pargi (IE_IY2(ie)) if (IE_LOGFD(ie) != NULL) { call fprintf (IE_LOGFD(ie), "%4d %4d %4d %4d\n") call pargi (IE_IX1(ie)) call pargi (IE_IX2(ie)) call pargi (IE_IY1(ie)) call pargi (IE_IY2(ie)) } case 'c','e','h','j','k','s','l','r','u','v','.': # Graphs IE_GTYPE(ie) = key redraw = YES case 'd': # Load the display. # Query the user for the frame to be loaded, the current # display frame being the default. call clgstr ("image", Memc[imname], SZ_FNAME) call clputi ("frame", IE_NEWFRAME(ie)) IE_DFRAME(ie) = clgeti ("frame") IE_NEWFRAME(ie) = IE_DFRAME(ie) if (IE_LIST(ie) != NULL) call ie_addimage (ie, Memc[imname], imlist) else call ie_display (ie, Memc[imname], IE_DFRAME(ie)) case 'g': # Graphics cursor curtype = 'g' case 'i': # Image cursor curtype = 'i' case 'm': # Image statistics call ie_statistics (ie, x, y) case 'n': # Next frame if (IE_LIST(ie) != NULL) { IE_INDEX(ie) = IE_INDEX(ie) + 1 if (IE_INDEX(ie) > IE_LISTLEN(ie)) IE_INDEX(ie) = 1 } else { IE_NEWFRAME(ie) = IE_NEWFRAME(ie) + 1 if (IE_NEWFRAME(ie) > IE_NFRAMES(ie)) IE_NEWFRAME(ie) = 1 } im = ie_gimage (ie, YES) case 'o': # Overplot mode = APPEND case 'p': # Previous frame if (IE_LIST(ie) != NULL) { IE_INDEX(ie) = IE_INDEX(ie) - 1 if (IE_INDEX(ie) <= 0) IE_INDEX(ie) = IE_LISTLEN(ie) } else { IE_NEWFRAME(ie) = IE_NEWFRAME(ie) - 1 if (IE_NEWFRAME(ie) <= 0) IE_NEWFRAME(ie) = IE_NFRAMES(ie) } im = ie_gimage (ie, YES) case 'q': # Quit break case 't': # Extract a section. call ie_timexam (ie, x, y) case 'w': # Toggle logfile if (IE_LOGFD(ie) == NULL) { if (IE_LOGFILE(ie) == EOS) call printf ("No log file defined\n") else { iferr (call ie_openlog (ie)) call erract (EA_WARN) } } else { call close (IE_LOGFD(ie)) IE_LOGFD(ie) = NULL call printf ("Logfile %s closed\n") call pargstr (IE_LOGFILE(ie)) } case 'x', 'y': # Positions call ie_pos (ie, x, y, key) case 'z': # Print grid call ie_print (ie, x, y) case 'I': # Immediate interrupt call fatal (1, "Interrupt") default: # Unrecognized command call printf ("\007") } switch (key) { case '?', 'a', 'b', 'd', 'm', 'w', 'x', 'y', 'z', ',': IE_LASTKEY(ie) = key } # Draw or overplot a graph. if (redraw == YES) { switch (IE_GTYPE(ie)) { case 'c': # column plot call ie_cimexam (gp, mode, ie, x) case 'e': # contour plot call ie_eimexam (gp, mode, ie, x, y) case 'h': # histogram plot call ie_himexam (gp, mode, ie, x, y) case 'j': # line plot call ie_jimexam (gp, mode, ie, x, y, 1) case 'k': # line plot call ie_jimexam (gp, mode, ie, x, y, 2) case 'l': # line plot call ie_limexam (gp, mode, ie, y) case 'r': # radial profile plot call ie_rimexam (gp, mode, ie, x, y) case 's': # surface plot call ie_simexam (gp, mode, ie, x, y) case 'u', 'v': # vector cut plot call ie_vimexam (gp, mode, ie, x, y, IE_GTYPE(ie)) case '.': # radial profile plot call ie_qrimexam (gp, mode, ie, x, y) } redraw = NO mode = NEW_FILE } } # Finish up. call gclose (gp) if (IE_IM(ie) != NULL) call imunmap (IE_IM(ie)) if (IE_MW(ie) != NULL) call mw_close (IE_MW(ie)) if (IE_PP(ie) != NULL) call clcpset (IE_PP(ie)) if (IE_DS(ie) != NULL) call IMUNMAP (IE_DS(ie)) if (IE_LOGFD(ie) != NULL) call close (IE_LOGFD(ie)) if (IE_LIST(ie) != NULL) call imtclose (IE_LIST(ie)) call hdmclose () call ampfree () call sfree (sp) end # IE_ADDIMAGE -- Add an image to the image list if not already present in # the list, and display the image. procedure ie_addimage (ie, image, imlist) pointer ie #I imexamine descriptor char image[ARB] #I image name pointer imlist #I image list int i bool inlist pointer im, sp, lname pointer ie_gimage(), imtopen() int imtrgetim(), imtlen() bool streq() begin call smark (sp) call salloc (lname, SZ_FNAME, TY_CHAR) # Is image already in list? inlist = false do i = 1, IE_LISTLEN(ie) { if (imtrgetim (IE_LIST(ie), i, Memc[lname], SZ_FNAME) > 0) if (streq (Memc[lname], image)) { inlist = true IE_INDEX(ie) = i break } } # Add to list if missing. if (!inlist) { call strcat (",", Memc[imlist], SZ_IMLIST) call strcat (image, Memc[imlist], SZ_IMLIST) call imtclose (IE_LIST(ie)) IE_LIST(ie) = imtopen (Memc[imlist]) IE_LISTLEN(ie) = imtlen (IE_LIST(ie)) IE_INDEX(ie) = IE_LISTLEN(ie) } # Display the image. im = ie_gimage (ie, YES) call sfree (sp) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/imexam/vimexam2.par���������������������������������������0000664�0000000�0000000�00000002006�13321663143�0023226�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������banner,b,h,yes,,,"Standard banner" title,s,h,"",,,"Title" xlabel,s,h,"Vector Distance",,,"X-axis label" ylabel,s,h,"Pixel Value",,,"Y-axis label" naverage,i,h,1,1,,"averaging width of strip" boundary,s,h,"constant",constant|nearest|reflect|wrap|project,,"type of boundary extension to use" constant,r,h,0.,,,"the constant for constant-valued boundary extension" x1,r,h,INDEF,,,X-axis window limit x2,r,h,INDEF,,,X-axis window limit y1,r,h,INDEF,,,Y-axis window limit y2,r,h,INDEF,,,Y-axis window limit pointmode,b,h,no,,,plot points instead of lines? marker,s,h,"plus",,,point marker character? szmarker,r,h,1.,,,marker size logx,b,h,no,,,log scale x-axis logy,b,h,no,,,log scale y-axis box,b,h,yes,,,draw box around periphery of window ticklabels,b,h,yes,,,label tick marks majrx,i,h,5,,,number of major divisions along x grid minrx,i,h,5,,,number of minor divisions along x grid majry,i,h,5,,,number of major divisions along y grid minry,i,h,5,,,number of minor divisions along y grid round,b,h,no,,,round axes to nice values? ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/lbias.com�������������������������������������������������0000664�0000000�0000000�00000000361�13321663143�0021306�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# LINEBIAS.COM -- Common block used to pass parameters to linebias int itmax # Maximum number of rejection iterations real ksigma # K-sigma clipping factor real sigcor # Correction to K-clipped sigma common /lbias/ itmax, ksigma, sigcor �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/linebias.gx�����������������������������������������������0000664�0000000�0000000�00000002007�13321663143�0021641�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "mosgeom.h" # SET_LINEBIAS -- Set up parameters for linebias routine in common /linebias/ procedure set_linebias () int clgeti() real clgetr() double signorm() include "lbias.com" begin itmax = clgeti ("niterate") ksigma = max (clgetr ("low_reject"), clgetr ("high_reject")) sigcor = real (signorm (double (ksigma))) end $for (silrd) # LINEBIASx -- Calculate bias level for current line as k-clipped mean across # overscan strip real procedure linebias$t (data, npix) PIXEL data[ARB] #I Overscan vector int npix #I Number of overscan pixels real bias #O Computed Bias level. int ngpix $if (datatype == dl) double mean, sigma, kclip, corr $else real mean, sigma, kclip, corr $endif int akavr$t() errchk akavr$t() include "lbias.com" begin if (npix <=0) return (0.0) $if (datatype == dl) kclip = double(ksigma) corr = double(sigcor) $else kclip = ksigma corr = sigcor $endif ngpix = akavr$t (data, npix, mean, sigma, kclip, corr, itmax) bias = real(mean) return (bias) end $endfor �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/linebias.x������������������������������������������������0000664�0000000�0000000�00000005606�13321663143�0021502�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "mosgeom.h" # SET_LINEBIAS -- Set up parameters for linebias routine in common /linebias/ procedure set_linebias () int clgeti() real clgetr() double signorm() include "lbias.com" begin itmax = clgeti ("niterate") ksigma = max (clgetr ("low_reject"), clgetr ("high_reject")) sigcor = real (signorm (double (ksigma))) end # LINEBIASx -- Calculate bias level for current line as k-clipped mean across # overscan strip real procedure linebiass (data, npix) short data[ARB] #I Overscan vector int npix #I Number of overscan pixels real bias #O Computed Bias level. int ngpix real mean, sigma, kclip, corr int akavrs() errchk akavrs() include "lbias.com" begin if (npix <=0) return (0.0) kclip = ksigma corr = sigcor ngpix = akavrs (data, npix, mean, sigma, kclip, corr, itmax) bias = real(mean) return (bias) end # LINEBIASx -- Calculate bias level for current line as k-clipped mean across # overscan strip real procedure linebiasi (data, npix) int data[ARB] #I Overscan vector int npix #I Number of overscan pixels real bias #O Computed Bias level. int ngpix real mean, sigma, kclip, corr int akavri() errchk akavri() include "lbias.com" begin if (npix <=0) return (0.0) kclip = ksigma corr = sigcor ngpix = akavri (data, npix, mean, sigma, kclip, corr, itmax) bias = real(mean) return (bias) end # LINEBIASx -- Calculate bias level for current line as k-clipped mean across # overscan strip real procedure linebiasl (data, npix) long data[ARB] #I Overscan vector int npix #I Number of overscan pixels real bias #O Computed Bias level. int ngpix double mean, sigma, kclip, corr int akavrl() errchk akavrl() include "lbias.com" begin if (npix <=0) return (0.0) kclip = double(ksigma) corr = double(sigcor) ngpix = akavrl (data, npix, mean, sigma, kclip, corr, itmax) bias = real(mean) return (bias) end # LINEBIASx -- Calculate bias level for current line as k-clipped mean across # overscan strip real procedure linebiasr (data, npix) real data[ARB] #I Overscan vector int npix #I Number of overscan pixels real bias #O Computed Bias level. int ngpix real mean, sigma, kclip, corr int akavrr() errchk akavrr() include "lbias.com" begin if (npix <=0) return (0.0) kclip = ksigma corr = sigcor ngpix = akavrr (data, npix, mean, sigma, kclip, corr, itmax) bias = real(mean) return (bias) end # LINEBIASx -- Calculate bias level for current line as k-clipped mean across # overscan strip real procedure linebiasd (data, npix) double data[ARB] #I Overscan vector int npix #I Number of overscan pixels real bias #O Computed Bias level. int ngpix double mean, sigma, kclip, corr int akavrd() errchk akavrd() include "lbias.com" begin if (npix <=0) return (0.0) kclip = double(ksigma) corr = double(sigcor) ngpix = akavrd (data, npix, mean, sigma, kclip, corr, itmax) bias = real(mean) return (bias) end ��������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/maskcolor.x�����������������������������������������������0000664�0000000�0000000�00000024772�13321663143�0021713�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include "ace.h" define COLORS "|black|white|red|green|blue|yellow|cyan|magenta|transparent|" define DEFCOLOR 203 # MASKCOLOR_MAP -- Create the mask colormap object. pointer procedure xmaskcolor_map (colorstring) char colorstring #I Color specification string pointer colors #O Mask colormap object int i, j, ip, ncolors, token, lasttoken, maskval1, maskval2, color, offset int strdic(), ctoi(), nowhite() pointer sp, str, op int coltrans[9] data coltrans/202,203,204,205,206,207,208,209,-1/ define err_ 10 begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) # If the colorstring is an expression just save the string # and set the number of colors to 0. i = nowhite (colorstring, Memc[str], SZ_LINE) if (Memc[str] == '(') { call malloc (colors, SZ_LINE, TY_INT) call malloc (op, LEN_OPERAND, TY_STRUCT) Memi[colors] = 0 Memi[colors+1] = op call strcpy (colorstring, Memc[P2C(colors+2)], SZ_LINE) O_TYPE(op) = TY_INT O_VALP(op) = NULL O_FLAGS(op) = O_FREEOP # Check expression here. return (colors) } # Allocate memory for the colormap object. call malloc (colors, 4*10, TY_INT) # Initialize ncolors = 1 maskval1 = INDEFI maskval2 = INDEFI color = DEFCOLOR offset = NO Memi[colors] = ncolors Memi[colors+2] = color Memi[colors+3] = offset # Parse the color specification. token = 0 call sscan (colorstring) repeat { lasttoken = token call gargtok (token, Memc[str], SZ_LINE) switch (token) { case TOK_IDENTIFIER: call strlwr (Memc[str]) i = strdic (Memc[str], Memc[str], SZ_LINE, COLORS) if (i == 0) goto err_ color = coltrans[i] case TOK_NUMBER: if (lasttoken == TOK_NUMBER) { if (Memc[str] != '-') goto err_ ip = 2 if (ctoi (Memc[str], ip, maskval2) == 0) goto err_ } else { if (Memc[str] == '+') { offset = YES ip = 2 } else if (Memc[str] == '-') { offset = YES ip = 1 } else ip = 1 if (ctoi (Memc[str], ip, color) == 0) goto err_ if (lasttoken != TOK_OPERATOR) maskval2 = color } case TOK_OPERATOR: if (Memc[str] != '=' || lasttoken != TOK_NUMBER) goto err_ maskval1 = min (color, maskval2) maskval2 = max (color, maskval2) if (Memc[str+1] == '+') { call gargtok (token, Memc[str+2], SZ_LINE) offset = YES ip = 3 if (ctoi (Memc[str], ip, color) == 0) goto err_ } else if (Memc[str+1] == '-') { call gargtok (token, Memc[str+2], SZ_LINE) offset = YES ip = 2 if (ctoi (Memc[str], ip, color) == 0) goto err_ } case TOK_PUNCTUATION, TOK_EOS: if (Memc[str] != ',' && Memc[str] != EOS) goto err_ if (!IS_INDEFI(maskval1)) { do i = 2, ncolors { j = 4 * i - 4 if (Memi[colors+j] == maskval1 && Memi[colors+j+1] == maskval2) break } if (i > ncolors) { if (mod (ncolors, 10) == 0) call realloc (colors, 4*(ncolors+10), TY_INT) ncolors = ncolors + 1 } j = 4 * i - 4 Memi[colors+j] = maskval1 Memi[colors+j+1] = maskval2 Memi[colors+j+2] = color Memi[colors+j+3] = offset } else { Memi[colors+2] = color Memi[colors+3] = offset } if (token == TOK_EOS) break maskval1 = INDEFI maskval2 = INDEFI offset = NO default: goto err_ } } Memi[colors] = ncolors call sfree (sp) return (colors) err_ call mfree (colors, TY_INT) call sfree (sp) call error (1, "Error in color specifications") end # MASKCOLOR_FREE -- Free the mask color object. procedure xmaskcolor_free (colors) pointer colors #I Mask colormap object begin if (Memi[colors] == 0) call evvfree (Memi[colors+1]) call mfree (colors, TY_INT) end # MASKCOLOR -- Return a color for a mask value. int procedure xmaskcolor (colors, maskval) pointer colors #I Mask colormap object int maskval #I Mask value int color #O Color value int i, j, offset begin # If there is no color array return the mask value. if (Memi[colors] == 0) return (maskval) color = Memi[colors+2] offset = Memi[colors+3] do i = 2, Memi[colors] { j = 4 * i - 4 if (maskval >= Memi[colors+j] && maskval <= Memi[colors+j+1]) { color = Memi[colors+j+2] offset = Memi[colors+j+3] break } } if (offset == YES) color = maskval + color return (color) end procedure xmaskexprn (colors, maskvals, nmaskvals) pointer colors #I Mask colormap object pointer maskvals #O Pointer to mask values (TY_INT) int nmaskvals #I Number of mask values int i pointer op, o, evvexpr() errchk evvexpr int locpr extern xmaskoperand, xmaskfunc begin if (Memi[colors] > 0) return op = Memi[colors+1] O_LEN(op) = nmaskvals O_VALP(op) = maskvals o = evvexpr (Memc[P2C(colors+2)], locpr(xmaskoperand), op, locpr(xmaskfunc), NULL, O_FREEOP) #call amovi (Memi[O_VALP(o)], Memi[maskvals], nmaskvals) switch (O_TYPE(o)) { case TY_SHORT: do i = 0, O_LEN(o) { if (Memi[maskvals+i] > 0) Memi[maskvals+i] = max (0, Mems[O_VALP(o)+i]) } case TY_BOOL, TY_INT: do i = 0, O_LEN(o) { if (Memi[maskvals+i] > 0) Memi[maskvals+i] = max (0, Memi[O_VALP(o)+i]) } case TY_REAL: do i = 0, O_LEN(o) { if (Memi[maskvals+i] > 0) Memi[maskvals+i] = max (0, nint(Memr[O_VALP(o)+i])) } case TY_DOUBLE: do i = 0, O_LEN(o) { if (Memi[maskvals+i] > 0) Memi[maskvals+i] = max (0, nint(Memd[O_VALP(o)+i])) } } call evvfree (o) end # MASKOPERAND -- Handle mask expression operands. procedure xmaskoperand (op, operand, o) pointer op #I Input operand pointer char operand[ARB] #I Operand name pointer o #O Operand object char str[10] int i, coltrans[9], strdic() data coltrans/202,203,204,205,206,207,208,209,-1/ begin if (operand[1] == '$') { call xvv_initop (o, O_LEN(op), O_TYPE(op)) call amovi (Memi[O_VALP(op)], Memi[O_VALP(o)], O_LEN(op)) return } call strcpy (operand, str, 11) call strlwr (str) i = strdic (str, str, 11, COLORS) if (i > 0) { call xvv_initop (o, 0, TY_INT) O_VALI(o) = coltrans[i] return } call xvv_error1 ("Unknown mask operand %s", operand) end define KEYWORDS "|acenum|colors|" define F_ACENUM 1 # acenum (maskcodes,[flags]) define F_COLORS 2 # colors (maskcodes,[col1,col2,col3]) # MASKFUNC -- Special processing functions. procedure xmaskfunc (data, func, args, nargs, val) pointer data #I client data char func[ARB] #I function to be called pointer args[ARB] #I pointer to arglist descriptor int nargs #I number of arguments pointer val #O output operand (function value) char str[12] int i, j, c1, c2, c3 int iresult, optype, oplen, opcode, v_nargs double dresult bool strne() int strdic(), btoi(), andi() errchk malloc begin # Lookup the function name in the dictionary. An exact match is # required (strdic permits abbreviations). Abort if the function # is not known. opcode = strdic (func, str, 12, KEYWORDS) if (strne (func, str)) call xvv_error1 ("unknown function `%s' called", func) # Verify correct number of arguments. switch (opcode) { case F_ACENUM, F_COLORS: v_nargs = -1 default: v_nargs = 1 } if (v_nargs > 0 && nargs != v_nargs) call xvv_error2 ("function `%s' requires %d arguments", func, v_nargs) else if (v_nargs < 0 && nargs < abs(v_nargs)) call xvv_error2 ("function `%s' requires at least %d arguments", func, abs(v_nargs)) # Group some common operations. switch (opcode) { case F_ACENUM: # Check types of arguments. if (O_TYPE(args[1]) != TY_INT) call xvv_error1 ("error in argument types for function `%s'", func) if (nargs > 1) { if (O_TYPE(args[2]) != TY_CHAR) call xvv_error1 ( "error in argument types for function `%s'", func) } optype = TY_INT oplen = O_LEN(args[1]) if (oplen > 0) call malloc (iresult, oplen, TY_INT) case F_COLORS: # Check types of arguments. do i = 1, nargs { if (O_TYPE(args[i]) != TY_INT) call xvv_error1 ("function `%s' requires integer arguments", func) } optype = TY_INT oplen = O_LEN(args[1]) if (oplen > 0) call malloc (iresult, oplen, TY_INT) } # Evaluate the function. switch (opcode) { case F_ACENUM: if (nargs == 1) call strcpy ("BDEG", str, 12) else call strcpy (O_VALC(args[2]), str, 12) call strupr (str) c1 = 0; c2 = 0 for (i=1; str[i]!=EOS; i=i+1) { switch (str[i]) { case 'B': c1 = c1 + MASK_BP case 'D': c2 = c2 + MASK_GRW + MASK_SPLIT case 'E': c1 = c1 + MASK_BNDRY case 'F': c1 = c1 + MASK_BPFLAG case 'G': c1 = c1 + MASK_GRW case 'S': c1 = c1 + MASK_SPLIT } } if (oplen == 0) { i = O_VALI(args[1]) if (i > 10) { if (andi(i,c1)!=0 && andi(i,c2)==0) i = MNUM(i) else i = -1 } else i = 0 iresult = i } else { do j = 0, oplen-1 { i = Memi[O_VALP(args[1])+j] if (i > 10) { if (andi(i,c1)!=0) i = MNUM(i) else if (c2 != 0 && i <= MASK_NUM) i = MNUM(i) else i = -1 } else i = 0 Memi[iresult+j] = i } } case F_COLORS: c1 = 0; c2 = 204; c3 = 217 if (nargs > 1) c1 = O_VALI(args[2]) if (nargs > 2) { c2 = O_VALI(args[3]) c3 = c2 } if (nargs > 3) c3 = O_VALI(args[4]) if (c3 < c2) { i = c2; c2 = c3; c3 = i } c3 = c3 - c2 + 1 optype = TY_INT oplen = O_LEN(args[1]) if (oplen == 0) { i = O_VALI(args[1]) if (i == 0) i = c1 else if (i > 0) i = c2 + mod (i-1, c3) iresult = i } else { do j = 0, oplen-1 { i = Memi[O_VALP(args[1])+j] if (i == 0) i = c1 else if (i > 0) i = c2 + mod (i-1, c3) Memi[iresult+j] = i } } } # Write the result to the output operand. Bool results are stored in # iresult as an integer value, string results are stored in iresult as # a pointer to the output string, and integer and real/double results # are stored in iresult and dresult without any tricks. call xvv_initop (val, oplen, optype) if (oplen == 0) { switch (optype) { case TY_BOOL: O_VALI(val) = btoi (iresult != 0) case TY_CHAR: O_VALP(val) = iresult case TY_INT: O_VALI(val) = iresult case TY_REAL: O_VALR(val) = dresult case TY_DOUBLE: O_VALD(val) = dresult } } else { O_VALP(val) = iresult O_FLAGS(val) = O_FREEVAL } # Free any storage used by the argument list operands. do i = 1, nargs call xvv_freeop (args[i]) end ������mscred-5.05-2018.07.09/src/mscdisplay/src/maxmin.x��������������������������������������������������0000664�0000000�0000000�00000002460�13321663143�0021200�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include include "mosgeom.h" # MAXMIN -- Get sampled minimum and maximum pixel values in the TRIMSECTION # of an image. The image is sampled on an even grid and the min and max # values of this sample are returned. procedure maxmin (im, mg, zmin, zmax, nsample_lines) pointer im # IMIO pointer for input image pointer mg # Mosgeom pointer for image real zmin, zmax # min and max intensity values int nsample_lines # amount of image to sample int start, step, ncols, nlines, sample_size, imlines, i real minval, maxval pointer mscl2r() #include "iis.com" begin ncols = TX2(mg) - TX1(mg) + 1 nlines = TY2(mg) - TY1(mg) + 1 zmin = MAX_REAL zmax = -MAX_REAL # Try to include a constant number of pixels in the sample # regardless of the image size. The entire image is used if we # have a small image, and at least sample_lines lines are read # if we have a large image. sample_size = ncols * nsample_lines imlines = min(nlines, max(nsample_lines, sample_size / ncols)) step = nlines / (imlines + 1) start = TY1(mg) + step / 2 do i = start, nlines, max (1, step) { call alimr (Memr[mscl2r(mg,i)], ncols, minval, maxval) zmin = min (zmin, minval) zmax = max (zmax, maxval) } end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/migl2.gx��������������������������������������������������0000664�0000000�0000000�00000006727�13321663143�0021102�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosim.h" include "mosgeom.h" include "mosproc.h" $for (silrd) # MIGL2x -- Get and process line from sub-image of mosaic. pointer procedure migl2$t (mi, linein) pointer mi #I MOSIM Pointer for mosaic. int linein #I Line required. pointer obuf #O pointer to data values pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int line int onx, ony, ocx1, ocx2, ocy1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, iline, nx, image, novr pointer mscl2$t() errchk mscl2$t, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) line = linein + ocy1 if (line < ocy1 || line > ocy2) { call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) } # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_PIXEL) MI_SB(mi) = sb SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_PIXEL } else { sb = MI_SB(mi) # The required data is already in the buffer if ((SB_Y1(sb) == line) && (SB_Y2(sb) == line) && (SB_X1(sb) == ocx1) && (SB_X2(sb) == ocx2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_PIXEL) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, onx, TY_PIXEL) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achts$t (Mems[SB_DATA(sb)], Mem$t[obuf], onx) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], onx) case TY_INT: call achti$t (Memi[SB_DATA(sb)], Mem$t[obuf], onx) case TY_LONG: call achtl$t (Meml[SB_DATA(sb)], Mem$t[obuf], onx) case TY_REAL: call achtr$t (Memr[SB_DATA(sb)], Mem$t[obuf], onx) case TY_DOUBLE: call achtd$t (Memd[SB_DATA(sb)], Mem$t[obuf], onx) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_PIXEL call pargi (SB_DATA(sb)) return (SB_DATA(sb)) } } else { # Free old and allocate new data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_PIXEL) SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_PIXEL } } # Fill output buffer from input images. # # Initialise buffer with blank value call amovk$t (PIXEL(blank), Mem$t[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) iline = line - (icy1 - ocy1) + idy1 - 1 ibuf = mscl2$t (img, iline) # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miproc$t (img, Mem$t[iptr], Mem$t[optr], nx, iline, Mem$t[ovr], novr) } return (SB_DATA(sb)) end $endfor �����������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/migl2.x���������������������������������������������������0000664�0000000�0000000�00000041434�13321663143�0020725�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosim.h" include "mosgeom.h" include "mosproc.h" # MIGL2x -- Get and process line from sub-image of mosaic. pointer procedure migl2s (mi, linein) pointer mi #I MOSIM Pointer for mosaic. int linein #I Line required. pointer obuf #O pointer to data values pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int line int onx, ony, ocx1, ocx2, ocy1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, iline, nx, image, novr pointer mscl2s() errchk mscl2s, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) line = linein + ocy1 if (line < ocy1 || line > ocy2) { call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) } # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_SHORT) MI_SB(mi) = sb SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_SHORT } else { sb = MI_SB(mi) # The required data is already in the buffer if ((SB_Y1(sb) == line) && (SB_Y2(sb) == line) && (SB_X1(sb) == ocx1) && (SB_X2(sb) == ocx2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_SHORT) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, onx, TY_SHORT) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtss (Mems[SB_DATA(sb)], Mems[obuf], onx) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], onx) case TY_INT: call achtis (Memi[SB_DATA(sb)], Mems[obuf], onx) case TY_LONG: call achtls (Meml[SB_DATA(sb)], Mems[obuf], onx) case TY_REAL: call achtrs (Memr[SB_DATA(sb)], Mems[obuf], onx) case TY_DOUBLE: call achtds (Memd[SB_DATA(sb)], Mems[obuf], onx) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_SHORT call pargi (SB_DATA(sb)) return (SB_DATA(sb)) } } else { # Free old and allocate new data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_SHORT) SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_SHORT } } # Fill output buffer from input images. # # Initialise buffer with blank value call amovks (short(blank), Mems[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) iline = line - (icy1 - ocy1) + idy1 - 1 ibuf = mscl2s (img, iline) # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocs (img, Mems[iptr], Mems[optr], nx, iline, Mems[ovr], novr) } return (SB_DATA(sb)) end # MIGL2x -- Get and process line from sub-image of mosaic. pointer procedure migl2i (mi, linein) pointer mi #I MOSIM Pointer for mosaic. int linein #I Line required. pointer obuf #O pointer to data values pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int line int onx, ony, ocx1, ocx2, ocy1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, iline, nx, image, novr pointer mscl2i() errchk mscl2i, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) line = linein + ocy1 if (line < ocy1 || line > ocy2) { call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) } # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_INT) MI_SB(mi) = sb SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_INT } else { sb = MI_SB(mi) # The required data is already in the buffer if ((SB_Y1(sb) == line) && (SB_Y2(sb) == line) && (SB_X1(sb) == ocx1) && (SB_X2(sb) == ocx2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_INT) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, onx, TY_INT) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsi (Mems[SB_DATA(sb)], Memi[obuf], onx) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], onx) case TY_INT: call achtii (Memi[SB_DATA(sb)], Memi[obuf], onx) case TY_LONG: call achtli (Meml[SB_DATA(sb)], Memi[obuf], onx) case TY_REAL: call achtri (Memr[SB_DATA(sb)], Memi[obuf], onx) case TY_DOUBLE: call achtdi (Memd[SB_DATA(sb)], Memi[obuf], onx) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_INT call pargi (SB_DATA(sb)) return (SB_DATA(sb)) } } else { # Free old and allocate new data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_INT) SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_INT } } # Fill output buffer from input images. # # Initialise buffer with blank value call amovki (int(blank), Memi[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) iline = line - (icy1 - ocy1) + idy1 - 1 ibuf = mscl2i (img, iline) # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miproci (img, Memi[iptr], Memi[optr], nx, iline, Memi[ovr], novr) } return (SB_DATA(sb)) end # MIGL2x -- Get and process line from sub-image of mosaic. pointer procedure migl2l (mi, linein) pointer mi #I MOSIM Pointer for mosaic. int linein #I Line required. pointer obuf #O pointer to data values pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int line int onx, ony, ocx1, ocx2, ocy1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, iline, nx, image, novr pointer mscl2l() errchk mscl2l, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) line = linein + ocy1 if (line < ocy1 || line > ocy2) { call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) } # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_LONG) MI_SB(mi) = sb SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_LONG } else { sb = MI_SB(mi) # The required data is already in the buffer if ((SB_Y1(sb) == line) && (SB_Y2(sb) == line) && (SB_X1(sb) == ocx1) && (SB_X2(sb) == ocx2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_LONG) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, onx, TY_LONG) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsl (Mems[SB_DATA(sb)], Meml[obuf], onx) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], onx) case TY_INT: call achtil (Memi[SB_DATA(sb)], Meml[obuf], onx) case TY_LONG: call achtll (Meml[SB_DATA(sb)], Meml[obuf], onx) case TY_REAL: call achtrl (Memr[SB_DATA(sb)], Meml[obuf], onx) case TY_DOUBLE: call achtdl (Memd[SB_DATA(sb)], Meml[obuf], onx) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_LONG call pargi (SB_DATA(sb)) return (SB_DATA(sb)) } } else { # Free old and allocate new data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_LONG) SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_LONG } } # Fill output buffer from input images. # # Initialise buffer with blank value call amovkl (long(blank), Meml[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) iline = line - (icy1 - ocy1) + idy1 - 1 ibuf = mscl2l (img, iline) # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocl (img, Meml[iptr], Meml[optr], nx, iline, Meml[ovr], novr) } return (SB_DATA(sb)) end # MIGL2x -- Get and process line from sub-image of mosaic. pointer procedure migl2r (mi, linein) pointer mi #I MOSIM Pointer for mosaic. int linein #I Line required. pointer obuf #O pointer to data values pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int line int onx, ony, ocx1, ocx2, ocy1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, iline, nx, image, novr pointer mscl2r() errchk mscl2r, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) line = linein + ocy1 if (line < ocy1 || line > ocy2) { call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) } # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_REAL) MI_SB(mi) = sb SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_REAL } else { sb = MI_SB(mi) # The required data is already in the buffer if ((SB_Y1(sb) == line) && (SB_Y2(sb) == line) && (SB_X1(sb) == ocx1) && (SB_X2(sb) == ocx2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_REAL) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, onx, TY_REAL) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsr (Mems[SB_DATA(sb)], Memr[obuf], onx) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], onx) case TY_INT: call achtir (Memi[SB_DATA(sb)], Memr[obuf], onx) case TY_LONG: call achtlr (Meml[SB_DATA(sb)], Memr[obuf], onx) case TY_REAL: call achtrr (Memr[SB_DATA(sb)], Memr[obuf], onx) case TY_DOUBLE: call achtdr (Memd[SB_DATA(sb)], Memr[obuf], onx) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_REAL call pargi (SB_DATA(sb)) return (SB_DATA(sb)) } } else { # Free old and allocate new data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_REAL) SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_REAL } } # Fill output buffer from input images. # # Initialise buffer with blank value call amovkr (real(blank), Memr[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) iline = line - (icy1 - ocy1) + idy1 - 1 ibuf = mscl2r (img, iline) # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocr (img, Memr[iptr], Memr[optr], nx, iline, Memr[ovr], novr) } return (SB_DATA(sb)) end # MIGL2x -- Get and process line from sub-image of mosaic. pointer procedure migl2d (mi, linein) pointer mi #I MOSIM Pointer for mosaic. int linein #I Line required. pointer obuf #O pointer to data values pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int line int onx, ony, ocx1, ocx2, ocy1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, iline, nx, image, novr pointer mscl2d() errchk mscl2d, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) line = linein + ocy1 if (line < ocy1 || line > ocy2) { call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) } # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_DOUBLE) MI_SB(mi) = sb SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_DOUBLE } else { sb = MI_SB(mi) # The required data is already in the buffer if ((SB_Y1(sb) == line) && (SB_Y2(sb) == line) && (SB_X1(sb) == ocx1) && (SB_X2(sb) == ocx2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_DOUBLE) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, onx, TY_DOUBLE) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsd (Mems[SB_DATA(sb)], Memd[obuf], onx) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], onx) case TY_INT: call achtid (Memi[SB_DATA(sb)], Memd[obuf], onx) case TY_LONG: call achtld (Meml[SB_DATA(sb)], Memd[obuf], onx) case TY_REAL: call achtrd (Memr[SB_DATA(sb)], Memd[obuf], onx) case TY_DOUBLE: call achtdd (Memd[SB_DATA(sb)], Memd[obuf], onx) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_DOUBLE call pargi (SB_DATA(sb)) return (SB_DATA(sb)) } } else { # Free old and allocate new data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_DOUBLE) SB_DATA(sb) = obuf SB_X1(sb) = ocx1 SB_X2(sb) = ocx2 SB_Y1(sb) = line SB_Y2(sb) = line SB_PIXTYPE(sb) = TY_DOUBLE } } # Fill output buffer from input images. # # Initialise buffer with blank value call amovkd (double(blank), Memd[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) iline = line - (icy1 - ocy1) + idy1 - 1 ibuf = mscl2d (img, iline) # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocd (img, Memd[iptr], Memd[optr], nx, iline, Memd[ovr], novr) } return (SB_DATA(sb)) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mignl.gx��������������������������������������������������0000664�0000000�0000000�00000007455�13321663143�0021175�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosim.h" include "mosgeom.h" include "mosproc.h" define LINE Meml[IMIDX($1)+1] # Current line count in index array # NOTE: These routines only realy work for 2D images! # Could be generalised but life's too short just now. $for (silrd) # MINL_INITx -- Set starting vectors for MIGNLx calls procedure minl_init$t (mi, v) pointer mi #I MOSIM Pointer for mosaic. long v[IM_MAXDIM] #I Initial value for loop counter. int nimage, onx, ony, ocy1, ocy2, icy1, icy2, idy1, image pointer omg, sb, obuf, img include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_PIXEL) MI_SB(mi) = sb SB_DATA(sb) = obuf } else { sb = MI_SB(mi) # Free old data buffer if any and allocate a new one if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_PIXEL) SB_DATA(sb) = obuf } # Set data buffer pixel type SB_PIXTYPE(sb) = TY_PIXEL # Convert line counter from image to ccd coordinates v[2] = v[2] + ocy1 - 1 # Initialise loop counters call amovl (v, Meml[IMIDX(omg)], IM_MAXDIM) do image = 1, nimage { img = MI_MG(mi, image) call amovl (v, Meml[IMIDX(img)], IM_MAXDIM) if (trim) { icy1 = CTY1(img) icy2 = CTY2(img) idy1 = TY1(img) } else { icy1 = CY1(img) icy2 = CY2(img) idy1 = DY1(img) } if (v[2] <= icy1) { LINE(img) = idy1 } else if (v[2] <= icy2) { LINE(img) = v[2] - (ocy1 - icy1) + idy1 } else { LINE(img) = NY(img) + 1 } } end # MIGNLx -- Get and process next line from sub-image of mosaic. int procedure mignl$t (mi, obuf, v) pointer mi #I MOSIM Pointer for mosaic. pointer obuf #O On output pointer to data values. long v[IM_MAXDIM] #I Loop counter. # function value #O Number of pixels in line or EOF. pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int onx, ocx1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, line, iline, nx, image, novr int mscnl$t() errchk mscnl$t, linebias$t, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ocx1 = CX1(omg) ocy2 = CY2(omg) # Perform zero-trip test (assumes 2D image) if (v[2] > ocy2) return (EOF) # Perform first time initialisation if (MI_SB(mi) == NULL) { call minl_init$t (mi, v) } else { # Reinitialise if caller has changed v since last call. if (LINE(omg) != v[2]) # Assumes 2D image. call minl_init$t (mi, v) } # Fill output buffer from input images. # sb = MI_SB(mi) obuf = SB_DATA(sb) line = LINE(omg) # Initialise buffer with blank value call amovk$t (PIXEL(blank), Mem$t[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) if (mscnl$t (img, ibuf, Meml[IMIDX(img)]) == EOF) next # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miproc$t (img, Mem$t[iptr], Mem$t[optr], nx, iline, Mem$t[ovr], novr) } # Bump loop counters ready for next trip (assumes 2D) v[2] = v[2] + long(1) LINE(omg) = v[2] return (onx) end $endfor �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mignl.x���������������������������������������������������0000664�0000000�0000000�00000043440�13321663143�0021020�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosim.h" include "mosgeom.h" include "mosproc.h" define LINE Meml[IMIDX($1)+1] # Current line count in index array # NOTE: These routines only realy work for 2D images! # Could be generalised but life's too short just now. # MINL_INITx -- Set starting vectors for MIGNLx calls procedure minl_inits (mi, v) pointer mi #I MOSIM Pointer for mosaic. long v[IM_MAXDIM] #I Initial value for loop counter. int nimage, onx, ony, ocy1, ocy2, icy1, icy2, idy1, image pointer omg, sb, obuf, img include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_SHORT) MI_SB(mi) = sb SB_DATA(sb) = obuf } else { sb = MI_SB(mi) # Free old data buffer if any and allocate a new one if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_SHORT) SB_DATA(sb) = obuf } # Set data buffer pixel type SB_PIXTYPE(sb) = TY_SHORT # Convert line counter from image to ccd coordinates v[2] = v[2] + ocy1 - 1 # Initialise loop counters call amovl (v, Meml[IMIDX(omg)], IM_MAXDIM) do image = 1, nimage { img = MI_MG(mi, image) call amovl (v, Meml[IMIDX(img)], IM_MAXDIM) if (trim) { icy1 = CTY1(img) icy2 = CTY2(img) idy1 = TY1(img) } else { icy1 = CY1(img) icy2 = CY2(img) idy1 = DY1(img) } if (v[2] <= icy1) { LINE(img) = idy1 } else if (v[2] <= icy2) { LINE(img) = v[2] - (ocy1 - icy1) + idy1 } else { LINE(img) = NY(img) + 1 } } end # MIGNLx -- Get and process next line from sub-image of mosaic. int procedure mignls (mi, obuf, v) pointer mi #I MOSIM Pointer for mosaic. pointer obuf #O On output pointer to data values. long v[IM_MAXDIM] #I Loop counter. # function value #O Number of pixels in line or EOF. pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int onx, ocx1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, line, iline, nx, image, novr int mscnls() errchk mscnls, linebiass, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ocx1 = CX1(omg) ocy2 = CY2(omg) # Perform zero-trip test (assumes 2D image) if (v[2] > ocy2) return (EOF) # Perform first time initialisation if (MI_SB(mi) == NULL) { call minl_inits (mi, v) } else { # Reinitialise if caller has changed v since last call. if (LINE(omg) != v[2]) # Assumes 2D image. call minl_inits (mi, v) } # Fill output buffer from input images. # sb = MI_SB(mi) obuf = SB_DATA(sb) line = LINE(omg) # Initialise buffer with blank value call amovks (short(blank), Mems[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) if (mscnls (img, ibuf, Meml[IMIDX(img)]) == EOF) next # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocs (img, Mems[iptr], Mems[optr], nx, iline, Mems[ovr], novr) } # Bump loop counters ready for next trip (assumes 2D) v[2] = v[2] + long(1) LINE(omg) = v[2] return (onx) end # MINL_INITx -- Set starting vectors for MIGNLx calls procedure minl_initi (mi, v) pointer mi #I MOSIM Pointer for mosaic. long v[IM_MAXDIM] #I Initial value for loop counter. int nimage, onx, ony, ocy1, ocy2, icy1, icy2, idy1, image pointer omg, sb, obuf, img include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_INT) MI_SB(mi) = sb SB_DATA(sb) = obuf } else { sb = MI_SB(mi) # Free old data buffer if any and allocate a new one if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_INT) SB_DATA(sb) = obuf } # Set data buffer pixel type SB_PIXTYPE(sb) = TY_INT # Convert line counter from image to ccd coordinates v[2] = v[2] + ocy1 - 1 # Initialise loop counters call amovl (v, Meml[IMIDX(omg)], IM_MAXDIM) do image = 1, nimage { img = MI_MG(mi, image) call amovl (v, Meml[IMIDX(img)], IM_MAXDIM) if (trim) { icy1 = CTY1(img) icy2 = CTY2(img) idy1 = TY1(img) } else { icy1 = CY1(img) icy2 = CY2(img) idy1 = DY1(img) } if (v[2] <= icy1) { LINE(img) = idy1 } else if (v[2] <= icy2) { LINE(img) = v[2] - (ocy1 - icy1) + idy1 } else { LINE(img) = NY(img) + 1 } } end # MIGNLx -- Get and process next line from sub-image of mosaic. int procedure mignli (mi, obuf, v) pointer mi #I MOSIM Pointer for mosaic. pointer obuf #O On output pointer to data values. long v[IM_MAXDIM] #I Loop counter. # function value #O Number of pixels in line or EOF. pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int onx, ocx1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, line, iline, nx, image, novr int mscnli() errchk mscnli, linebiasi, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ocx1 = CX1(omg) ocy2 = CY2(omg) # Perform zero-trip test (assumes 2D image) if (v[2] > ocy2) return (EOF) # Perform first time initialisation if (MI_SB(mi) == NULL) { call minl_initi (mi, v) } else { # Reinitialise if caller has changed v since last call. if (LINE(omg) != v[2]) # Assumes 2D image. call minl_initi (mi, v) } # Fill output buffer from input images. # sb = MI_SB(mi) obuf = SB_DATA(sb) line = LINE(omg) # Initialise buffer with blank value call amovki (int(blank), Memi[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) if (mscnli (img, ibuf, Meml[IMIDX(img)]) == EOF) next # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miproci (img, Memi[iptr], Memi[optr], nx, iline, Memi[ovr], novr) } # Bump loop counters ready for next trip (assumes 2D) v[2] = v[2] + long(1) LINE(omg) = v[2] return (onx) end # MINL_INITx -- Set starting vectors for MIGNLx calls procedure minl_initl (mi, v) pointer mi #I MOSIM Pointer for mosaic. long v[IM_MAXDIM] #I Initial value for loop counter. int nimage, onx, ony, ocy1, ocy2, icy1, icy2, idy1, image pointer omg, sb, obuf, img include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_LONG) MI_SB(mi) = sb SB_DATA(sb) = obuf } else { sb = MI_SB(mi) # Free old data buffer if any and allocate a new one if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_LONG) SB_DATA(sb) = obuf } # Set data buffer pixel type SB_PIXTYPE(sb) = TY_LONG # Convert line counter from image to ccd coordinates v[2] = v[2] + ocy1 - 1 # Initialise loop counters call amovl (v, Meml[IMIDX(omg)], IM_MAXDIM) do image = 1, nimage { img = MI_MG(mi, image) call amovl (v, Meml[IMIDX(img)], IM_MAXDIM) if (trim) { icy1 = CTY1(img) icy2 = CTY2(img) idy1 = TY1(img) } else { icy1 = CY1(img) icy2 = CY2(img) idy1 = DY1(img) } if (v[2] <= icy1) { LINE(img) = idy1 } else if (v[2] <= icy2) { LINE(img) = v[2] - (ocy1 - icy1) + idy1 } else { LINE(img) = NY(img) + 1 } } end # MIGNLx -- Get and process next line from sub-image of mosaic. int procedure mignll (mi, obuf, v) pointer mi #I MOSIM Pointer for mosaic. pointer obuf #O On output pointer to data values. long v[IM_MAXDIM] #I Loop counter. # function value #O Number of pixels in line or EOF. pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int onx, ocx1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, line, iline, nx, image, novr int mscnll() errchk mscnll, linebiasl, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ocx1 = CX1(omg) ocy2 = CY2(omg) # Perform zero-trip test (assumes 2D image) if (v[2] > ocy2) return (EOF) # Perform first time initialisation if (MI_SB(mi) == NULL) { call minl_initl (mi, v) } else { # Reinitialise if caller has changed v since last call. if (LINE(omg) != v[2]) # Assumes 2D image. call minl_initl (mi, v) } # Fill output buffer from input images. # sb = MI_SB(mi) obuf = SB_DATA(sb) line = LINE(omg) # Initialise buffer with blank value call amovkl (long(blank), Meml[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) if (mscnll (img, ibuf, Meml[IMIDX(img)]) == EOF) next # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocl (img, Meml[iptr], Meml[optr], nx, iline, Meml[ovr], novr) } # Bump loop counters ready for next trip (assumes 2D) v[2] = v[2] + long(1) LINE(omg) = v[2] return (onx) end # MINL_INITx -- Set starting vectors for MIGNLx calls procedure minl_initr (mi, v) pointer mi #I MOSIM Pointer for mosaic. long v[IM_MAXDIM] #I Initial value for loop counter. int nimage, onx, ony, ocy1, ocy2, icy1, icy2, idy1, image pointer omg, sb, obuf, img include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_REAL) MI_SB(mi) = sb SB_DATA(sb) = obuf } else { sb = MI_SB(mi) # Free old data buffer if any and allocate a new one if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_REAL) SB_DATA(sb) = obuf } # Set data buffer pixel type SB_PIXTYPE(sb) = TY_REAL # Convert line counter from image to ccd coordinates v[2] = v[2] + ocy1 - 1 # Initialise loop counters call amovl (v, Meml[IMIDX(omg)], IM_MAXDIM) do image = 1, nimage { img = MI_MG(mi, image) call amovl (v, Meml[IMIDX(img)], IM_MAXDIM) if (trim) { icy1 = CTY1(img) icy2 = CTY2(img) idy1 = TY1(img) } else { icy1 = CY1(img) icy2 = CY2(img) idy1 = DY1(img) } if (v[2] <= icy1) { LINE(img) = idy1 } else if (v[2] <= icy2) { LINE(img) = v[2] - (ocy1 - icy1) + idy1 } else { LINE(img) = NY(img) + 1 } } end # MIGNLx -- Get and process next line from sub-image of mosaic. int procedure mignlr (mi, obuf, v) pointer mi #I MOSIM Pointer for mosaic. pointer obuf #O On output pointer to data values. long v[IM_MAXDIM] #I Loop counter. # function value #O Number of pixels in line or EOF. pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int onx, ocx1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, line, iline, nx, image, novr int mscnlr() errchk mscnlr, linebiasr, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ocx1 = CX1(omg) ocy2 = CY2(omg) # Perform zero-trip test (assumes 2D image) if (v[2] > ocy2) return (EOF) # Perform first time initialisation if (MI_SB(mi) == NULL) { call minl_initr (mi, v) } else { # Reinitialise if caller has changed v since last call. if (LINE(omg) != v[2]) # Assumes 2D image. call minl_initr (mi, v) } # Fill output buffer from input images. # sb = MI_SB(mi) obuf = SB_DATA(sb) line = LINE(omg) # Initialise buffer with blank value call amovkr (real(blank), Memr[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) if (mscnlr (img, ibuf, Meml[IMIDX(img)]) == EOF) next # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocr (img, Memr[iptr], Memr[optr], nx, iline, Memr[ovr], novr) } # Bump loop counters ready for next trip (assumes 2D) v[2] = v[2] + long(1) LINE(omg) = v[2] return (onx) end # MINL_INITx -- Set starting vectors for MIGNLx calls procedure minl_initd (mi, v) pointer mi #I MOSIM Pointer for mosaic. long v[IM_MAXDIM] #I Initial value for loop counter. int nimage, onx, ony, ocy1, ocy2, icy1, icy2, idy1, image pointer omg, sb, obuf, img include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) call malloc (obuf, onx, TY_DOUBLE) MI_SB(mi) = sb SB_DATA(sb) = obuf } else { sb = MI_SB(mi) # Free old data buffer if any and allocate a new one if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) call malloc (obuf, onx, TY_DOUBLE) SB_DATA(sb) = obuf } # Set data buffer pixel type SB_PIXTYPE(sb) = TY_DOUBLE # Convert line counter from image to ccd coordinates v[2] = v[2] + ocy1 - 1 # Initialise loop counters call amovl (v, Meml[IMIDX(omg)], IM_MAXDIM) do image = 1, nimage { img = MI_MG(mi, image) call amovl (v, Meml[IMIDX(img)], IM_MAXDIM) if (trim) { icy1 = CTY1(img) icy2 = CTY2(img) idy1 = TY1(img) } else { icy1 = CY1(img) icy2 = CY2(img) idy1 = DY1(img) } if (v[2] <= icy1) { LINE(img) = idy1 } else if (v[2] <= icy2) { LINE(img) = v[2] - (ocy1 - icy1) + idy1 } else { LINE(img) = NY(img) + 1 } } end # MIGNLx -- Get and process next line from sub-image of mosaic. int procedure mignld (mi, obuf, v) pointer mi #I MOSIM Pointer for mosaic. pointer obuf #O On output pointer to data values. long v[IM_MAXDIM] #I Loop counter. # function value #O Number of pixels in line or EOF. pointer omg, sb, img, iim, ibuf, iptr, optr, ovr int onx, ocx1, ocy2, icx1, icx2, icy1, icy2, idx1, idy1 int nimage, line, iline, nx, image, novr int mscnld() errchk mscnld, linebiasd, malloc, syserrs include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ocx1 = CX1(omg) ocy2 = CY2(omg) # Perform zero-trip test (assumes 2D image) if (v[2] > ocy2) return (EOF) # Perform first time initialisation if (MI_SB(mi) == NULL) { call minl_initd (mi, v) } else { # Reinitialise if caller has changed v since last call. if (LINE(omg) != v[2]) # Assumes 2D image. call minl_initd (mi, v) } # Fill output buffer from input images. # sb = MI_SB(mi) obuf = SB_DATA(sb) line = LINE(omg) # Initialise buffer with blank value call amovkd (double(blank), Memd[obuf], onx) # Loop over input images, skipping those which have no data in # current line. do image = 1, nimage { img = MI_MG(mi, image) icy1 = CY1(img) icy2 = CY2(img) if (line < icy1 || line > icy2) next icx1 = CX1(img) icx2 = CX2(img) idx1 = DX1(img) idy1 = DY1(img) # Get corresponding line of input image iim = MI_IM(mi, image) if (mscnld (img, ibuf, Meml[IMIDX(img)]) == EOF) next # Process input image line writing to output buffer iptr = ibuf + idx1 - 1 optr = obuf + icx1 - ocx1 nx = icx2 - icx1 + 1 iline = line - CY1(img) + 1 ovr = ibuf + BX1(img) - 1 novr = BX2(img) - BX1(img) + 1 call miprocd (img, Memd[iptr], Memd[optr], nx, iline, Memd[ovr], novr) } # Bump loop counters ready for next trip (assumes 2D) v[2] = v[2] + long(1) LINE(omg) = v[2] return (onx) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/migs2.gx��������������������������������������������������0000664�0000000�0000000�00000031143�13321663143�0021077�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosim.h" include "mosgeom.h" include "mosproc.h" $for (silrd) # MIGS2x -- Get and process a section of a (2D) mosaic image. pointer procedure migs2$t (mi, x1in, x2in, y1in, y2in) pointer mi #I MOSIM Pointer for mosaic. int x1in, x2in #I Range of columns in section. int y1in, y2in #I Range of columns in section. pointer obuf #O pointer to data values. pointer omg, sb int x1, x2, y1, y2 int onx, ocx1, ocx2, ox1, ox2 int ony, ocy1, ocy2, oy1, oy2 int nimage, npix errchk syserrs, malloc, migets$t, micpys include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) # x1 = x1in + ocx1 # x2 = x2in + ocx1 # y1 = y1in + ocy1 # y2 = y2in + ocy1 x1 = x1in x2 = x2in y1 = y1in y2 = y2in #call eprintf ("x1=%d x2=%d y1=%d y2=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call eprintf ("nimage=%d ocx1=%d ocx2=%d ocy1=%d ocy2=%d\n") #call pargi (nimage) #call pargi (ocx1) #call pargi (ocx2) #call pargi (ocy1) #call pargi (ocy2) # Complain if section totaly out of bounds if (x2 < ocx1 || x1 > ocx2 || y1 < ocy1 || y1 > ocy2) call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) # Clip section at boundary of mosaic ox1 = max (x1, ocx1) ox2 = min (x2, ocx2) oy1 = max (y1, ocy1) oy2 = min (y2, ocy2) onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 npix = onx * ony #call eprintf ("ox1=%d ox2=%d oy1=%d oy2=%d onx=%d ony=%d npix=%d\n") #call pargi (ox1) #call pargi (ox2) #call pargi (oy1) #call pargi (oy2) #call pargi (onx) #call pargi (ony) #call pargi (npix) # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) MI_SB(mi) = sb SB_DATA(sb) = NULL # Set null section in SB to ensure buffer will be filled SB_X1(sb) = 0 SB_X2(sb) = 0 SB_Y1(sb) = 0 SB_Y2(sb) = 0 SB_PIXTYPE(sb) = TY_PIXEL } else { sb = MI_SB(mi) } #call eprintf ("sb_x1=%d sb_x2=%d sb_y1=%d sb_y2=%d\n") #call pargi (SB_X1(sb)) #call pargi (SB_X2(sb)) #call pargi (SB_Y1(sb)) #call pargi (SB_Y2(sb)) # The requested section is entirely outside the buffer if ((SB_X2(sb) < ox1) || (SB_X1(sb) > ox2) || (SB_Y2(sb) < oy1) || (SB_Y1(sb) > oy2)) { # Free old data buffer. if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Allocate new buffer and initialise to blank value call malloc (obuf, npix, TY_PIXEL) call amovk$t (PIXEL(blank), Mem$t[obuf], npix) call migets$t (mi, ox1, ox2, oy1, oy2, ox1, ox2, oy1, oy2, obuf) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_PIXEL return (SB_DATA(sb)) # Exactly the requested section is already in the buffer } else if ((SB_X1(sb) == ox1) && (SB_X2(sb) == ox2) && (SB_Y1(sb) == oy1) && (SB_Y2(sb) == oy2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_PIXEL) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, npix, TY_PIXEL) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achts$t (Mems[SB_DATA(sb)], Mem$t[obuf], npix) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], npix) case TY_INT: call achti$t (Memi[SB_DATA(sb)], Mem$t[obuf], npix) case TY_LONG: call achtl$t (Meml[SB_DATA(sb)], Mem$t[obuf], npix) case TY_REAL: call achtr$t (Memr[SB_DATA(sb)], Mem$t[obuf], npix) case TY_DOUBLE: call achtd$t (Memd[SB_DATA(sb)], Mem$t[obuf], npix) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_PIXEL return (SB_DATA(sb)) } # The requested section is entirely contained in the buffer } else if ((SB_X1(sb) <= ox1) && (SB_X2(sb) >= ox2) && (SB_Y1(sb) <= oy1) && (SB_Y2(sb) >= oy2)) { # Copy the part we need to a new buffer call malloc (obuf, npix, TY_PIXEL) call micpy (sb, ox1, ox2, oy1, oy2, TY_PIXEL, obuf) SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_PIXEL # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf return (SB_DATA(sb)) # The requested section partialy overlaps the data buffer (oh joy!) } else { # Allocate a new buffer and initialise to blank value call malloc (obuf, npix, TY_PIXEL) call amovk$t (PIXEL(blank), Mem$t[obuf], npix) # Copy what we can from the buffer. call micpy (sb, ox1, ox2, oy1, oy2, TY_PIXEL, obuf) # Fill out the rest by reading the images. if (oy1 < SB_Y1(sb)) call migets$t (mi, ox1, ox2, oy1, SB_Y1(sb)-1, ox1, ox2, oy1, oy2, obuf) if (ox1 < SB_X1(sb)) call migets$t (mi, ox1, SB_X1(sb)-1, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (ox2 > SB_X2(sb)) call migets$t (mi, SB_X2(sb)+1, ox2, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (oy2 > SB_Y2(sb)) call migets$t (mi, ox1, ox2, SB_Y2(sb)+1, oy2, ox1, ox2, oy1, oy2, obuf) # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_PIXEL return (SB_DATA(sb)) } end $endfor $for (silrd) # MIGETSx -- Fill rectangle in output buffer from input images. # The section requested may be larger or smaller than the output buffer. # In the former case we only return the piece which maps into the output # buffer. In the latter case we fill a portion of the output buffer with # data read from the images. procedure migets$t (mi, x1, x2, y1, y2, ox1, ox2, oy1, oy2, obuf) pointer mi #I MOSIM Pointer for mosaic. int x1, x2 #I Range of columns in required section. int y1, y2 #I Range of columns in required section. int ox1, ox2 #I Range of columns in output buffer. int oy1, oy2 #I Range of columns in output buffer. pointer obuf #O pointer to data values. int image, i, j, k, line, novr, bx1, bx2 int onx, ox0, ix1, ix2, cx1, cx2, sx1, sx2, nx int ony, oy0, iy1, iy2, cy1, cy2, sy1, sy2, ny real sdx1, sdx2, sdy1, sdy2 pointer img, iim, ibuf, bbuf, ptr PIXEL junk pointer mscs2$t() errchk mscs2$t, miproc$t() include "mosproc.com" # Macros to "simplify" array indexing define IPTR (ibuf + ($2-1)*nx + ($1-1)) define OPTR (obuf + ($2+oy0-1)*onx + ($1+ox0-1)) define IPTR1 (ibuf + ($1-1)*nx) define OPTR1 (obuf + ($1+oy0-1)*onx + ox0) define BPTR1 (bbuf + ($1-1)*novr) begin # Dimensions of output buffer onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 # Clip requested section at boundary of input buffer. ix1 = max (x1, ox1) ix2 = min (x2, ox2) iy1 = max (y1, oy1) iy2 = min (y2, oy2) # Loop over input images, skipping those which have no data within # the requested section do image = 1, MI_NIMS(mi) { img = MI_MG(mi, image) # "CCD" coordinates of corners of DATASEC of this image cx1 = CX1(img) cx2 = CX2(img) cy1 = CY1(img) cy2 = CY2(img) if (ix1 > cx2 || ix2 < cx1 || iy2 < cy1 || iy1 > cy2) { next } # "CCD" coordinates of the section of this image we want cx1 = max (ix1, cx1) cx2 = min (ix2, cx2) cy1 = max (iy1, cy1) cy2 = min (iy2, cy2) nx = cx2 - cx1 + 1 ny = cy2 - cy1 + 1 # "IMAGE" coordinates of the section of this image we want sdx1 = DX(img) sdx2 = (DX(img) - 1) / 2. sdy1 = DY(img) sdy2 = (DY(img) - 1) / 2. sx1 = nint ((cx1 - CX1(img) - sdx2) / sdx1 + DX1(img)) sx2 = nint ((cx2 - CX1(img) - sdx2) / sdx1 + DX1(img)) sy1 = nint ((cy1 - CY1(img) - sdy2) / sdy1 + DY1(img)) sy2 = nint ((cy2 - CY1(img) - sdy2) / sdy1 + DY1(img)) # Read required section of this image and replicate if necessary. iim = MI_IM(mi, image) if (DX(img) == 1 && DY(img) == 1) ibuf = mscs2$t (img, sx1, sx2, sy1, sy2) else { call malloc (ibuf, nx * ny, TY_PIXEL) ptr = ibuf do j = cy1, cy2 { sy1 = nint ((j-CY1(img)-sdy2)/sdy1+DY1(img)) bbuf = mscs2$t (img, sx1, sx2, sy1, sy1) do i = cx1, cx2 { k = nint ((i-CX1(img)-sdx2)/sdx1+DX1(img)) - sx1 Mem$t[ptr] = Mem$t[bbuf+k] ptr = ptr + 1 } } } # Process input image section line by line writing to output buffer # Offsets to starting point in output for data from this image ox0 = cx1 - ox1 oy0 = cy1 - oy1 # Read corresponding overscan data if needed. if (and(proc, L) != 0) { bx1 = BX1(img) bx2 = BX2(img) novr = bx2 - bx1 + 1 bbuf = mscs2$t (img, bx1, bx2, sy1, sy2) do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miproc$t (img, Mem$t[IPTR1(j)], Mem$t[OPTR1(j)], nx, line, Mem$t[BPTR1(j)], novr) } } else { do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miproc$t (img, Mem$t[IPTR1(j)], Mem$t[OPTR1(j)], nx, line, junk, 0) } } if (DX(img) != 1 || DY(img) != 1) call mfree (ibuf, TY_PIXEL) } end $endfor # MICPY -- Fill rectangle in output buffer by copying from the internal buffer procedure micpy (sb, x1, x2, y1, y2, otype, obuf) pointer sb #I Pointer to section data sub-structure int x1, x2 #I Range of columns in section. int y1, y2 #I Range of lines in section. int otype #I Desired type of output data. pointer obuf #O pointer to data values. begin switch (otype) { case TY_SHORT: call micpys (sb, x1, x2, y1, y2, obuf) # case TY_USHORT: # call micpyu (sb, x1, x2, y1, y2, obuf) case TY_INT: call micpyi (sb, x1, x2, y1, y2, obuf) case TY_LONG: call micpyl (sb, x1, x2, y1, y2, obuf) case TY_REAL: call micpyr (sb, x1, x2, y1, y2, obuf) case TY_DOUBLE: call micpyd (sb, x1, x2, y1, y2, obuf) } end $for (silrd) # MICPYx -- Fill rectangle in output buffer by copying from the internal buffer # The data is type converted if neccesary. The section requested may be # larger or smaller than that available in the internal buffer. In the # former case we just fill the part of the output buffer for which we have # data. In the latter case we copy a subsection of the internal buffer to # output. procedure micpy$t (sb, x1, x2, y1, y2, obuf) pointer sb #I Pointer to section data sub-structure. int x1, x2 #I Range of columns in requested section. int y1, y2 #I Range of lines in requested section. pointer obuf #O pointer to data values. int j, i, btype int nx, x0, bnx, bx1, bx2, bx0, sx1, sx2, snx int ny, y0, bny, by1, by2, by0, sy1, sy2, sny pointer ibuf # Macros to "simplify" array indexing define IPTR (ibuf + ($2+by0-1)*bnx + ($1+bx0-1)) define OPTR (obuf + ($2+y0-1)*nx + ($1+x0-1)) begin #call eprintf ("MICPY\n") # dimensions of output buffer nx = x2 - x1 + 1 ny = y2 - y1 + 1 #call eprintf ("\t x1=%d x2=%d y1=%d y2=%d nx=%d ny=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call pargi (nx) #call pargi (ny) # Coordinates etc. of internal buffer ibuf = SB_DATA(sb) bx1 = SB_X1(sb) bx2 = SB_X2(sb) by1 = SB_Y1(sb) by2 = SB_Y2(sb) bnx = bx2 - bx1 + 1 bny = by2 - by1 + 1 btype = SB_PIXTYPE(sb) #call eprintf ("\tbx1=%d bx2=%d by1=%d by2=%d bnx=%d bny=%d\n") #call pargi (bx1) #call pargi (bx2) #call pargi (by1) #call pargi (by2) #call pargi (bnx) #call pargi (bny) # offset to starting point in output buffer x0 = max ((bx1 - x1), 0) y0 = max ((by1 - y1), 0) # Offset to starting point in internal buffer bx0 = max ((x1 - bx1), 0) by0 = max ((y1 - by1), 0) #call eprintf ("\tx0=%d y0=%d bx0=%d bx0=%d\n") #call pargi (x0) #call pargi (y0) #call pargi (bx0) #call pargi (by0) # Coordinates of the piece we have in the internal buffer. sx1 = max (x1, bx1) sx2 = min (x2, bx2) sy1 = max (y1, by1) sy2 = min (y2, by2) # Number of pixels to copy. snx = sx2 - sx1 + 1 sny = sy2 - sy1 + 1 #call eprintf ("\tsx1=%d sx2=%d sy1=%d sy2=%d snx=%d sny=%d\n") #call pargi (sx1) #call pargi (sx2) #call pargi (sy1) #call pargi (sy2) #call pargi (snx) #call pargi (sny) switch (btype) { case TY_SHORT: do j = 1, sny { do i = 1, snx Mem$t[OPTR(i, j)] = Mems[IPTR(i,j)] } case TY_INT: do j = 1, sny { do i = 1, snx Mem$t[OPTR(i, j)] = Memi[IPTR(i,j)] } case TY_LONG: do j = 1, sny { do i = 1, snx Mem$t[OPTR(i, j)] = Meml[IPTR(i,j)] } case TY_REAL: do j = 1, sny { do i = 1, snx Mem$t[OPTR(i, j)] = Memr[IPTR(i,j)] } case TY_DOUBLE: do j = 1, sny { do i = 1, snx Mem$t[OPTR(i, j)] = Memd[IPTR(i,j)] } } end $endfor �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/migs2.x���������������������������������������������������0000664�0000000�0000000�00000166320�13321663143�0020736�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosim.h" include "mosgeom.h" include "mosproc.h" # MIGS2x -- Get and process a section of a (2D) mosaic image. pointer procedure migs2s (mi, x1in, x2in, y1in, y2in) pointer mi #I MOSIM Pointer for mosaic. int x1in, x2in #I Range of columns in section. int y1in, y2in #I Range of columns in section. pointer obuf #O pointer to data values. pointer omg, sb int x1, x2, y1, y2 int onx, ocx1, ocx2, ox1, ox2 int ony, ocy1, ocy2, oy1, oy2 int nimage, npix errchk syserrs, malloc, migetss, micpys include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) # x1 = x1in + ocx1 # x2 = x2in + ocx1 # y1 = y1in + ocy1 # y2 = y2in + ocy1 x1 = x1in x2 = x2in y1 = y1in y2 = y2in #call eprintf ("x1=%d x2=%d y1=%d y2=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call eprintf ("nimage=%d ocx1=%d ocx2=%d ocy1=%d ocy2=%d\n") #call pargi (nimage) #call pargi (ocx1) #call pargi (ocx2) #call pargi (ocy1) #call pargi (ocy2) # Complain if section totaly out of bounds if (x2 < ocx1 || x1 > ocx2 || y1 < ocy1 || y1 > ocy2) call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) # Clip section at boundary of mosaic ox1 = max (x1, ocx1) ox2 = min (x2, ocx2) oy1 = max (y1, ocy1) oy2 = min (y2, ocy2) onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 npix = onx * ony #call eprintf ("ox1=%d ox2=%d oy1=%d oy2=%d onx=%d ony=%d npix=%d\n") #call pargi (ox1) #call pargi (ox2) #call pargi (oy1) #call pargi (oy2) #call pargi (onx) #call pargi (ony) #call pargi (npix) # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) MI_SB(mi) = sb SB_DATA(sb) = NULL # Set null section in SB to ensure buffer will be filled SB_X1(sb) = 0 SB_X2(sb) = 0 SB_Y1(sb) = 0 SB_Y2(sb) = 0 SB_PIXTYPE(sb) = TY_SHORT } else { sb = MI_SB(mi) } #call eprintf ("sb_x1=%d sb_x2=%d sb_y1=%d sb_y2=%d\n") #call pargi (SB_X1(sb)) #call pargi (SB_X2(sb)) #call pargi (SB_Y1(sb)) #call pargi (SB_Y2(sb)) # The requested section is entirely outside the buffer if ((SB_X2(sb) < ox1) || (SB_X1(sb) > ox2) || (SB_Y2(sb) < oy1) || (SB_Y1(sb) > oy2)) { # Free old data buffer. if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Allocate new buffer and initialise to blank value call malloc (obuf, npix, TY_SHORT) call amovks (short(blank), Mems[obuf], npix) call migetss (mi, ox1, ox2, oy1, oy2, ox1, ox2, oy1, oy2, obuf) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_SHORT return (SB_DATA(sb)) # Exactly the requested section is already in the buffer } else if ((SB_X1(sb) == ox1) && (SB_X2(sb) == ox2) && (SB_Y1(sb) == oy1) && (SB_Y2(sb) == oy2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_SHORT) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, npix, TY_SHORT) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtss (Mems[SB_DATA(sb)], Mems[obuf], npix) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], npix) case TY_INT: call achtis (Memi[SB_DATA(sb)], Mems[obuf], npix) case TY_LONG: call achtls (Meml[SB_DATA(sb)], Mems[obuf], npix) case TY_REAL: call achtrs (Memr[SB_DATA(sb)], Mems[obuf], npix) case TY_DOUBLE: call achtds (Memd[SB_DATA(sb)], Mems[obuf], npix) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_SHORT return (SB_DATA(sb)) } # The requested section is entirely contained in the buffer } else if ((SB_X1(sb) <= ox1) && (SB_X2(sb) >= ox2) && (SB_Y1(sb) <= oy1) && (SB_Y2(sb) >= oy2)) { # Copy the part we need to a new buffer call malloc (obuf, npix, TY_SHORT) call micpy (sb, ox1, ox2, oy1, oy2, TY_SHORT, obuf) SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_SHORT # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf return (SB_DATA(sb)) # The requested section partialy overlaps the data buffer (oh joy!) } else { # Allocate a new buffer and initialise to blank value call malloc (obuf, npix, TY_SHORT) call amovks (short(blank), Mems[obuf], npix) # Copy what we can from the buffer. call micpy (sb, ox1, ox2, oy1, oy2, TY_SHORT, obuf) # Fill out the rest by reading the images. if (oy1 < SB_Y1(sb)) call migetss (mi, ox1, ox2, oy1, SB_Y1(sb)-1, ox1, ox2, oy1, oy2, obuf) if (ox1 < SB_X1(sb)) call migetss (mi, ox1, SB_X1(sb)-1, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (ox2 > SB_X2(sb)) call migetss (mi, SB_X2(sb)+1, ox2, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (oy2 > SB_Y2(sb)) call migetss (mi, ox1, ox2, SB_Y2(sb)+1, oy2, ox1, ox2, oy1, oy2, obuf) # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_SHORT return (SB_DATA(sb)) } end # MIGS2x -- Get and process a section of a (2D) mosaic image. pointer procedure migs2i (mi, x1in, x2in, y1in, y2in) pointer mi #I MOSIM Pointer for mosaic. int x1in, x2in #I Range of columns in section. int y1in, y2in #I Range of columns in section. pointer obuf #O pointer to data values. pointer omg, sb int x1, x2, y1, y2 int onx, ocx1, ocx2, ox1, ox2 int ony, ocy1, ocy2, oy1, oy2 int nimage, npix errchk syserrs, malloc, migetsi, micpys include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) # x1 = x1in + ocx1 # x2 = x2in + ocx1 # y1 = y1in + ocy1 # y2 = y2in + ocy1 x1 = x1in x2 = x2in y1 = y1in y2 = y2in #call eprintf ("x1=%d x2=%d y1=%d y2=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call eprintf ("nimage=%d ocx1=%d ocx2=%d ocy1=%d ocy2=%d\n") #call pargi (nimage) #call pargi (ocx1) #call pargi (ocx2) #call pargi (ocy1) #call pargi (ocy2) # Complain if section totaly out of bounds if (x2 < ocx1 || x1 > ocx2 || y1 < ocy1 || y1 > ocy2) call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) # Clip section at boundary of mosaic ox1 = max (x1, ocx1) ox2 = min (x2, ocx2) oy1 = max (y1, ocy1) oy2 = min (y2, ocy2) onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 npix = onx * ony #call eprintf ("ox1=%d ox2=%d oy1=%d oy2=%d onx=%d ony=%d npix=%d\n") #call pargi (ox1) #call pargi (ox2) #call pargi (oy1) #call pargi (oy2) #call pargi (onx) #call pargi (ony) #call pargi (npix) # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) MI_SB(mi) = sb SB_DATA(sb) = NULL # Set null section in SB to ensure buffer will be filled SB_X1(sb) = 0 SB_X2(sb) = 0 SB_Y1(sb) = 0 SB_Y2(sb) = 0 SB_PIXTYPE(sb) = TY_INT } else { sb = MI_SB(mi) } #call eprintf ("sb_x1=%d sb_x2=%d sb_y1=%d sb_y2=%d\n") #call pargi (SB_X1(sb)) #call pargi (SB_X2(sb)) #call pargi (SB_Y1(sb)) #call pargi (SB_Y2(sb)) # The requested section is entirely outside the buffer if ((SB_X2(sb) < ox1) || (SB_X1(sb) > ox2) || (SB_Y2(sb) < oy1) || (SB_Y1(sb) > oy2)) { # Free old data buffer. if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Allocate new buffer and initialise to blank value call malloc (obuf, npix, TY_INT) call amovki (int(blank), Memi[obuf], npix) call migetsi (mi, ox1, ox2, oy1, oy2, ox1, ox2, oy1, oy2, obuf) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_INT return (SB_DATA(sb)) # Exactly the requested section is already in the buffer } else if ((SB_X1(sb) == ox1) && (SB_X2(sb) == ox2) && (SB_Y1(sb) == oy1) && (SB_Y2(sb) == oy2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_INT) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, npix, TY_INT) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsi (Mems[SB_DATA(sb)], Memi[obuf], npix) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], npix) case TY_INT: call achtii (Memi[SB_DATA(sb)], Memi[obuf], npix) case TY_LONG: call achtli (Meml[SB_DATA(sb)], Memi[obuf], npix) case TY_REAL: call achtri (Memr[SB_DATA(sb)], Memi[obuf], npix) case TY_DOUBLE: call achtdi (Memd[SB_DATA(sb)], Memi[obuf], npix) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_INT return (SB_DATA(sb)) } # The requested section is entirely contained in the buffer } else if ((SB_X1(sb) <= ox1) && (SB_X2(sb) >= ox2) && (SB_Y1(sb) <= oy1) && (SB_Y2(sb) >= oy2)) { # Copy the part we need to a new buffer call malloc (obuf, npix, TY_INT) call micpy (sb, ox1, ox2, oy1, oy2, TY_INT, obuf) SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_INT # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf return (SB_DATA(sb)) # The requested section partialy overlaps the data buffer (oh joy!) } else { # Allocate a new buffer and initialise to blank value call malloc (obuf, npix, TY_INT) call amovki (int(blank), Memi[obuf], npix) # Copy what we can from the buffer. call micpy (sb, ox1, ox2, oy1, oy2, TY_INT, obuf) # Fill out the rest by reading the images. if (oy1 < SB_Y1(sb)) call migetsi (mi, ox1, ox2, oy1, SB_Y1(sb)-1, ox1, ox2, oy1, oy2, obuf) if (ox1 < SB_X1(sb)) call migetsi (mi, ox1, SB_X1(sb)-1, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (ox2 > SB_X2(sb)) call migetsi (mi, SB_X2(sb)+1, ox2, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (oy2 > SB_Y2(sb)) call migetsi (mi, ox1, ox2, SB_Y2(sb)+1, oy2, ox1, ox2, oy1, oy2, obuf) # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_INT return (SB_DATA(sb)) } end # MIGS2x -- Get and process a section of a (2D) mosaic image. pointer procedure migs2l (mi, x1in, x2in, y1in, y2in) pointer mi #I MOSIM Pointer for mosaic. int x1in, x2in #I Range of columns in section. int y1in, y2in #I Range of columns in section. pointer obuf #O pointer to data values. pointer omg, sb int x1, x2, y1, y2 int onx, ocx1, ocx2, ox1, ox2 int ony, ocy1, ocy2, oy1, oy2 int nimage, npix errchk syserrs, malloc, migetsl, micpys include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) # x1 = x1in + ocx1 # x2 = x2in + ocx1 # y1 = y1in + ocy1 # y2 = y2in + ocy1 x1 = x1in x2 = x2in y1 = y1in y2 = y2in #call eprintf ("x1=%d x2=%d y1=%d y2=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call eprintf ("nimage=%d ocx1=%d ocx2=%d ocy1=%d ocy2=%d\n") #call pargi (nimage) #call pargi (ocx1) #call pargi (ocx2) #call pargi (ocy1) #call pargi (ocy2) # Complain if section totaly out of bounds if (x2 < ocx1 || x1 > ocx2 || y1 < ocy1 || y1 > ocy2) call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) # Clip section at boundary of mosaic ox1 = max (x1, ocx1) ox2 = min (x2, ocx2) oy1 = max (y1, ocy1) oy2 = min (y2, ocy2) onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 npix = onx * ony #call eprintf ("ox1=%d ox2=%d oy1=%d oy2=%d onx=%d ony=%d npix=%d\n") #call pargi (ox1) #call pargi (ox2) #call pargi (oy1) #call pargi (oy2) #call pargi (onx) #call pargi (ony) #call pargi (npix) # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) MI_SB(mi) = sb SB_DATA(sb) = NULL # Set null section in SB to ensure buffer will be filled SB_X1(sb) = 0 SB_X2(sb) = 0 SB_Y1(sb) = 0 SB_Y2(sb) = 0 SB_PIXTYPE(sb) = TY_LONG } else { sb = MI_SB(mi) } #call eprintf ("sb_x1=%d sb_x2=%d sb_y1=%d sb_y2=%d\n") #call pargi (SB_X1(sb)) #call pargi (SB_X2(sb)) #call pargi (SB_Y1(sb)) #call pargi (SB_Y2(sb)) # The requested section is entirely outside the buffer if ((SB_X2(sb) < ox1) || (SB_X1(sb) > ox2) || (SB_Y2(sb) < oy1) || (SB_Y1(sb) > oy2)) { # Free old data buffer. if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Allocate new buffer and initialise to blank value call malloc (obuf, npix, TY_LONG) call amovkl (long(blank), Meml[obuf], npix) call migetsl (mi, ox1, ox2, oy1, oy2, ox1, ox2, oy1, oy2, obuf) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_LONG return (SB_DATA(sb)) # Exactly the requested section is already in the buffer } else if ((SB_X1(sb) == ox1) && (SB_X2(sb) == ox2) && (SB_Y1(sb) == oy1) && (SB_Y2(sb) == oy2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_LONG) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, npix, TY_LONG) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsl (Mems[SB_DATA(sb)], Meml[obuf], npix) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], npix) case TY_INT: call achtil (Memi[SB_DATA(sb)], Meml[obuf], npix) case TY_LONG: call achtll (Meml[SB_DATA(sb)], Meml[obuf], npix) case TY_REAL: call achtrl (Memr[SB_DATA(sb)], Meml[obuf], npix) case TY_DOUBLE: call achtdl (Memd[SB_DATA(sb)], Meml[obuf], npix) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_LONG return (SB_DATA(sb)) } # The requested section is entirely contained in the buffer } else if ((SB_X1(sb) <= ox1) && (SB_X2(sb) >= ox2) && (SB_Y1(sb) <= oy1) && (SB_Y2(sb) >= oy2)) { # Copy the part we need to a new buffer call malloc (obuf, npix, TY_LONG) call micpy (sb, ox1, ox2, oy1, oy2, TY_LONG, obuf) SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_LONG # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf return (SB_DATA(sb)) # The requested section partialy overlaps the data buffer (oh joy!) } else { # Allocate a new buffer and initialise to blank value call malloc (obuf, npix, TY_LONG) call amovkl (long(blank), Meml[obuf], npix) # Copy what we can from the buffer. call micpy (sb, ox1, ox2, oy1, oy2, TY_LONG, obuf) # Fill out the rest by reading the images. if (oy1 < SB_Y1(sb)) call migetsl (mi, ox1, ox2, oy1, SB_Y1(sb)-1, ox1, ox2, oy1, oy2, obuf) if (ox1 < SB_X1(sb)) call migetsl (mi, ox1, SB_X1(sb)-1, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (ox2 > SB_X2(sb)) call migetsl (mi, SB_X2(sb)+1, ox2, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (oy2 > SB_Y2(sb)) call migetsl (mi, ox1, ox2, SB_Y2(sb)+1, oy2, ox1, ox2, oy1, oy2, obuf) # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_LONG return (SB_DATA(sb)) } end # MIGS2x -- Get and process a section of a (2D) mosaic image. pointer procedure migs2r (mi, x1in, x2in, y1in, y2in) pointer mi #I MOSIM Pointer for mosaic. int x1in, x2in #I Range of columns in section. int y1in, y2in #I Range of columns in section. pointer obuf #O pointer to data values. pointer omg, sb int x1, x2, y1, y2 int onx, ocx1, ocx2, ox1, ox2 int ony, ocy1, ocy2, oy1, oy2 int nimage, npix errchk syserrs, malloc, migetsr, micpys include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) # x1 = x1in + ocx1 # x2 = x2in + ocx1 # y1 = y1in + ocy1 # y2 = y2in + ocy1 x1 = x1in x2 = x2in y1 = y1in y2 = y2in #call eprintf ("x1=%d x2=%d y1=%d y2=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call eprintf ("nimage=%d ocx1=%d ocx2=%d ocy1=%d ocy2=%d\n") #call pargi (nimage) #call pargi (ocx1) #call pargi (ocx2) #call pargi (ocy1) #call pargi (ocy2) # Complain if section totaly out of bounds if (x2 < ocx1 || x1 > ocx2 || y1 < ocy1 || y1 > ocy2) call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) # Clip section at boundary of mosaic ox1 = max (x1, ocx1) ox2 = min (x2, ocx2) oy1 = max (y1, ocy1) oy2 = min (y2, ocy2) onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 npix = onx * ony #call eprintf ("ox1=%d ox2=%d oy1=%d oy2=%d onx=%d ony=%d npix=%d\n") #call pargi (ox1) #call pargi (ox2) #call pargi (oy1) #call pargi (oy2) #call pargi (onx) #call pargi (ony) #call pargi (npix) # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) MI_SB(mi) = sb SB_DATA(sb) = NULL # Set null section in SB to ensure buffer will be filled SB_X1(sb) = 0 SB_X2(sb) = 0 SB_Y1(sb) = 0 SB_Y2(sb) = 0 SB_PIXTYPE(sb) = TY_REAL } else { sb = MI_SB(mi) } #call eprintf ("sb_x1=%d sb_x2=%d sb_y1=%d sb_y2=%d\n") #call pargi (SB_X1(sb)) #call pargi (SB_X2(sb)) #call pargi (SB_Y1(sb)) #call pargi (SB_Y2(sb)) # The requested section is entirely outside the buffer if ((SB_X2(sb) < ox1) || (SB_X1(sb) > ox2) || (SB_Y2(sb) < oy1) || (SB_Y1(sb) > oy2)) { # Free old data buffer. if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Allocate new buffer and initialise to blank value call malloc (obuf, npix, TY_REAL) call amovkr (real(blank), Memr[obuf], npix) call migetsr (mi, ox1, ox2, oy1, oy2, ox1, ox2, oy1, oy2, obuf) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_REAL return (SB_DATA(sb)) # Exactly the requested section is already in the buffer } else if ((SB_X1(sb) == ox1) && (SB_X2(sb) == ox2) && (SB_Y1(sb) == oy1) && (SB_Y2(sb) == oy2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_REAL) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, npix, TY_REAL) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsr (Mems[SB_DATA(sb)], Memr[obuf], npix) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], npix) case TY_INT: call achtir (Memi[SB_DATA(sb)], Memr[obuf], npix) case TY_LONG: call achtlr (Meml[SB_DATA(sb)], Memr[obuf], npix) case TY_REAL: call achtrr (Memr[SB_DATA(sb)], Memr[obuf], npix) case TY_DOUBLE: call achtdr (Memd[SB_DATA(sb)], Memr[obuf], npix) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_REAL return (SB_DATA(sb)) } # The requested section is entirely contained in the buffer } else if ((SB_X1(sb) <= ox1) && (SB_X2(sb) >= ox2) && (SB_Y1(sb) <= oy1) && (SB_Y2(sb) >= oy2)) { # Copy the part we need to a new buffer call malloc (obuf, npix, TY_REAL) call micpy (sb, ox1, ox2, oy1, oy2, TY_REAL, obuf) SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_REAL # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf return (SB_DATA(sb)) # The requested section partialy overlaps the data buffer (oh joy!) } else { # Allocate a new buffer and initialise to blank value call malloc (obuf, npix, TY_REAL) call amovkr (real(blank), Memr[obuf], npix) # Copy what we can from the buffer. call micpy (sb, ox1, ox2, oy1, oy2, TY_REAL, obuf) # Fill out the rest by reading the images. if (oy1 < SB_Y1(sb)) call migetsr (mi, ox1, ox2, oy1, SB_Y1(sb)-1, ox1, ox2, oy1, oy2, obuf) if (ox1 < SB_X1(sb)) call migetsr (mi, ox1, SB_X1(sb)-1, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (ox2 > SB_X2(sb)) call migetsr (mi, SB_X2(sb)+1, ox2, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (oy2 > SB_Y2(sb)) call migetsr (mi, ox1, ox2, SB_Y2(sb)+1, oy2, ox1, ox2, oy1, oy2, obuf) # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_REAL return (SB_DATA(sb)) } end # MIGS2x -- Get and process a section of a (2D) mosaic image. pointer procedure migs2d (mi, x1in, x2in, y1in, y2in) pointer mi #I MOSIM Pointer for mosaic. int x1in, x2in #I Range of columns in section. int y1in, y2in #I Range of columns in section. pointer obuf #O pointer to data values. pointer omg, sb int x1, x2, y1, y2 int onx, ocx1, ocx2, ox1, ox2 int ony, ocy1, ocy2, oy1, oy2 int nimage, npix errchk syserrs, malloc, migetsd, micpys include "mosproc.com" begin nimage = MI_NIMS(mi) omg = MI_MG(mi, nimage+1) onx = NX(omg) ony = NY(omg) ocx1 = CX1(omg) ocx2 = CX2(omg) ocy1 = CY1(omg) ocy2 = CY2(omg) # x1 = x1in + ocx1 # x2 = x2in + ocx1 # y1 = y1in + ocy1 # y2 = y2in + ocy1 x1 = x1in x2 = x2in y1 = y1in y2 = y2in #call eprintf ("x1=%d x2=%d y1=%d y2=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call eprintf ("nimage=%d ocx1=%d ocx2=%d ocy1=%d ocy2=%d\n") #call pargi (nimage) #call pargi (ocx1) #call pargi (ocx2) #call pargi (ocy1) #call pargi (ocy2) # Complain if section totaly out of bounds if (x2 < ocx1 || x1 > ocx2 || y1 < ocy1 || y1 > ocy2) call syserrs (SYS_IMREFOOB, Memc[MI_RNAME(mi)]) # Clip section at boundary of mosaic ox1 = max (x1, ocx1) ox2 = min (x2, ocx2) oy1 = max (y1, ocy1) oy2 = min (y2, ocy2) onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 npix = onx * ony #call eprintf ("ox1=%d ox2=%d oy1=%d oy2=%d onx=%d ony=%d npix=%d\n") #call pargi (ox1) #call pargi (ox2) #call pargi (oy1) #call pargi (oy2) #call pargi (onx) #call pargi (ony) #call pargi (npix) # First trip. Allocate data buffer if (MI_SB(mi) == NULL) { call malloc (sb, LEN_SECBUFF, TY_STRUCT) MI_SB(mi) = sb SB_DATA(sb) = NULL # Set null section in SB to ensure buffer will be filled SB_X1(sb) = 0 SB_X2(sb) = 0 SB_Y1(sb) = 0 SB_Y2(sb) = 0 SB_PIXTYPE(sb) = TY_DOUBLE } else { sb = MI_SB(mi) } #call eprintf ("sb_x1=%d sb_x2=%d sb_y1=%d sb_y2=%d\n") #call pargi (SB_X1(sb)) #call pargi (SB_X2(sb)) #call pargi (SB_Y1(sb)) #call pargi (SB_Y2(sb)) # The requested section is entirely outside the buffer if ((SB_X2(sb) < ox1) || (SB_X1(sb) > ox2) || (SB_Y2(sb) < oy1) || (SB_Y1(sb) > oy2)) { # Free old data buffer. if (SB_DATA(sb) != NULL) call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Allocate new buffer and initialise to blank value call malloc (obuf, npix, TY_DOUBLE) call amovkd (double(blank), Memd[obuf], npix) call migetsd (mi, ox1, ox2, oy1, oy2, ox1, ox2, oy1, oy2, obuf) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_DOUBLE return (SB_DATA(sb)) # Exactly the requested section is already in the buffer } else if ((SB_X1(sb) == ox1) && (SB_X2(sb) == ox2) && (SB_Y1(sb) == oy1) && (SB_Y2(sb) == oy2)) { # and is the correct data type. We are done! if (SB_PIXTYPE(sb) == TY_DOUBLE) { return (SB_DATA(sb)) # Change data type and return } else { call malloc (obuf, npix, TY_DOUBLE) switch (SB_PIXTYPE(sb)) { case TY_SHORT: call achtsd (Mems[SB_DATA(sb)], Memd[obuf], npix) # case TY_USHORT: # call achtu$t (Memu[SB_DATA(sb)], Mem$t[obuf], npix) case TY_INT: call achtid (Memi[SB_DATA(sb)], Memd[obuf], npix) case TY_LONG: call achtld (Meml[SB_DATA(sb)], Memd[obuf], npix) case TY_REAL: call achtrd (Memr[SB_DATA(sb)], Memd[obuf], npix) case TY_DOUBLE: call achtdd (Memd[SB_DATA(sb)], Memd[obuf], npix) } # Free old buffer call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) # Return new buffer SB_DATA(sb) = obuf SB_PIXTYPE(sb) = TY_DOUBLE return (SB_DATA(sb)) } # The requested section is entirely contained in the buffer } else if ((SB_X1(sb) <= ox1) && (SB_X2(sb) >= ox2) && (SB_Y1(sb) <= oy1) && (SB_Y2(sb) >= oy2)) { # Copy the part we need to a new buffer call malloc (obuf, npix, TY_DOUBLE) call micpy (sb, ox1, ox2, oy1, oy2, TY_DOUBLE, obuf) SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_DOUBLE # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf return (SB_DATA(sb)) # The requested section partialy overlaps the data buffer (oh joy!) } else { # Allocate a new buffer and initialise to blank value call malloc (obuf, npix, TY_DOUBLE) call amovkd (double(blank), Memd[obuf], npix) # Copy what we can from the buffer. call micpy (sb, ox1, ox2, oy1, oy2, TY_DOUBLE, obuf) # Fill out the rest by reading the images. if (oy1 < SB_Y1(sb)) call migetsd (mi, ox1, ox2, oy1, SB_Y1(sb)-1, ox1, ox2, oy1, oy2, obuf) if (ox1 < SB_X1(sb)) call migetsd (mi, ox1, SB_X1(sb)-1, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (ox2 > SB_X2(sb)) call migetsd (mi, SB_X2(sb)+1, ox2, SB_Y1(sb), SB_Y2(sb), ox1, ox2, oy1, oy2, obuf) if (oy2 > SB_Y2(sb)) call migetsd (mi, ox1, ox2, SB_Y2(sb)+1, oy2, ox1, ox2, oy1, oy2, obuf) # Free old data buffer. call mfree (SB_DATA(sb), SB_PIXTYPE(sb)) SB_DATA(sb) = obuf SB_X1(sb) = ox1 SB_X2(sb) = ox2 SB_Y1(sb) = oy1 SB_Y2(sb) = oy2 SB_PIXTYPE(sb) = TY_DOUBLE return (SB_DATA(sb)) } end # MIGETSx -- Fill rectangle in output buffer from input images. # The section requested may be larger or smaller than the output buffer. # In the former case we only return the piece which maps into the output # buffer. In the latter case we fill a portion of the output buffer with # data read from the images. procedure migetss (mi, x1, x2, y1, y2, ox1, ox2, oy1, oy2, obuf) pointer mi #I MOSIM Pointer for mosaic. int x1, x2 #I Range of columns in required section. int y1, y2 #I Range of columns in required section. int ox1, ox2 #I Range of columns in output buffer. int oy1, oy2 #I Range of columns in output buffer. pointer obuf #O pointer to data values. int image, i, j, k, line, novr, bx1, bx2 int onx, ox0, ix1, ix2, cx1, cx2, sx1, sx2, nx int ony, oy0, iy1, iy2, cy1, cy2, sy1, sy2, ny real sdx1, sdx2, sdy1, sdy2 pointer img, iim, ibuf, bbuf, ptr short junk pointer mscs2s() errchk mscs2s, miprocs() include "mosproc.com" # Macros to "simplify" array indexing define IPTR (ibuf + ($2-1)*nx + ($1-1)) define OPTR (obuf + ($2+oy0-1)*onx + ($1+ox0-1)) define IPTR1 (ibuf + ($1-1)*nx) define OPTR1 (obuf + ($1+oy0-1)*onx + ox0) define BPTR1 (bbuf + ($1-1)*novr) begin # Dimensions of output buffer onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 # Clip requested section at boundary of input buffer. ix1 = max (x1, ox1) ix2 = min (x2, ox2) iy1 = max (y1, oy1) iy2 = min (y2, oy2) # Loop over input images, skipping those which have no data within # the requested section do image = 1, MI_NIMS(mi) { img = MI_MG(mi, image) # "CCD" coordinates of corners of DATASEC of this image cx1 = CX1(img) cx2 = CX2(img) cy1 = CY1(img) cy2 = CY2(img) if (ix1 > cx2 || ix2 < cx1 || iy2 < cy1 || iy1 > cy2) { next } # "CCD" coordinates of the section of this image we want cx1 = max (ix1, cx1) cx2 = min (ix2, cx2) cy1 = max (iy1, cy1) cy2 = min (iy2, cy2) nx = cx2 - cx1 + 1 ny = cy2 - cy1 + 1 # "IMAGE" coordinates of the section of this image we want sdx1 = DX(img) sdx2 = (DX(img) - 1) / 2. sdy1 = DY(img) sdy2 = (DY(img) - 1) / 2. sx1 = nint ((cx1 - CX1(img) - sdx2) / sdx1 + DX1(img)) sx2 = nint ((cx2 - CX1(img) - sdx2) / sdx1 + DX1(img)) sy1 = nint ((cy1 - CY1(img) - sdy2) / sdy1 + DY1(img)) sy2 = nint ((cy2 - CY1(img) - sdy2) / sdy1 + DY1(img)) # Read required section of this image and replicate if necessary. iim = MI_IM(mi, image) if (DX(img) == 1 && DY(img) == 1) ibuf = mscs2s (img, sx1, sx2, sy1, sy2) else { call malloc (ibuf, nx * ny, TY_SHORT) ptr = ibuf do j = cy1, cy2 { sy1 = nint ((j-CY1(img)-sdy2)/sdy1+DY1(img)) bbuf = mscs2s (img, sx1, sx2, sy1, sy1) do i = cx1, cx2 { k = nint ((i-CX1(img)-sdx2)/sdx1+DX1(img)) - sx1 Mems[ptr] = Mems[bbuf+k] ptr = ptr + 1 } } } # Process input image section line by line writing to output buffer # Offsets to starting point in output for data from this image ox0 = cx1 - ox1 oy0 = cy1 - oy1 # Read corresponding overscan data if needed. if (and(proc, L) != 0) { bx1 = BX1(img) bx2 = BX2(img) novr = bx2 - bx1 + 1 bbuf = mscs2s (img, bx1, bx2, sy1, sy2) do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocs (img, Mems[IPTR1(j)], Mems[OPTR1(j)], nx, line, Mems[BPTR1(j)], novr) } } else { do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocs (img, Mems[IPTR1(j)], Mems[OPTR1(j)], nx, line, junk, 0) } } if (DX(img) != 1 || DY(img) != 1) call mfree (ibuf, TY_SHORT) } end # MIGETSx -- Fill rectangle in output buffer from input images. # The section requested may be larger or smaller than the output buffer. # In the former case we only return the piece which maps into the output # buffer. In the latter case we fill a portion of the output buffer with # data read from the images. procedure migetsi (mi, x1, x2, y1, y2, ox1, ox2, oy1, oy2, obuf) pointer mi #I MOSIM Pointer for mosaic. int x1, x2 #I Range of columns in required section. int y1, y2 #I Range of columns in required section. int ox1, ox2 #I Range of columns in output buffer. int oy1, oy2 #I Range of columns in output buffer. pointer obuf #O pointer to data values. int image, i, j, k, line, novr, bx1, bx2 int onx, ox0, ix1, ix2, cx1, cx2, sx1, sx2, nx int ony, oy0, iy1, iy2, cy1, cy2, sy1, sy2, ny real sdx1, sdx2, sdy1, sdy2 pointer img, iim, ibuf, bbuf, ptr int junk pointer mscs2i() errchk mscs2i, miproci() include "mosproc.com" # Macros to "simplify" array indexing define IPTR (ibuf + ($2-1)*nx + ($1-1)) define OPTR (obuf + ($2+oy0-1)*onx + ($1+ox0-1)) define IPTR1 (ibuf + ($1-1)*nx) define OPTR1 (obuf + ($1+oy0-1)*onx + ox0) define BPTR1 (bbuf + ($1-1)*novr) begin # Dimensions of output buffer onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 # Clip requested section at boundary of input buffer. ix1 = max (x1, ox1) ix2 = min (x2, ox2) iy1 = max (y1, oy1) iy2 = min (y2, oy2) # Loop over input images, skipping those which have no data within # the requested section do image = 1, MI_NIMS(mi) { img = MI_MG(mi, image) # "CCD" coordinates of corners of DATASEC of this image cx1 = CX1(img) cx2 = CX2(img) cy1 = CY1(img) cy2 = CY2(img) if (ix1 > cx2 || ix2 < cx1 || iy2 < cy1 || iy1 > cy2) { next } # "CCD" coordinates of the section of this image we want cx1 = max (ix1, cx1) cx2 = min (ix2, cx2) cy1 = max (iy1, cy1) cy2 = min (iy2, cy2) nx = cx2 - cx1 + 1 ny = cy2 - cy1 + 1 # "IMAGE" coordinates of the section of this image we want sdx1 = DX(img) sdx2 = (DX(img) - 1) / 2. sdy1 = DY(img) sdy2 = (DY(img) - 1) / 2. sx1 = nint ((cx1 - CX1(img) - sdx2) / sdx1 + DX1(img)) sx2 = nint ((cx2 - CX1(img) - sdx2) / sdx1 + DX1(img)) sy1 = nint ((cy1 - CY1(img) - sdy2) / sdy1 + DY1(img)) sy2 = nint ((cy2 - CY1(img) - sdy2) / sdy1 + DY1(img)) # Read required section of this image and replicate if necessary. iim = MI_IM(mi, image) if (DX(img) == 1 && DY(img) == 1) ibuf = mscs2i (img, sx1, sx2, sy1, sy2) else { call malloc (ibuf, nx * ny, TY_INT) ptr = ibuf do j = cy1, cy2 { sy1 = nint ((j-CY1(img)-sdy2)/sdy1+DY1(img)) bbuf = mscs2i (img, sx1, sx2, sy1, sy1) do i = cx1, cx2 { k = nint ((i-CX1(img)-sdx2)/sdx1+DX1(img)) - sx1 Memi[ptr] = Memi[bbuf+k] ptr = ptr + 1 } } } # Process input image section line by line writing to output buffer # Offsets to starting point in output for data from this image ox0 = cx1 - ox1 oy0 = cy1 - oy1 # Read corresponding overscan data if needed. if (and(proc, L) != 0) { bx1 = BX1(img) bx2 = BX2(img) novr = bx2 - bx1 + 1 bbuf = mscs2i (img, bx1, bx2, sy1, sy2) do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miproci (img, Memi[IPTR1(j)], Memi[OPTR1(j)], nx, line, Memi[BPTR1(j)], novr) } } else { do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miproci (img, Memi[IPTR1(j)], Memi[OPTR1(j)], nx, line, junk, 0) } } if (DX(img) != 1 || DY(img) != 1) call mfree (ibuf, TY_INT) } end # MIGETSx -- Fill rectangle in output buffer from input images. # The section requested may be larger or smaller than the output buffer. # In the former case we only return the piece which maps into the output # buffer. In the latter case we fill a portion of the output buffer with # data read from the images. procedure migetsl (mi, x1, x2, y1, y2, ox1, ox2, oy1, oy2, obuf) pointer mi #I MOSIM Pointer for mosaic. int x1, x2 #I Range of columns in required section. int y1, y2 #I Range of columns in required section. int ox1, ox2 #I Range of columns in output buffer. int oy1, oy2 #I Range of columns in output buffer. pointer obuf #O pointer to data values. int image, i, j, k, line, novr, bx1, bx2 int onx, ox0, ix1, ix2, cx1, cx2, sx1, sx2, nx int ony, oy0, iy1, iy2, cy1, cy2, sy1, sy2, ny real sdx1, sdx2, sdy1, sdy2 pointer img, iim, ibuf, bbuf, ptr long junk pointer mscs2l() errchk mscs2l, miprocl() include "mosproc.com" # Macros to "simplify" array indexing define IPTR (ibuf + ($2-1)*nx + ($1-1)) define OPTR (obuf + ($2+oy0-1)*onx + ($1+ox0-1)) define IPTR1 (ibuf + ($1-1)*nx) define OPTR1 (obuf + ($1+oy0-1)*onx + ox0) define BPTR1 (bbuf + ($1-1)*novr) begin # Dimensions of output buffer onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 # Clip requested section at boundary of input buffer. ix1 = max (x1, ox1) ix2 = min (x2, ox2) iy1 = max (y1, oy1) iy2 = min (y2, oy2) # Loop over input images, skipping those which have no data within # the requested section do image = 1, MI_NIMS(mi) { img = MI_MG(mi, image) # "CCD" coordinates of corners of DATASEC of this image cx1 = CX1(img) cx2 = CX2(img) cy1 = CY1(img) cy2 = CY2(img) if (ix1 > cx2 || ix2 < cx1 || iy2 < cy1 || iy1 > cy2) { next } # "CCD" coordinates of the section of this image we want cx1 = max (ix1, cx1) cx2 = min (ix2, cx2) cy1 = max (iy1, cy1) cy2 = min (iy2, cy2) nx = cx2 - cx1 + 1 ny = cy2 - cy1 + 1 # "IMAGE" coordinates of the section of this image we want sdx1 = DX(img) sdx2 = (DX(img) - 1) / 2. sdy1 = DY(img) sdy2 = (DY(img) - 1) / 2. sx1 = nint ((cx1 - CX1(img) - sdx2) / sdx1 + DX1(img)) sx2 = nint ((cx2 - CX1(img) - sdx2) / sdx1 + DX1(img)) sy1 = nint ((cy1 - CY1(img) - sdy2) / sdy1 + DY1(img)) sy2 = nint ((cy2 - CY1(img) - sdy2) / sdy1 + DY1(img)) # Read required section of this image and replicate if necessary. iim = MI_IM(mi, image) if (DX(img) == 1 && DY(img) == 1) ibuf = mscs2l (img, sx1, sx2, sy1, sy2) else { call malloc (ibuf, nx * ny, TY_LONG) ptr = ibuf do j = cy1, cy2 { sy1 = nint ((j-CY1(img)-sdy2)/sdy1+DY1(img)) bbuf = mscs2l (img, sx1, sx2, sy1, sy1) do i = cx1, cx2 { k = nint ((i-CX1(img)-sdx2)/sdx1+DX1(img)) - sx1 Meml[ptr] = Meml[bbuf+k] ptr = ptr + 1 } } } # Process input image section line by line writing to output buffer # Offsets to starting point in output for data from this image ox0 = cx1 - ox1 oy0 = cy1 - oy1 # Read corresponding overscan data if needed. if (and(proc, L) != 0) { bx1 = BX1(img) bx2 = BX2(img) novr = bx2 - bx1 + 1 bbuf = mscs2l (img, bx1, bx2, sy1, sy2) do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocl (img, Meml[IPTR1(j)], Meml[OPTR1(j)], nx, line, Meml[BPTR1(j)], novr) } } else { do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocl (img, Meml[IPTR1(j)], Meml[OPTR1(j)], nx, line, junk, 0) } } if (DX(img) != 1 || DY(img) != 1) call mfree (ibuf, TY_LONG) } end # MIGETSx -- Fill rectangle in output buffer from input images. # The section requested may be larger or smaller than the output buffer. # In the former case we only return the piece which maps into the output # buffer. In the latter case we fill a portion of the output buffer with # data read from the images. procedure migetsr (mi, x1, x2, y1, y2, ox1, ox2, oy1, oy2, obuf) pointer mi #I MOSIM Pointer for mosaic. int x1, x2 #I Range of columns in required section. int y1, y2 #I Range of columns in required section. int ox1, ox2 #I Range of columns in output buffer. int oy1, oy2 #I Range of columns in output buffer. pointer obuf #O pointer to data values. int image, i, j, k, line, novr, bx1, bx2 int onx, ox0, ix1, ix2, cx1, cx2, sx1, sx2, nx int ony, oy0, iy1, iy2, cy1, cy2, sy1, sy2, ny real sdx1, sdx2, sdy1, sdy2 pointer img, iim, ibuf, bbuf, ptr real junk pointer mscs2r() errchk mscs2r, miprocr() include "mosproc.com" # Macros to "simplify" array indexing define IPTR (ibuf + ($2-1)*nx + ($1-1)) define OPTR (obuf + ($2+oy0-1)*onx + ($1+ox0-1)) define IPTR1 (ibuf + ($1-1)*nx) define OPTR1 (obuf + ($1+oy0-1)*onx + ox0) define BPTR1 (bbuf + ($1-1)*novr) begin # Dimensions of output buffer onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 # Clip requested section at boundary of input buffer. ix1 = max (x1, ox1) ix2 = min (x2, ox2) iy1 = max (y1, oy1) iy2 = min (y2, oy2) # Loop over input images, skipping those which have no data within # the requested section do image = 1, MI_NIMS(mi) { img = MI_MG(mi, image) # "CCD" coordinates of corners of DATASEC of this image cx1 = CX1(img) cx2 = CX2(img) cy1 = CY1(img) cy2 = CY2(img) if (ix1 > cx2 || ix2 < cx1 || iy2 < cy1 || iy1 > cy2) { next } # "CCD" coordinates of the section of this image we want cx1 = max (ix1, cx1) cx2 = min (ix2, cx2) cy1 = max (iy1, cy1) cy2 = min (iy2, cy2) nx = cx2 - cx1 + 1 ny = cy2 - cy1 + 1 # "IMAGE" coordinates of the section of this image we want sdx1 = DX(img) sdx2 = (DX(img) - 1) / 2. sdy1 = DY(img) sdy2 = (DY(img) - 1) / 2. sx1 = nint ((cx1 - CX1(img) - sdx2) / sdx1 + DX1(img)) sx2 = nint ((cx2 - CX1(img) - sdx2) / sdx1 + DX1(img)) sy1 = nint ((cy1 - CY1(img) - sdy2) / sdy1 + DY1(img)) sy2 = nint ((cy2 - CY1(img) - sdy2) / sdy1 + DY1(img)) # Read required section of this image and replicate if necessary. iim = MI_IM(mi, image) if (DX(img) == 1 && DY(img) == 1) ibuf = mscs2r (img, sx1, sx2, sy1, sy2) else { call malloc (ibuf, nx * ny, TY_REAL) ptr = ibuf do j = cy1, cy2 { sy1 = nint ((j-CY1(img)-sdy2)/sdy1+DY1(img)) bbuf = mscs2r (img, sx1, sx2, sy1, sy1) do i = cx1, cx2 { k = nint ((i-CX1(img)-sdx2)/sdx1+DX1(img)) - sx1 Memr[ptr] = Memr[bbuf+k] ptr = ptr + 1 } } } # Process input image section line by line writing to output buffer # Offsets to starting point in output for data from this image ox0 = cx1 - ox1 oy0 = cy1 - oy1 # Read corresponding overscan data if needed. if (and(proc, L) != 0) { bx1 = BX1(img) bx2 = BX2(img) novr = bx2 - bx1 + 1 bbuf = mscs2r (img, bx1, bx2, sy1, sy2) do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocr (img, Memr[IPTR1(j)], Memr[OPTR1(j)], nx, line, Memr[BPTR1(j)], novr) } } else { do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocr (img, Memr[IPTR1(j)], Memr[OPTR1(j)], nx, line, junk, 0) } } if (DX(img) != 1 || DY(img) != 1) call mfree (ibuf, TY_REAL) } end # MIGETSx -- Fill rectangle in output buffer from input images. # The section requested may be larger or smaller than the output buffer. # In the former case we only return the piece which maps into the output # buffer. In the latter case we fill a portion of the output buffer with # data read from the images. procedure migetsd (mi, x1, x2, y1, y2, ox1, ox2, oy1, oy2, obuf) pointer mi #I MOSIM Pointer for mosaic. int x1, x2 #I Range of columns in required section. int y1, y2 #I Range of columns in required section. int ox1, ox2 #I Range of columns in output buffer. int oy1, oy2 #I Range of columns in output buffer. pointer obuf #O pointer to data values. int image, i, j, k, line, novr, bx1, bx2 int onx, ox0, ix1, ix2, cx1, cx2, sx1, sx2, nx int ony, oy0, iy1, iy2, cy1, cy2, sy1, sy2, ny real sdx1, sdx2, sdy1, sdy2 pointer img, iim, ibuf, bbuf, ptr double junk pointer mscs2d() errchk mscs2d, miprocd() include "mosproc.com" # Macros to "simplify" array indexing define IPTR (ibuf + ($2-1)*nx + ($1-1)) define OPTR (obuf + ($2+oy0-1)*onx + ($1+ox0-1)) define IPTR1 (ibuf + ($1-1)*nx) define OPTR1 (obuf + ($1+oy0-1)*onx + ox0) define BPTR1 (bbuf + ($1-1)*novr) begin # Dimensions of output buffer onx = ox2 - ox1 + 1 ony = oy2 - oy1 + 1 # Clip requested section at boundary of input buffer. ix1 = max (x1, ox1) ix2 = min (x2, ox2) iy1 = max (y1, oy1) iy2 = min (y2, oy2) # Loop over input images, skipping those which have no data within # the requested section do image = 1, MI_NIMS(mi) { img = MI_MG(mi, image) # "CCD" coordinates of corners of DATASEC of this image cx1 = CX1(img) cx2 = CX2(img) cy1 = CY1(img) cy2 = CY2(img) if (ix1 > cx2 || ix2 < cx1 || iy2 < cy1 || iy1 > cy2) { next } # "CCD" coordinates of the section of this image we want cx1 = max (ix1, cx1) cx2 = min (ix2, cx2) cy1 = max (iy1, cy1) cy2 = min (iy2, cy2) nx = cx2 - cx1 + 1 ny = cy2 - cy1 + 1 # "IMAGE" coordinates of the section of this image we want sdx1 = DX(img) sdx2 = (DX(img) - 1) / 2. sdy1 = DY(img) sdy2 = (DY(img) - 1) / 2. sx1 = nint ((cx1 - CX1(img) - sdx2) / sdx1 + DX1(img)) sx2 = nint ((cx2 - CX1(img) - sdx2) / sdx1 + DX1(img)) sy1 = nint ((cy1 - CY1(img) - sdy2) / sdy1 + DY1(img)) sy2 = nint ((cy2 - CY1(img) - sdy2) / sdy1 + DY1(img)) # Read required section of this image and replicate if necessary. iim = MI_IM(mi, image) if (DX(img) == 1 && DY(img) == 1) ibuf = mscs2d (img, sx1, sx2, sy1, sy2) else { call malloc (ibuf, nx * ny, TY_DOUBLE) ptr = ibuf do j = cy1, cy2 { sy1 = nint ((j-CY1(img)-sdy2)/sdy1+DY1(img)) bbuf = mscs2d (img, sx1, sx2, sy1, sy1) do i = cx1, cx2 { k = nint ((i-CX1(img)-sdx2)/sdx1+DX1(img)) - sx1 Memd[ptr] = Memd[bbuf+k] ptr = ptr + 1 } } } # Process input image section line by line writing to output buffer # Offsets to starting point in output for data from this image ox0 = cx1 - ox1 oy0 = cy1 - oy1 # Read corresponding overscan data if needed. if (and(proc, L) != 0) { bx1 = BX1(img) bx2 = BX2(img) novr = bx2 - bx1 + 1 bbuf = mscs2d (img, bx1, bx2, sy1, sy2) do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocd (img, Memd[IPTR1(j)], Memd[OPTR1(j)], nx, line, Memd[BPTR1(j)], novr) } } else { do j = 1, ny { line = nint ((j - CY1(img) - sdy2) / sdy1 + DY1(img)) call miprocd (img, Memd[IPTR1(j)], Memd[OPTR1(j)], nx, line, junk, 0) } } if (DX(img) != 1 || DY(img) != 1) call mfree (ibuf, TY_DOUBLE) } end # MICPY -- Fill rectangle in output buffer by copying from the internal buffer procedure micpy (sb, x1, x2, y1, y2, otype, obuf) pointer sb #I Pointer to section data sub-structure int x1, x2 #I Range of columns in section. int y1, y2 #I Range of lines in section. int otype #I Desired type of output data. pointer obuf #O pointer to data values. begin switch (otype) { case TY_SHORT: call micpys (sb, x1, x2, y1, y2, obuf) # case TY_USHORT: # call micpyu (sb, x1, x2, y1, y2, obuf) case TY_INT: call micpyi (sb, x1, x2, y1, y2, obuf) case TY_LONG: call micpyl (sb, x1, x2, y1, y2, obuf) case TY_REAL: call micpyr (sb, x1, x2, y1, y2, obuf) case TY_DOUBLE: call micpyd (sb, x1, x2, y1, y2, obuf) } end # MICPYx -- Fill rectangle in output buffer by copying from the internal buffer # The data is type converted if neccesary. The section requested may be # larger or smaller than that available in the internal buffer. In the # former case we just fill the part of the output buffer for which we have # data. In the latter case we copy a subsection of the internal buffer to # output. procedure micpys (sb, x1, x2, y1, y2, obuf) pointer sb #I Pointer to section data sub-structure. int x1, x2 #I Range of columns in requested section. int y1, y2 #I Range of lines in requested section. pointer obuf #O pointer to data values. int j, i, btype int nx, x0, bnx, bx1, bx2, bx0, sx1, sx2, snx int ny, y0, bny, by1, by2, by0, sy1, sy2, sny pointer ibuf # Macros to "simplify" array indexing define IPTR (ibuf + ($2+by0-1)*bnx + ($1+bx0-1)) define OPTR (obuf + ($2+y0-1)*nx + ($1+x0-1)) begin #call eprintf ("MICPY\n") # dimensions of output buffer nx = x2 - x1 + 1 ny = y2 - y1 + 1 #call eprintf ("\t x1=%d x2=%d y1=%d y2=%d nx=%d ny=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call pargi (nx) #call pargi (ny) # Coordinates etc. of internal buffer ibuf = SB_DATA(sb) bx1 = SB_X1(sb) bx2 = SB_X2(sb) by1 = SB_Y1(sb) by2 = SB_Y2(sb) bnx = bx2 - bx1 + 1 bny = by2 - by1 + 1 btype = SB_PIXTYPE(sb) #call eprintf ("\tbx1=%d bx2=%d by1=%d by2=%d bnx=%d bny=%d\n") #call pargi (bx1) #call pargi (bx2) #call pargi (by1) #call pargi (by2) #call pargi (bnx) #call pargi (bny) # offset to starting point in output buffer x0 = max ((bx1 - x1), 0) y0 = max ((by1 - y1), 0) # Offset to starting point in internal buffer bx0 = max ((x1 - bx1), 0) by0 = max ((y1 - by1), 0) #call eprintf ("\tx0=%d y0=%d bx0=%d bx0=%d\n") #call pargi (x0) #call pargi (y0) #call pargi (bx0) #call pargi (by0) # Coordinates of the piece we have in the internal buffer. sx1 = max (x1, bx1) sx2 = min (x2, bx2) sy1 = max (y1, by1) sy2 = min (y2, by2) # Number of pixels to copy. snx = sx2 - sx1 + 1 sny = sy2 - sy1 + 1 #call eprintf ("\tsx1=%d sx2=%d sy1=%d sy2=%d snx=%d sny=%d\n") #call pargi (sx1) #call pargi (sx2) #call pargi (sy1) #call pargi (sy2) #call pargi (snx) #call pargi (sny) switch (btype) { case TY_SHORT: do j = 1, sny { do i = 1, snx Mems[OPTR(i, j)] = Mems[IPTR(i,j)] } case TY_INT: do j = 1, sny { do i = 1, snx Mems[OPTR(i, j)] = Memi[IPTR(i,j)] } case TY_LONG: do j = 1, sny { do i = 1, snx Mems[OPTR(i, j)] = Meml[IPTR(i,j)] } case TY_REAL: do j = 1, sny { do i = 1, snx Mems[OPTR(i, j)] = Memr[IPTR(i,j)] } case TY_DOUBLE: do j = 1, sny { do i = 1, snx Mems[OPTR(i, j)] = Memd[IPTR(i,j)] } } end # MICPYx -- Fill rectangle in output buffer by copying from the internal buffer # The data is type converted if neccesary. The section requested may be # larger or smaller than that available in the internal buffer. In the # former case we just fill the part of the output buffer for which we have # data. In the latter case we copy a subsection of the internal buffer to # output. procedure micpyi (sb, x1, x2, y1, y2, obuf) pointer sb #I Pointer to section data sub-structure. int x1, x2 #I Range of columns in requested section. int y1, y2 #I Range of lines in requested section. pointer obuf #O pointer to data values. int j, i, btype int nx, x0, bnx, bx1, bx2, bx0, sx1, sx2, snx int ny, y0, bny, by1, by2, by0, sy1, sy2, sny pointer ibuf # Macros to "simplify" array indexing define IPTR (ibuf + ($2+by0-1)*bnx + ($1+bx0-1)) define OPTR (obuf + ($2+y0-1)*nx + ($1+x0-1)) begin #call eprintf ("MICPY\n") # dimensions of output buffer nx = x2 - x1 + 1 ny = y2 - y1 + 1 #call eprintf ("\t x1=%d x2=%d y1=%d y2=%d nx=%d ny=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call pargi (nx) #call pargi (ny) # Coordinates etc. of internal buffer ibuf = SB_DATA(sb) bx1 = SB_X1(sb) bx2 = SB_X2(sb) by1 = SB_Y1(sb) by2 = SB_Y2(sb) bnx = bx2 - bx1 + 1 bny = by2 - by1 + 1 btype = SB_PIXTYPE(sb) #call eprintf ("\tbx1=%d bx2=%d by1=%d by2=%d bnx=%d bny=%d\n") #call pargi (bx1) #call pargi (bx2) #call pargi (by1) #call pargi (by2) #call pargi (bnx) #call pargi (bny) # offset to starting point in output buffer x0 = max ((bx1 - x1), 0) y0 = max ((by1 - y1), 0) # Offset to starting point in internal buffer bx0 = max ((x1 - bx1), 0) by0 = max ((y1 - by1), 0) #call eprintf ("\tx0=%d y0=%d bx0=%d bx0=%d\n") #call pargi (x0) #call pargi (y0) #call pargi (bx0) #call pargi (by0) # Coordinates of the piece we have in the internal buffer. sx1 = max (x1, bx1) sx2 = min (x2, bx2) sy1 = max (y1, by1) sy2 = min (y2, by2) # Number of pixels to copy. snx = sx2 - sx1 + 1 sny = sy2 - sy1 + 1 #call eprintf ("\tsx1=%d sx2=%d sy1=%d sy2=%d snx=%d sny=%d\n") #call pargi (sx1) #call pargi (sx2) #call pargi (sy1) #call pargi (sy2) #call pargi (snx) #call pargi (sny) switch (btype) { case TY_SHORT: do j = 1, sny { do i = 1, snx Memi[OPTR(i, j)] = Mems[IPTR(i,j)] } case TY_INT: do j = 1, sny { do i = 1, snx Memi[OPTR(i, j)] = Memi[IPTR(i,j)] } case TY_LONG: do j = 1, sny { do i = 1, snx Memi[OPTR(i, j)] = Meml[IPTR(i,j)] } case TY_REAL: do j = 1, sny { do i = 1, snx Memi[OPTR(i, j)] = Memr[IPTR(i,j)] } case TY_DOUBLE: do j = 1, sny { do i = 1, snx Memi[OPTR(i, j)] = Memd[IPTR(i,j)] } } end # MICPYx -- Fill rectangle in output buffer by copying from the internal buffer # The data is type converted if neccesary. The section requested may be # larger or smaller than that available in the internal buffer. In the # former case we just fill the part of the output buffer for which we have # data. In the latter case we copy a subsection of the internal buffer to # output. procedure micpyl (sb, x1, x2, y1, y2, obuf) pointer sb #I Pointer to section data sub-structure. int x1, x2 #I Range of columns in requested section. int y1, y2 #I Range of lines in requested section. pointer obuf #O pointer to data values. int j, i, btype int nx, x0, bnx, bx1, bx2, bx0, sx1, sx2, snx int ny, y0, bny, by1, by2, by0, sy1, sy2, sny pointer ibuf # Macros to "simplify" array indexing define IPTR (ibuf + ($2+by0-1)*bnx + ($1+bx0-1)) define OPTR (obuf + ($2+y0-1)*nx + ($1+x0-1)) begin #call eprintf ("MICPY\n") # dimensions of output buffer nx = x2 - x1 + 1 ny = y2 - y1 + 1 #call eprintf ("\t x1=%d x2=%d y1=%d y2=%d nx=%d ny=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call pargi (nx) #call pargi (ny) # Coordinates etc. of internal buffer ibuf = SB_DATA(sb) bx1 = SB_X1(sb) bx2 = SB_X2(sb) by1 = SB_Y1(sb) by2 = SB_Y2(sb) bnx = bx2 - bx1 + 1 bny = by2 - by1 + 1 btype = SB_PIXTYPE(sb) #call eprintf ("\tbx1=%d bx2=%d by1=%d by2=%d bnx=%d bny=%d\n") #call pargi (bx1) #call pargi (bx2) #call pargi (by1) #call pargi (by2) #call pargi (bnx) #call pargi (bny) # offset to starting point in output buffer x0 = max ((bx1 - x1), 0) y0 = max ((by1 - y1), 0) # Offset to starting point in internal buffer bx0 = max ((x1 - bx1), 0) by0 = max ((y1 - by1), 0) #call eprintf ("\tx0=%d y0=%d bx0=%d bx0=%d\n") #call pargi (x0) #call pargi (y0) #call pargi (bx0) #call pargi (by0) # Coordinates of the piece we have in the internal buffer. sx1 = max (x1, bx1) sx2 = min (x2, bx2) sy1 = max (y1, by1) sy2 = min (y2, by2) # Number of pixels to copy. snx = sx2 - sx1 + 1 sny = sy2 - sy1 + 1 #call eprintf ("\tsx1=%d sx2=%d sy1=%d sy2=%d snx=%d sny=%d\n") #call pargi (sx1) #call pargi (sx2) #call pargi (sy1) #call pargi (sy2) #call pargi (snx) #call pargi (sny) switch (btype) { case TY_SHORT: do j = 1, sny { do i = 1, snx Meml[OPTR(i, j)] = Mems[IPTR(i,j)] } case TY_INT: do j = 1, sny { do i = 1, snx Meml[OPTR(i, j)] = Memi[IPTR(i,j)] } case TY_LONG: do j = 1, sny { do i = 1, snx Meml[OPTR(i, j)] = Meml[IPTR(i,j)] } case TY_REAL: do j = 1, sny { do i = 1, snx Meml[OPTR(i, j)] = Memr[IPTR(i,j)] } case TY_DOUBLE: do j = 1, sny { do i = 1, snx Meml[OPTR(i, j)] = Memd[IPTR(i,j)] } } end # MICPYx -- Fill rectangle in output buffer by copying from the internal buffer # The data is type converted if neccesary. The section requested may be # larger or smaller than that available in the internal buffer. In the # former case we just fill the part of the output buffer for which we have # data. In the latter case we copy a subsection of the internal buffer to # output. procedure micpyr (sb, x1, x2, y1, y2, obuf) pointer sb #I Pointer to section data sub-structure. int x1, x2 #I Range of columns in requested section. int y1, y2 #I Range of lines in requested section. pointer obuf #O pointer to data values. int j, i, btype int nx, x0, bnx, bx1, bx2, bx0, sx1, sx2, snx int ny, y0, bny, by1, by2, by0, sy1, sy2, sny pointer ibuf # Macros to "simplify" array indexing define IPTR (ibuf + ($2+by0-1)*bnx + ($1+bx0-1)) define OPTR (obuf + ($2+y0-1)*nx + ($1+x0-1)) begin #call eprintf ("MICPY\n") # dimensions of output buffer nx = x2 - x1 + 1 ny = y2 - y1 + 1 #call eprintf ("\t x1=%d x2=%d y1=%d y2=%d nx=%d ny=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call pargi (nx) #call pargi (ny) # Coordinates etc. of internal buffer ibuf = SB_DATA(sb) bx1 = SB_X1(sb) bx2 = SB_X2(sb) by1 = SB_Y1(sb) by2 = SB_Y2(sb) bnx = bx2 - bx1 + 1 bny = by2 - by1 + 1 btype = SB_PIXTYPE(sb) #call eprintf ("\tbx1=%d bx2=%d by1=%d by2=%d bnx=%d bny=%d\n") #call pargi (bx1) #call pargi (bx2) #call pargi (by1) #call pargi (by2) #call pargi (bnx) #call pargi (bny) # offset to starting point in output buffer x0 = max ((bx1 - x1), 0) y0 = max ((by1 - y1), 0) # Offset to starting point in internal buffer bx0 = max ((x1 - bx1), 0) by0 = max ((y1 - by1), 0) #call eprintf ("\tx0=%d y0=%d bx0=%d bx0=%d\n") #call pargi (x0) #call pargi (y0) #call pargi (bx0) #call pargi (by0) # Coordinates of the piece we have in the internal buffer. sx1 = max (x1, bx1) sx2 = min (x2, bx2) sy1 = max (y1, by1) sy2 = min (y2, by2) # Number of pixels to copy. snx = sx2 - sx1 + 1 sny = sy2 - sy1 + 1 #call eprintf ("\tsx1=%d sx2=%d sy1=%d sy2=%d snx=%d sny=%d\n") #call pargi (sx1) #call pargi (sx2) #call pargi (sy1) #call pargi (sy2) #call pargi (snx) #call pargi (sny) switch (btype) { case TY_SHORT: do j = 1, sny { do i = 1, snx Memr[OPTR(i, j)] = Mems[IPTR(i,j)] } case TY_INT: do j = 1, sny { do i = 1, snx Memr[OPTR(i, j)] = Memi[IPTR(i,j)] } case TY_LONG: do j = 1, sny { do i = 1, snx Memr[OPTR(i, j)] = Meml[IPTR(i,j)] } case TY_REAL: do j = 1, sny { do i = 1, snx Memr[OPTR(i, j)] = Memr[IPTR(i,j)] } case TY_DOUBLE: do j = 1, sny { do i = 1, snx Memr[OPTR(i, j)] = Memd[IPTR(i,j)] } } end # MICPYx -- Fill rectangle in output buffer by copying from the internal buffer # The data is type converted if neccesary. The section requested may be # larger or smaller than that available in the internal buffer. In the # former case we just fill the part of the output buffer for which we have # data. In the latter case we copy a subsection of the internal buffer to # output. procedure micpyd (sb, x1, x2, y1, y2, obuf) pointer sb #I Pointer to section data sub-structure. int x1, x2 #I Range of columns in requested section. int y1, y2 #I Range of lines in requested section. pointer obuf #O pointer to data values. int j, i, btype int nx, x0, bnx, bx1, bx2, bx0, sx1, sx2, snx int ny, y0, bny, by1, by2, by0, sy1, sy2, sny pointer ibuf # Macros to "simplify" array indexing define IPTR (ibuf + ($2+by0-1)*bnx + ($1+bx0-1)) define OPTR (obuf + ($2+y0-1)*nx + ($1+x0-1)) begin #call eprintf ("MICPY\n") # dimensions of output buffer nx = x2 - x1 + 1 ny = y2 - y1 + 1 #call eprintf ("\t x1=%d x2=%d y1=%d y2=%d nx=%d ny=%d\n") #call pargi (x1) #call pargi (x2) #call pargi (y1) #call pargi (y2) #call pargi (nx) #call pargi (ny) # Coordinates etc. of internal buffer ibuf = SB_DATA(sb) bx1 = SB_X1(sb) bx2 = SB_X2(sb) by1 = SB_Y1(sb) by2 = SB_Y2(sb) bnx = bx2 - bx1 + 1 bny = by2 - by1 + 1 btype = SB_PIXTYPE(sb) #call eprintf ("\tbx1=%d bx2=%d by1=%d by2=%d bnx=%d bny=%d\n") #call pargi (bx1) #call pargi (bx2) #call pargi (by1) #call pargi (by2) #call pargi (bnx) #call pargi (bny) # offset to starting point in output buffer x0 = max ((bx1 - x1), 0) y0 = max ((by1 - y1), 0) # Offset to starting point in internal buffer bx0 = max ((x1 - bx1), 0) by0 = max ((y1 - by1), 0) #call eprintf ("\tx0=%d y0=%d bx0=%d bx0=%d\n") #call pargi (x0) #call pargi (y0) #call pargi (bx0) #call pargi (by0) # Coordinates of the piece we have in the internal buffer. sx1 = max (x1, bx1) sx2 = min (x2, bx2) sy1 = max (y1, by1) sy2 = min (y2, by2) # Number of pixels to copy. snx = sx2 - sx1 + 1 sny = sy2 - sy1 + 1 #call eprintf ("\tsx1=%d sx2=%d sy1=%d sy2=%d snx=%d sny=%d\n") #call pargi (sx1) #call pargi (sx2) #call pargi (sy1) #call pargi (sy2) #call pargi (snx) #call pargi (sny) switch (btype) { case TY_SHORT: do j = 1, sny { do i = 1, snx Memd[OPTR(i, j)] = Mems[IPTR(i,j)] } case TY_INT: do j = 1, sny { do i = 1, snx Memd[OPTR(i, j)] = Memi[IPTR(i,j)] } case TY_LONG: do j = 1, sny { do i = 1, snx Memd[OPTR(i, j)] = Meml[IPTR(i,j)] } case TY_REAL: do j = 1, sny { do i = 1, snx Memd[OPTR(i, j)] = Memr[IPTR(i,j)] } case TY_DOUBLE: do j = 1, sny { do i = 1, snx Memd[OPTR(i, j)] = Memd[IPTR(i,j)] } } end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/miproc.gx�������������������������������������������������0000664�0000000�0000000�00000004000�13321663143�0021337�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "mosgeom.h" include "mosproc.h" $for (silrd) # MIPROCx -- Perform quick look processing on data array procedure miproc$t (mg, in, out, nx, line, overscan, novr) pointer mg #I Mosgeom pointer. PIXEL in[ARB] #I Raw data array. PIXEL out[ARB] #O Processed array. int nx #I Number of pixels. int line #I image line. PIXEL overscan[ARB] #I Overscan vector. int novr #I Number of pixels in overscan vector. int i real k1, k2 real linebias$t() errchk linebias$t include "mosproc.com" begin switch (proc) { case NONE: do i = 1, nx out[i] = in[i] case D: k1 = DARK(mg) do i = 1, nx out[i] = in[i] - k1 case G: k2 = GAIN(mg) do i = 1, nx out[i] = in[i] * k2 case DG: k1 = DARK(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case C, A: k1 = BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CD, AD: k1 = DARK(mg) + BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CG, AG: k1 = BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case CDG, ADG: k1 = DARK(mg) + BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case L: k1 = linebias$t (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LD: k1 = DARK(mg) + linebias$t (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LG: k1 = linebias$t (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case LDG: k1 = DARK(mg) + linebias$t (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case F: k1 = Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FD: k1 = DARK(mg) + Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FG: k1 = Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case FDG: k1 = DARK(mg) + Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 } end $endfor mscred-5.05-2018.07.09/src/mscdisplay/src/miproc.x��������������������������������������������������0000664�0000000�0000000�00000023315�13321663143�0021202�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "mosgeom.h" include "mosproc.h" # MIPROCx -- Perform quick look processing on data array procedure miprocs (mg, in, out, nx, line, overscan, novr) pointer mg #I Mosgeom pointer. short in[ARB] #I Raw data array. short out[ARB] #O Processed array. int nx #I Number of pixels. int line #I image line. short overscan[ARB] #I Overscan vector. int novr #I Number of pixels in overscan vector. int i real k1, k2 real linebiass() errchk linebiass include "mosproc.com" begin switch (proc) { case NONE: do i = 1, nx out[i] = in[i] case D: k1 = DARK(mg) do i = 1, nx out[i] = in[i] - k1 case G: k2 = GAIN(mg) do i = 1, nx out[i] = in[i] * k2 case DG: k1 = DARK(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case C, A: k1 = BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CD, AD: k1 = DARK(mg) + BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CG, AG: k1 = BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case CDG, ADG: k1 = DARK(mg) + BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case L: k1 = linebiass (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LD: k1 = DARK(mg) + linebiass (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LG: k1 = linebiass (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case LDG: k1 = DARK(mg) + linebiass (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case F: k1 = Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FD: k1 = DARK(mg) + Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FG: k1 = Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case FDG: k1 = DARK(mg) + Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 } end # MIPROCx -- Perform quick look processing on data array procedure miproci (mg, in, out, nx, line, overscan, novr) pointer mg #I Mosgeom pointer. int in[ARB] #I Raw data array. int out[ARB] #O Processed array. int nx #I Number of pixels. int line #I image line. int overscan[ARB] #I Overscan vector. int novr #I Number of pixels in overscan vector. int i real k1, k2 real linebiasi() errchk linebiasi include "mosproc.com" begin switch (proc) { case NONE: do i = 1, nx out[i] = in[i] case D: k1 = DARK(mg) do i = 1, nx out[i] = in[i] - k1 case G: k2 = GAIN(mg) do i = 1, nx out[i] = in[i] * k2 case DG: k1 = DARK(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case C, A: k1 = BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CD, AD: k1 = DARK(mg) + BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CG, AG: k1 = BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case CDG, ADG: k1 = DARK(mg) + BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case L: k1 = linebiasi (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LD: k1 = DARK(mg) + linebiasi (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LG: k1 = linebiasi (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case LDG: k1 = DARK(mg) + linebiasi (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case F: k1 = Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FD: k1 = DARK(mg) + Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FG: k1 = Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case FDG: k1 = DARK(mg) + Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 } end # MIPROCx -- Perform quick look processing on data array procedure miprocl (mg, in, out, nx, line, overscan, novr) pointer mg #I Mosgeom pointer. long in[ARB] #I Raw data array. long out[ARB] #O Processed array. int nx #I Number of pixels. int line #I image line. long overscan[ARB] #I Overscan vector. int novr #I Number of pixels in overscan vector. int i real k1, k2 real linebiasl() errchk linebiasl include "mosproc.com" begin switch (proc) { case NONE: do i = 1, nx out[i] = in[i] case D: k1 = DARK(mg) do i = 1, nx out[i] = in[i] - k1 case G: k2 = GAIN(mg) do i = 1, nx out[i] = in[i] * k2 case DG: k1 = DARK(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case C, A: k1 = BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CD, AD: k1 = DARK(mg) + BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CG, AG: k1 = BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case CDG, ADG: k1 = DARK(mg) + BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case L: k1 = linebiasl (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LD: k1 = DARK(mg) + linebiasl (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LG: k1 = linebiasl (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case LDG: k1 = DARK(mg) + linebiasl (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case F: k1 = Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FD: k1 = DARK(mg) + Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FG: k1 = Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case FDG: k1 = DARK(mg) + Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 } end # MIPROCx -- Perform quick look processing on data array procedure miprocr (mg, in, out, nx, line, overscan, novr) pointer mg #I Mosgeom pointer. real in[ARB] #I Raw data array. real out[ARB] #O Processed array. int nx #I Number of pixels. int line #I image line. real overscan[ARB] #I Overscan vector. int novr #I Number of pixels in overscan vector. int i real k1, k2 real linebiasr() errchk linebiasr include "mosproc.com" begin switch (proc) { case NONE: do i = 1, nx out[i] = in[i] case D: k1 = DARK(mg) do i = 1, nx out[i] = in[i] - k1 case G: k2 = GAIN(mg) do i = 1, nx out[i] = in[i] * k2 case DG: k1 = DARK(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case C, A: k1 = BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CD, AD: k1 = DARK(mg) + BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CG, AG: k1 = BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case CDG, ADG: k1 = DARK(mg) + BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case L: k1 = linebiasr (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LD: k1 = DARK(mg) + linebiasr (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LG: k1 = linebiasr (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case LDG: k1 = DARK(mg) + linebiasr (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case F: k1 = Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FD: k1 = DARK(mg) + Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FG: k1 = Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case FDG: k1 = DARK(mg) + Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 } end # MIPROCx -- Perform quick look processing on data array procedure miprocd (mg, in, out, nx, line, overscan, novr) pointer mg #I Mosgeom pointer. double in[ARB] #I Raw data array. double out[ARB] #O Processed array. int nx #I Number of pixels. int line #I image line. double overscan[ARB] #I Overscan vector. int novr #I Number of pixels in overscan vector. int i real k1, k2 real linebiasd() errchk linebiasd include "mosproc.com" begin switch (proc) { case NONE: do i = 1, nx out[i] = in[i] case D: k1 = DARK(mg) do i = 1, nx out[i] = in[i] - k1 case G: k2 = GAIN(mg) do i = 1, nx out[i] = in[i] * k2 case DG: k1 = DARK(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case C, A: k1 = BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CD, AD: k1 = DARK(mg) + BIAS(mg) do i = 1, nx out[i] = in[i] - k1 case CG, AG: k1 = BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case CDG, ADG: k1 = DARK(mg) + BIAS(mg) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case L: k1 = linebiasd (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LD: k1 = DARK(mg) + linebiasd (overscan, novr) do i = 1, nx out[i] = in[i] - k1 case LG: k1 = linebiasd (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case LDG: k1 = DARK(mg) + linebiasd (overscan, novr) k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case F: k1 = Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FD: k1 = DARK(mg) + Memr[OVRSCN(mg)+line -1] do i = 1, nx out[i] = in[i] - k1 case FG: k1 = Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 case FDG: k1 = DARK(mg) + Memr[OVRSCN(mg)+line-1] k2 = GAIN(mg) do i = 1, nx out[i] = (in[i] - k1) * k2 } end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mitemplate.x����������������������������������������������0000664�0000000�0000000�00000010373�13321663143�0022052�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MITEMPLATE -- Expand an image name template and collapse it to a set of # mosaic image rootnames. define LEN_MITSTRUCT 5 # Length of structure. define MIT_PTR Memi[$1] # String buffer pointer. define MIT_LENGTH Memi[$1+1] # Length of String buffer. define MIT_NIMAGES Memi[$1+2] # Number of images. define MIT_INDICES Memi[$1+3] # Array of string indexes. define MIT_INDEX Memi[$1+4] # String index of next entry. define DEFSTR SZ_COMMAND # Default string allocation. define DEFIDX 100 # Default index allocation. define SPACE " " # Space character pointer procedure mitopen (input) char input[ARB] #I Image name template. pointer mit #O pointer to rootname list structure. pointer sp, image, rootname, previous, buff, idxs, list int str_alloc, idx_alloc, nch, nimages, len pointer imtopen() int imtgetim(), strlen() bool streq() begin call smark (sp) call salloc (image, SZ_LINE, TY_CHAR) call salloc (rootname, SZ_LINE, TY_CHAR) call salloc (previous, SZ_LINE, TY_CHAR) # Allocate structure, string buffer and index array call malloc (mit, LEN_MITSTRUCT, TY_STRUCT) str_alloc = DEFSTR call malloc (buff, str_alloc, TY_CHAR) idx_alloc = DEFIDX call malloc (idxs, idx_alloc, TY_INT) nch = 0 nimages = 0 Memc[previous] = EOS list = imtopen (input) while (imtgetim (list, Memc[image], SZ_LINE) != EOF) { call mg_rootname (Memc[image], Memc[rootname], SZ_LINE) # Skip repeated rootnames. if (streq (Memc[previous], Memc[rootname])) next # Check for index and buffer overflow and reallocate if neccesary. nimages = nimages + 1 if (nimages > idx_alloc) { idx_alloc = idx_alloc + DEFIDX call realloc (idxs, idx_alloc, TY_INT) } len = strlen (Memc[rootname]) if (nch + len + 2 > str_alloc) { str_alloc = str_alloc + DEFSTR call realloc (buff, str_alloc, TY_CHAR) } # Index points to start of new string Memi[idxs+nimages-1] = nch call strcpy (Memc[rootname], Memc[buff+nch], len) nch = nch + len call strcpy (Memc[rootname], Memc[previous], SZ_LINE) } # Reallocate buffer and index array call realloc (buff, nch, TY_CHAR) call realloc (idxs, nimages, TY_INT) # Save results in structure MIT_PTR(mit) = buff MIT_LENGTH(mit) = nch MIT_NIMAGES(mit) = nimages MIT_INDICES(mit) = idxs MIT_INDEX(mit) = 1 return (mit) end # MITGETIM -- Get next image from an expanded list of rootnames. int procedure mitgetim (mit, image, maxch) pointer mit #I Pointer to template structure. char image[ARB] #O Output image name. int maxch #I maximum length of image. int nch #O Number of characters in image or EOF int mitrgetim() begin # Check for null list if (mit == NULL) return (EOF) nch = mitrgetim (mit, MIT_INDEX(mit), image, maxch) return (nch) end # MITRGETIM -- Get next image from an expanded list of rootnames. int procedure mitrgetim (mit, index, image, maxch) pointer mit #I Pointer to template structure. int index #I List element to be returned. char image[ARB] #O Output image name. int maxch #I maximum length of image. int nch #O Number of characters in image or EOF int first, last begin # Check for null list if (mit == NULL) return (EOF) if (index <= 0 || index > MIT_NIMAGES(mit)) return (EOF) first = Memi[MIT_INDICES(mit)+index-1] if (index == MIT_NIMAGES(mit)) { last = MIT_LENGTH(mit) - 1 } else { last = Memi[MIT_INDICES(mit)+index] - 1 } nch = min (maxch, last - first + 1) call strcpy (Memc[MIT_PTR(mit)+first], image, nch) MIT_INDEX(mit) = MIT_INDEX(mit) + 1 return (nch) end # MITLEN -- Get number of images in list of rootnames. int procedure mitlen (mit) pointer mit #I Pointer to template structure. begin if (mit != NULL) return (MIT_NIMAGES(mit)) else return (0) end # MITREWIND -- "rewind" list of rootnames. procedure mitrewind (mit) pointer mit #I Pointer to template structure. begin if (mit != NULL) MIT_INDEX(mit) = 1 end # MITCLOSE -- Close list of rootnames. procedure mitclose (mit) pointer mit #I Pointer to template structure. begin if (mit != NULL) { if (MIT_PTR(mit) != NULL) call mfree (MIT_PTR(mit), TY_CHAR) if (MIT_INDICES(mit) != NULL) call mfree (MIT_INDICES(mit), TY_INT) call mfree (mit, TY_STRUCT) } end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mittest.par�����������������������������������������������0000664�0000000�0000000�00000000100�13321663143�0021700�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,"",,,Input image template index,i,a,1,,,Index in list ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mkoverscan.x����������������������������������������������0000664�0000000�0000000�00000005125�13321663143�0022060�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include "mosgeom.h" # MK_OVERSCAN -- Make the overscan vector. # # 1. Average the overscan columns or lines. # 2. Fit a function with the ICFIT routines to smooth the overscan vector. procedure mk_overscan (im, mg) pointer im # IMIO pointer for image. pointer mg # MOSGEOM pointer. int i, first, last, navg, npts pointer sp, imname, buf, x real asumr() pointer imgs2r() errchk imgs2r, fit_overscan begin call smark (sp) call salloc (imname, SZ_LINE, TY_CHAR) call imstats (im, IM_IMAGENAME, Memc[imname], SZ_LINE) first = BX1(mg) last = BX2(mg) navg = last - first + 1 npts = NY(mg) # Set zero overscan vector if (navg < 1) { call calloc (OVRSCN(mg), npts, TY_REAL) call sfree (sp) return } call salloc (buf, npts, TY_REAL) do i = 1, npts Memr[buf+i-1] = asumr (Memr[imgs2r(im, 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. # Use DATA not CCD coordinates (ala ccdproc) as x. Not sure this is # the right choice. npts = DY2(mg) - DY1(mg) + 1 call malloc (OVRSCN(mg), npts, TY_REAL) call salloc (x, npts, TY_REAL) call trim_overscan (Memr[buf], npts, DY1(mg), Memr[x], Memr[OVRSCN(mg)]) call fit_overscan (Memc[imname], BX1(mg), BX2(mg), BY1(mg), BY2(mg), Memr[x], Memr[OVRSCN(mg)], npts) call sfree (sp) end # AVG_OVERSCAN -- Average (kclipped in X) the overscan vector. # procedure avg_overscan (im, mg, sample) pointer im # IMIO pointer for image. pointer mg # MOSGEOM pointer. real sample # Fraction of overscan to sample int nlines, npts, interval, start, line, bx1, bx2, navg pointer buf real sum double signorm() real linebiasr() pointer imgs2r() errchk imgs2r, linebiasr include "lbias.com" begin # Set parameters for linebias routine itmax = 2 ksigma = 3.0 sigcor = real (signorm (double (ksigma))) bx1 = BX1(mg) bx2 = BX2(mg) navg = bx2 - bx1 + 1 # Set zero bias value if no overscan strip. if (navg < 1) { BIAS(mg) = 0.0 return } if (sample <= 0.0) { interval = 1 start = 1 } else { # Sample evenly (we deliberately avoid pixels at start and end) nlines = NY(mg) npts = max (5., nlines * sample) interval = nlines / (npts + 1) start = max (1, (nlines - interval * npts) / 2) } npts = 0 sum = 0.0 do line = start, NY(mg), interval { npts = npts + 1 buf = imgs2r (im, bx1, bx2, line, line) if (navg == 1) { sum = Memr[buf] } else { sum = sum + linebiasr (Memr[buf], navg) } } BIAS(mg) = sum / npts end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mkpkg�����������������������������������������������������0000664�0000000�0000000�00000003356�13321663143�0020557�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCDISPLAY lmscdisp: $checkout libmscdisp.a mscbin$ $update libmscdisp.a $checkin libmscdisp.a mscbin$ ; limexam: $call limexam@imexam ; lsf: $call lsf@starfocus ; libmscdisp.a: $ifolder (mscg.x, mscg.gx) $generic -k -o mscg.x mscg.gx $endif $ifolder (sigm2.x, sigm2.gx) $generic -k -o sigm2.x sigm2.gx $endif $ifolder (mignl.x, mignl.gx) $generic -k -o mignl.x mignl.gx $endif $ifolder (migl2.x, migl2.gx) $generic -k -o migl2.x migl2.gx $endif $ifolder (migs2.x, migs2.gx) $generic -k -o migs2.x migs2.gx $endif $ifolder (miproc.x, miproc.gx) $generic -k -o miproc.x miproc.gx $endif $ifolder (linebias.x, linebias.gx) $generic -k -o linebias.x linebias.gx $endif $ifolder (akavg.x, akavg.gx) $generic -k -o akavg.x akavg.gx $endif akavg.x ampset.x ampinfo.com gamma.x linebias.x lbias.com mosgeom.h maskcolor.x ace.h maxmin.x mosgeom.h migl2.x mosgeom.h mosim.h mosproc.com mosproc.h mignl.x mosgeom.h mosim.h mosproc.com\ mosproc.com mosproc.h migs2.x mosgeom.h mosim.h mosproc.com mosproc.h miproc.x mosgeom.h mosproc.com mosproc.h mitemplate.x mkoverscan.x lbias.com mosgeom.h moscoords.x mosmap.x ampinfo.com \ mosgeom.h mosim.h mosproc.h mscg.x mosgeom.h proc.x mosgeom.h mosproc.com mosproc.h sigm2.x mosgeom.h xtfixpix.h t_mscdisplay.x display.h gwindow.h \ mosgeom.h mosim.h mosproc.com mosproc.h t_mscrtdisp.x display.h gwindow.h \ mosgeom.h mosim.h mosproc.com\ mosproc.h ; ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/moscoords.x�����������������������������������������������0000664�0000000�0000000�00000002005�13321663143�0021712�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. # MOSCOORDS -- Convert display coordinates to mosaic coordinates. procedure moscoords (wcs, x, y) int wcs #U Display WCS real x #U X real y #U Y int i, snx, sny, dx, dy, dnx, dny real sx, sy pointer sp, reg, objref int imd_wcsver(), imd_query_map() int wcsver data wcsver/-1/ begin if (wcsver == -1) wcsver = imd_wcsver() if (wcsver == 0) return call smark (sp) call salloc (reg, SZ_FNAME, TY_CHAR) call salloc (objref, SZ_FNAME, TY_CHAR) if (imd_query_map (wcs, Memc[reg], sx, sy, snx, sny, dx, dy, dnx, dny, Memc[objref]) == ERR) { call sfree (sp) return } x = (x - sx) * (dnx - 1.) / (snx - 1.) + dx y = (y - sy) * (dny - 1.) / (sny - 1.) + dy do i = wcs+1, ARB if (imd_query_map (i, Memc[reg], sx, sy, snx, sny, dx, dy, dnx, dny, Memc[objref]) == ERR) break x = (x - dx) * (snx - 1.) / (dnx - 1.) + sx y = (y - dy) * (sny - 1.) / (dny - 1.) + sy wcs = i - 1 call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mosgeom.h�������������������������������������������������0000664�0000000�0000000�00000005633�13321663143�0021342�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MOSGEOM.H -- Mosaic geometry structure definitions. # # There is one such structure for each of the multiple input images # and one for the output image. define LEN_ZERONAME 39 # Length of zero name define LEN_FLATNAME 39 # Length of flat field name define LEN_MOSGEOM 81 # Length of mosgeom structure. define MG_IM Memi[$1+1] # IMIO pointer define MG_USHORT Memi[$1+2] # Use special FITS USHORT optimization define CCDNAME Memi[$1+3] # Pointer to CCD name string define AMPID Memi[$1+4] # Pointer to ampid string define NX Memi[$1+5] # Image dimension in column direction define NY Memi[$1+6] # Image dimension in line direction define IMIDX Memi[$1+7] # Pointer to indices for im{gp}nlt calls # CCD section define CX1 Memi[$1+8] # CCD section starting column. define CX2 Memi[$1+9] # CCD section ending column. define CY1 Memi[$1+10] # CCD section starting line. define CY2 Memi[$1+11] # CCD section ending line. # DATA section define DX1 Memi[$1+12] # DATA section starting column. define DX2 Memi[$1+13] # DATA section ending column. define DY1 Memi[$1+14] # DATA section starting line. define DY2 Memi[$1+15] # DATA section ending line. # DATA to CCD define DX Memi[$1+16] # Pixel summing factor define DY Memi[$1+17] # Pixel summing factor # TRIM section define TX1 Memi[$1+18] # TRIM section starting column. define TX2 Memi[$1+19] # TRIM section ending column. define TY1 Memi[$1+20] # TRIM section starting line. define TY2 Memi[$1+21] # TRIM section ending line. # BIAS section define BX1 Memi[$1+22] # BIAS section starting column. define BX2 Memi[$1+23] # BIAS section ending column. define BY1 Memi[$1+24] # BIAS section starting line. define BY2 Memi[$1+25] # BIAS section ending line. # Amplifier dependent parameters used for processing/display. define PROC Memi[$1+26] # Process? define DOBIAS Memi[$1+27] # Do bias subtraction? define DOZERO Memi[$1+28] # Do zero subtraction? define DOFLAT Memi[$1+29] # Do flat field division? define ZERONAME Memc[P2C($1+30)]# Zero name define FLATNAME Memc[P2C($1+50)]# Flat field name define DZIM Memi[$1+70] # Display zero IMIO pointer define DFIM Memi[$1+71] # Display flat IMIO pointer define CCDMEAN Memr[P2R($1+72)]# CCDMEAN value define BIAS Memr[P2R($1+73)]# Zero offset (bias level) of readout. define OVRSCN Memi[$1+74] # Pointer to overscan vector. define GAIN Memr[P2R($1+75)]# Gain of readout. define DARK Memr[P2R($1+76)]# Dark rate of readout. define Z1 Memr[P2R($1+77)]# Z1 value for display. define Z2 Memr[P2R($1+78)]# Z2 value for display. # Real-time flags. define CKNODATA Memi[$1+79] # Check for no data? define NODATA Memi[$1+80] # No data found? # Macros to calculate corners of trim section relative to CCD section. define CTX1 CX1($1) + (TX1($1) - DX1($1)) * DX($1) define CTX2 CX2($1) + (TX2($1) - DX2($1)) * DX($1) define CTY1 CY1($1) + (TY1($1) - DY1($1)) * DY($1) define CTY2 CY2($1) + (TY2($1) - DY2($1)) * DY($1) �����������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mosim.h���������������������������������������������������0000664�0000000�0000000�00000002650�13321663143�0021014�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MOSIM.H -- Definition for mosaic image structure. # define LEN_MOSIM 5 # Length of mosaic structure. define MI_NIMS Memi[$1] # Number of sub-images mapped. define MI_RNAME Memi[$1+1] # Rootname of mosaic images. define MI_IMS Memi[$1+2] # Array of IMIO pointers. define MI_MGS Memi[$1+3] # Array of mosgeom pointers. define MI_SB Memi[$1+4] # Section data structure. # Macros to return individual array items define MI_IM Memi[MI_IMS($1)+$2-1] # IMIO pointer for image $2. define MI_MG Memi[MI_MGS($1)+$2-1] # Mosgeom pointer for image $2. define MI_DATA SB_DATA(MI_SB($1)) # Pointer to data buffer # Mosgeom pointer for composite define MI_CMG Memi[MI_MGS($1)+MI_NIMS($1)] # Section data sub-structure. This is used to store a (small) section of the # tiled mosaic in memory. A substructure is used to simplify future extension # to multiple buffers. # # The saved section coordinates are relative to the mosaic CCDSEC. define LEN_SECBUFF 6 define SB_DATA Memi[$1] # Pointer to data buffer. define SB_X1 Memi[$1+1] # Section starting column. define SB_X2 Memi[$1+2] # Section ending column. define SB_Y1 Memi[$1+3] # Section starting line. define SB_Y2 Memi[$1+4] # Section ending line. define SB_PIXTYPE Memi[$1+5] # Data type of array. # Valid mosaic image names have the form rootname.ampid.??h. define MI_TEMPLATE "%s_%s.??h" # Template image name. define MI_DEFEXT "*" # Default extension. ����������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mosmap.x��������������������������������������������������0000664�0000000�0000000�00000100170�13321663143�0021200�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include include "mosim.h" include "mosgeom.h" include "mosproc.h" pointer procedure mimap (image, acmode, hdr_arg) char image[ARB] #I image specification int acmode #I image access mode int hdr_arg #I length of user fields, or structure pointer pointer mi #O Structure pointer int rootlen, mef, proc, dobias, dozero, doflat, ninput, err, imext pointer sp, im, mg, template, imname, zname, caldir, filter, inlist bool clgetb() pointer immap(), mg_open(), mg_compgeom(), imtopenp() int xt_extns(), imtopen, imtlen(), imtgetim() int errget(), btoi(), strlen() char errmsg[SZ_LINE] errchk mg_open, mg_compgeom, imextensions, imtgetim, miunmap begin call smark (sp) call salloc (template, SZ_LINE, TY_CHAR) call salloc (imname, SZ_LINE, TY_CHAR) call salloc (zname, SZ_LINE, TY_CHAR) call salloc (caldir, SZ_LINE, TY_CHAR) call salloc (filter, SZ_LINE, TY_CHAR) # Allocate space for mosim structure call malloc (mi, LEN_MOSIM, TY_STRUCT) call malloc (MI_RNAME(mi), SZ_LINE, TY_CHAR) MI_NIMS(mi) = 0 MI_IMS(mi) = NULL MI_MGS(mi) = NULL MI_SB(mi) = NULL # Save rootname in structure rootlen = strlen (image) call strcpy (image, Memc[MI_RNAME(mi)], SZ_LINE) switch (acmode) { # Open for input case READ_ONLY, READ_WRITE: # First try and open a FITS multiextension image and if no # extensions are found then open a template. call clgstr ("mimpars.extname", Memc[template], SZ_LINE) inlist = xt_extns (image, "IMAGE", "0-", Memc[template], "", NO, YES, NO, NO, "", NO, imext) ninput = imtlen (inlist) if (ninput == 0) { call imtclose (inlist) # Now try to open as a multi-image mosaic call clgstr ("mimpars.exttmplt", Memc[imname], SZ_LINE) call sprintf (Memc[template], SZ_LINE, "%s%s") call pargstr (image) call pargstr (Memc[imname]) call printf("file template: %s\n") call pargstr(Memc[template]) # Get list of input images inlist = imtopen (Memc[template]) mef = NO } else mef = YES # No images match template - Complain. ninput = imtlen (inlist) if (ninput == 0) { call sfree (sp) call miunmap (mi) call sprintf (errmsg, SZ_LINE, "Cannot open mosaic (%s)") call pargstr (image) call error (0, errmsg) } # Process? proc = btoi (clgetb ("mimpars.process")) if (proc == YES) { dobias = btoi (clgetb ("mimpars.overscan")) dozero = btoi (clgetb ("mimpars.zerosub")) doflat = btoi (clgetb ("mimpars.flatfield")) if (dozero == YES) { im = imtopenp ("zero") if (imtlen (im) > 1) call error (1, "Only one zero may be specified") if (imtgetim (im, Memc[zname], SZ_LINE) == EOF) dozero = NO call imtclose (im) } if (dobias == NO && dozero == NO && doflat == NO) proc = NO } if (proc == YES) { call clgstr ("mimpars.caldir", Memc[caldir], SZ_LINE) call clgstr ("mimpars.filter", Memc[filter], SZ_LINE) } call malloc (MI_IMS(mi), ninput, TY_INT) call malloc (MI_MGS(mi), ninput, TY_INT) # Map input images and fill out mosgeom structuress ninput = 0 while (imtgetim (inlist, Memc[imname], SZ_FNAME) != EOF) { iferr (mg = mg_open (Memc[imname], rootlen, acmode, hdr_arg, mef, proc, dobias, dozero, doflat, Memc[zname], Memc[caldir], Memc[filter], ninput, im)) { call sfree (sp) call miunmap (mi) call erract (EA_ERROR) } ninput = ninput + 1 MI_IM(mi, ninput) = im MI_MG(mi, ninput) = mg } call imtclose (inlist) # No images mapped succesfully - Complain. if (ninput == 0) { call sfree (sp) call miunmap (mi) call sprintf (errmsg, SZ_LINE, "Cannot open mosaic (%s)") call pargstr (image) call error (0, errmsg) } # Realocate arrays. One extra mosgeom struct is allocated # to hold the composite geometry for the entire mosaic. MI_NIMS(mi) = ninput call realloc (MI_IMS(mi), ninput, TY_INT) call realloc (MI_MGS(mi), ninput+1, TY_INT) # Generate mosgeom structure for tiled mosaic and tack it on to # the end of the array of structures. MI_MG(mi, ninput+1) = mg_compgeom (mi) case NEW_COPY: iferr (im = immap (image, acmode, MI_IM(hdr_arg, 1))) { err = errget (errmsg, SZ_LINE) call miunmap (mi) call error (err, errmsg) } mg = mg_compgeom (hdr_arg) MI_NIMS(mi) = 1 call malloc (MI_IMS(mi), 1, TY_INT) call malloc (MI_MGS(mi), 2, TY_INT) MI_IM(mi, 1) = im MI_MG(mi, 1) = NULL MI_MG(mi, 2) = mg # Reset image dimensions to match that of input mosaic image IM_LEN (im, 1) = NX(mg) IM_LEN (im, 2) = NY(mg) default: iferr (im = immap (image, acmode, hdr_arg)) { err = errget (errmsg, SZ_LINE) call miunmap (mi) call error (err, errmsg) } MI_NIMS(mi) = 1 call malloc (MI_IMS(mi), 1, TY_INT) MI_IM(mi, 1) = im } return (mi) end procedure miunmap (mi) pointer mi #I Structure pointer int i begin if (mi != NULL) { # Free rootname call mfree (MI_RNAME(mi), TY_CHAR) # Unmap images if (MI_IMS(mi) != NULL) { do i = 1, MI_NIMS(mi) { call imunmap (MI_IM(mi, i)) } call mfree (MI_IMS(mi), TY_INT) } # Free mosgeom structures (including the composite) if (MI_MGS(mi) != NULL) { do i = 1, MI_NIMS(mi) + 1 { call mg_free (MI_MG(mi, i)) } call mfree (MI_MGS(mi), TY_INT) } # Free Section buffer if (MI_SB(mi) != NULL) { if (SB_DATA(MI_SB(mi)) != NULL) call mfree (SB_DATA(MI_SB(mi)), SB_PIXTYPE (MI_SB(mi))) call mfree (MI_SB(mi), TY_INT) } call mfree (mi, TY_STRUCT) } end # MG_OPEN -- Create and fill out mosgeom structure for image pointer procedure mg_open (imname, rootlen, acmode, hdr_arg, mef, proc, dobias, dozero, doflat, zero, caldir, filter, nim, im) char imname[ARB] #I Image name int rootlen #I Length of root part of image name int acmode #I Access mode pointer hdr_arg #I Header argument int mef #I MEF? int proc #I Process? int dobias #I Do bias subtraction? int dozero #I Do zero subtraction? int doflat #I Do flat field division? char zero[ARB] #I Zero image char caldir[ARB] #I Calibration directory char filter[ARB] #I Filter int nim #I Number of extensions previously read pointer im #O IMIO pointer for open image. pointer mg #O Pointer to completed mosgeom structure. char ch pointer sp, section, tsection, filt, str, key, cdir, dcim int i, x1, x2, xs, y1, y2, ys, amp, len, fd real rval double wref[4], lref[4] bool hdmflag(), streq() int strdic(), strlen(), open(), fscan(), nscan(), stridxs() real hdmgetr(), imgetr() pointer immap(), im_pmmap() errchk immap, im_pmmap, yt_match, hdmgetr, open, mkdetsec include "ampinfo.com" begin call smark (sp) call salloc (section, SZ_LINE, TY_CHAR) call salloc (tsection, SZ_LINE, TY_CHAR) call salloc (filt, SZ_LINE, TY_CHAR) call salloc (str, SZ_LINE, TY_CHAR) call salloc (key, SZ_LINE, TY_CHAR) call salloc (cdir, SZ_LINE, TY_CHAR) # Map image. Return on error. im = immap (imname, acmode, hdr_arg) # Allocate space for mosgeom structure and initialize. call calloc (mg, LEN_MOSGEOM, TY_STRUCT) MG_IM(mg) = im CKNODATA(mg) = NO NODATA(mg) = NO # Set pixel type for access. if (IM_PIXTYPE(im) == TY_USHORT && mef == YES) MG_USHORT(mg) = YES else MG_USHORT(mg) = NO # CCD name. call hdmgstr (im, "ccdname", Memc[section], SZ_LINE) if (Memc[section] != EOS) { len = strlen (Memc[section]) call malloc (CCDNAME(mg), len , TY_CHAR) call strcpy (Memc[section], Memc[CCDNAME(mg)], len) } else CCDNAME(mg) = NULL # Get amplifier id. call mg_ampid (im, Memc[section], SZ_LINE) if (Memc[section] != EOS) { len = strlen (Memc[section]) call malloc (AMPID(mg), len , TY_CHAR) call strcpy (Memc[section], Memc[AMPID(mg)], len) } else AMPID(mg) = NULL # Set index into amplist if we have one. amp = 0 if (namps != 0) amp = strdic (Memc[section], Memc[section], SZ_LINE, Memc[amplist]) # Get input image dimensions. NX(mg) = IM_LEN(im, 1) NY(mg) = IM_LEN(im, 2) # Allocate and initialise the Index vector call calloc (IMIDX(mg), IM_MAXDIM, TY_LONG) # Check for header keywords and set defaults as necessary. call mos_header (mg, Memc[key], Memc[section]) # Set data section (DATASEC keyword) Memc[section] = EOS call hdmgstr (im, "datasec", Memc[section], SZ_LINE) x1 = 1 x2 = NX(mg) xs = 1 y1 = 1 y2 = NY(mg) ys = 1 call ccd_section (Memc[section], x1, x2, xs, y1, y2, ys) DX1(mg) = x1 DX2(mg) = x2 DY1(mg) = y1 DY2(mg) = y2 # Set detector section (DETSEC keyword) call hdmgstr (im, "detsec", Memc[section], SZ_LINE) if (Memc[section] == EOS) { ifnoerr (rval = hdmgetr (im, "crval1")) call mkdetsec (mg, nim+1, wref, lref, Memc[section], SZ_LINE) else call hdmgstr (im, "ccdsec", Memc[section], SZ_LINE) } x1 = DX1(mg) x2 = DX2(mg) xs = 1 y1 = DY1(mg) y2 = DY2(mg) ys = 1 call ccd_section (Memc[section], x1, x2, xs, y1, y2, ys) CX1(mg) = x1 CX2(mg) = x2 CY1(mg) = y1 CY2(mg) = y2 # Set pixel summing factors. x1 = CX2(mg) - CX1(mg) x2 = DX2(mg) - DX1(mg) y1 = CY2(mg) - CY1(mg) y2 = DY2(mg) - DY1(mg) if (x1 < 0) x1 = x1 - 1 else x1 = x1 + 1 if (x2 < 0) x2 = x2 - 1 else x2 = x2 + 1 if (y1 < 0) y1 = y1 - 1 else y1 = y1 + 1 if (y2 < 0) y2 = y2 - 1 else y2 = y2 + 1 DX(mg) = nint (real (x1) / real (x2)) if (DX(mg) > 0) DX(mg) = max (1, DX(mg)) else DX(mg) = min (-1, DX(mg)) DY(mg) = nint (real (y1) / real (y2)) if (DY(mg) > 0) DY(mg) = max (1, DY(mg)) else DY(mg) = min (-1, DY(mg)) # Set TRIM section (TRIMSEC keyword) call hdmgstr (im, "trimsec", Memc[section], SZ_LINE) x1 = DX1(mg) x2 = DX2(mg) xs = 1 y1 = DY1(mg) y2 = DY2(mg) ys = 1 call ccd_section (Memc[section], x1, x2, xs, y1, y2, ys) TX1(mg) = x1 TX2(mg) = x2 TY1(mg) = y1 TY2(mg) = y2 CX1(mg) = CX1(mg) + (TX1(mg) - DX1(mg)) * DX(mg) CX2(mg) = CX2(mg) + (TX2(mg) - DX2(mg)) * DX(mg) CY1(mg) = CY1(mg) + (TY1(mg) - DY1(mg)) * DY(mg) CY2(mg) = CY2(mg) + (TY2(mg) - DY2(mg)) * DY(mg) DX1(mg) = TX1(mg) DX2(mg) = TX2(mg) DY1(mg) = TY1(mg) DY2(mg) = TY2(mg) # Set BIAS section (BIASSEC keyword) call hdmgstr (im, "biassec", Memc[section], SZ_LINE) x1 = 0 x2 = 0 xs = 1 y1 = 0 y2 = 0 ys = 1 call ccd_section (Memc[section], x1, x2, xs, y1, y2, ys) BX1(mg) = x1 BX2(mg) = x2 BY1(mg) = y1 BY2(mg) = y2 # Flip if needed. if (CX1(mg) > CX2(mg)) { x1 = CX1(mg) CX1(mg) = CX2(mg) CX2(mg) = x1 x1 = DX1(mg) DX1(mg) = DX2(mg) DX2(mg) = x1 x1 = TX1(mg) TX1(mg) = TX2(mg) TX2(mg) = x1 x1 = BX1(mg) BX1(mg) = BX2(mg) BX2(mg) = x1 } if (CY1(mg) > CY2(mg)) { y1 = CY1(mg) CY1(mg) = CY2(mg) CY2(mg) = y1 y1 = DY1(mg) DY1(mg) = DY2(mg) DY2(mg) = y1 y1 = TY1(mg) TY1(mg) = TY2(mg) TY2(mg) = y1 y1 = BY1(mg) BY1(mg) = BY2(mg) BY2(mg) = y1 } # Flip image if needed. if (DX1(mg) > DX2(mg) || DY1(mg) > DY2(mg)) { if (DX1(mg) < DX2(mg)) call sprintf (Memc[tsection], SZ_LINE, "[*,-*]") else if (DY1(mg) < DY2(mg)) call sprintf (Memc[tsection], SZ_LINE, "[-*,*]") else call sprintf (Memc[tsection], SZ_LINE, "[-*,-*]") call sprintf (Memc[section], SZ_LINE, "%s%s") call pargstr (imname) call pargstr (Memc[tsection]) call imunmap (im) im = immap (Memc[section], acmode, hdr_arg) MG_IM(mg) = im if (DX1(mg) > DX2(mg)) { DX(mg) = -DX(mg) DX1(mg) = IM_LEN(im,1) - DX1(mg) + 1 DX2(mg) = IM_LEN(im,1) - DX2(mg) + 1 BX1(mg) = IM_LEN(im,1) - BX1(mg) + 1 BX2(mg) = IM_LEN(im,1) - BX2(mg) + 1 } if (DY1(mg) > DY2(mg)) { DY(mg) = -DY(mg) DY1(mg) = IM_LEN(im,2) - DY1(mg) + 1 DY2(mg) = IM_LEN(im,2) - DY2(mg) + 1 BY1(mg) = IM_LEN(im,2) - BY1(mg) + 1 BY2(mg) = IM_LEN(im,2) - BY2(mg) + 1 } } else Memc[tsection] = EOS # Setup OTF calibration processing. PROC(mg) = proc DOBIAS(mg) = dobias DOZERO(mg) = dozero DOFLAT(mg) = doflat DZIM(mg) = NULL DFIM(mg) = NULL if (PROC(mg) == YES) { if (hdmflag (im, "overscan")) DOBIAS(mg) = NO if (hdmflag (im, "zerocor")) DOZERO(mg) = NO if (hdmflag (im, "flatcor")) DOFLAT(mg) = NO if (DOBIAS(mg) == NO && DOZERO(mg) == NO && DOFLAT(mg) == NO) PROC(mg) = NO } if (PROC(mg) == YES) { if (DOZERO(mg) == YES) { # Set zero calibration. if (zero[1] == '!') { iferr (call imgstr (im, zero[2], ZERONAME(mg), LEN_ZERONAME)) { call eprintf ("Can't find keyword %s (%s)\n") call pargstr (zero[2]) call pargstr (imname) ZERONAME(mg) = EOS } else { call sprintf (Memc[section], SZ_LINE, "%s%s") call pargstr (ZERONAME(mg)) call pargstr (Memc[tsection]) } } else { call strcpy (zero, ZERONAME(mg), LEN_ZERONAME) call sprintf (Memc[section], SZ_LINE, "%s%s%s") call pargstr (ZERONAME(mg)) call pargstr (imname[rootlen+1]) call pargstr (Memc[tsection]) } if (ZERONAME(mg) != EOS) { i = stridxs ("[", Memc[section]) if (i > 0) call strcpy (Memc[section], ZERONAME(mg), i-1) iferr (DZIM(mg) = immap (Memc[section], READ_ONLY, NULL)) { DZIM(mg) = NULL DOZERO(mg) = NO if (nim == 0) call eprintf ("No zero calibration performed.\n") } } else { DZIM(mg) = NULL DOZERO(mg) = NO if (nim == 0) call eprintf ("No zero calibration performed.\n") } } if (DOFLAT(mg) == YES) { # Get full filter name. if (filter[1] == '!') call hdmgstr (im, filter[2], Memc[filt], SZ_LINE) else call strcpy (filter, Memc[filt], SZ_LINE) # Translate to directory identification. call strcpy (Memc[filt], Memc[str], SZ_LINE) for (i=0;;i=i+1) { ch = Memc[str+i] if (ch == EOS || IS_WHITE(ch)) break else if (!(IS_ALNUM(ch)||ch=='.')) Memc[str+i] = '_' } Memc[str+i] = EOS # Look for translation menu. iferr { if (caldir[1] == '!') call hdmgstr (im, caldir[2], Memc[cdir], SZ_LINE) else call strcpy (caldir, Memc[cdir], SZ_LINE) call sprintf (Memc[section], SZ_LINE, "%scal.men") call pargstr (Memc[cdir]) fd = open (Memc[section], READ_ONLY, TEXT_FILE) while (fscan(fd) != EOF) { call gargwrd (Memc[section], SZ_LINE) call gargwrd (Memc[key], SZ_LINE) if (nscan() != 2) next if (streq (Memc[section], Memc[filt]) || streq (Memc[key], Memc[filt])) { call strcpy (Memc[key], Memc[str], SZ_LINE) break } } call close (fd) } then #call erract (EA_WARN) ; # Find calibration data. iferr { call sprintf (Memc[section], SZ_LINE, "%s%s/flat%s.pl") call pargstr (Memc[cdir]) call pargstr (Memc[str]) call pargstr (Memc[AMPID(mg)]) iferr (dcim = im_pmmap (Memc[section], READ_ONLY, NULL)) { if (nim == 0) { call eprintf ( "Calibration for filter %s not found (%s%s).\n") call pargstr (Memc[filt]) call pargstr (Memc[cdir]) call pargstr (Memc[str]) } call strcpy ("default", Memc[str], SZ_LINE) call sprintf (Memc[section], SZ_LINE, "%s%s/flat%s.pl") call pargstr (Memc[cdir]) call pargstr (Memc[str]) call pargstr (Memc[AMPID(mg)]) iferr (dcim = im_pmmap (Memc[section],READ_ONLY,NULL)) { if (nim == 0) call eprintf ( "Default calibration not found (%s%s).\n") call pargstr (Memc[cdir]) call pargstr (Memc[str]) call erract (EA_ERROR) } if (nim == 0) call eprintf ("Using default calibration.\n") } DFIM(mg) = dcim iferr (CCDMEAN(mg) = hdmgetr (DFIM(mg), "ccdmean")) { if (nim == 0) call eprintf ("CCDMEAN keyword not found.\n") call erract (EA_ERROR) } iferr (rval = imgetr (im, "LTM1_1")) { call imaddr (im, "LTM1_1", 1./DX(mg)) call imaddr (im, "LTM2_2", 1./DY(mg)) call imaddr (im, "LTV1", real (DX1(mg)-1)) call imaddr (im, "LTV2", 0.) } iferr (call yt_match (DFIM(mg), im, "physical")) { if (nim == 0) call eprintf ( "Cannot match calibration pixels to data pixels.\n") call erract (EA_ERROR) } call strcpy (Memc[str], FLATNAME(mg), LEN_FLATNAME) } then { if (DFIM(mg) != NULL) call imunmap (DFIM(mg)) DFIM(mg) = NULL if (nim == 0) call eprintf ("No flat field calibration performed.\n") } if (DFIM(mg) == NULL) DOFLAT(mg) = NO } if (DOBIAS(mg)==NO && DOZERO(mg)==NO && DOFLAT(mg)==NO) PROC(mg) = NO } call sfree (sp) return (mg) end # MOS_HEADER -- Set header keywords required for display. # If any of DETSEC, DATASEC, CRVAL1 are present assume there is a populated # header; i.e. not real-time readout. Otherwise use the translation file for # real-time readout defaults. procedure mos_header (mg, key, section) pointer mg #I MG structure. char key[SZ_LINE] #I Working string char section[SZ_LINE] #I Working string int i, j, nx, ny, nx1, ctoi(), strlen() pointer im begin im = MG_IM(mg) # Check for keywords that would indicate there is a header. call hdmgstr (im, "detsec", section, SZ_LINE) if (section[1] != EOS) return call hdmgstr (im, "datasec", section, SZ_LINE) if (section[1] != EOS) return call hdmgstr (im, "crval1", section, SZ_LINE) if (section[1] != EOS) return # In order to get defaults from translation file we require AMPID. if (AMPID(mg) == NULL) return # Set DETSEC. call sprintf (key, SZ_LINE, "det%.5s") call pargstr (Memc[AMPID(mg)]) call hdmgstr (im, key, section, SZ_LINE) call hdmpstr (im, "detsec", section) # Set DATASEC. call sprintf (key, SZ_LINE, "dat%.5s") call pargstr (Memc[AMPID(mg)]) call hdmgstr (im, key, section, SZ_LINE) DX1(mg) = 1 DX2(mg) = NX(mg) i = 1 DY1(mg) = 1 DY2(mg) = NY(mg) j = 1 call ccd_section (section, DX1(mg), DX2(mg), i, DY1(mg), DY2(mg), j) # Set BIASSEC. New format is a section and old format is number # of pixels to left or right of data section. call sprintf (key, SZ_LINE, "bias%.5s") call pargstr (Memc[AMPID(mg)]) call hdmgstr (im, key, section, SZ_LINE) BX1(mg) = 1 BX2(mg) = NX(mg) i = 1 BY1(mg) = 1 BY2(mg) = NY(mg) j = 1 if (section[1] == '[') { call ccd_section (section, BX1(mg), BX2(mg), i, BY1(mg), BY2(mg), j) nx = INDEFI } else { i = 1 j = ctoi (section, i, nx) if (nx < 0) { BX1(mg) = DX1(mg) + nx BX2(mg) = DX1(mg) - 1 nx = DX2(mg) } else { BX1(mg) = DX2(mg) + 1 BX2(mg) = DX2(mg) + nx nx = BX2(mg) } ny = DY2(mg) } # Adjust for binning based on unbinned size. if (IS_INDEFI(nx)) { call sprintf (key, SZ_LINE, "size%.5s") call pargstr (Memc[AMPID(mg)]) call hdmgstr (im, key, section, SZ_LINE) nx = NX(mg) ny = NY(mg) if (section[1] != EOS) { j = ctoi (section, i, nx) j = ctoi (section, i, ny) } } nx1 = BX2(mg) - BX1(mg) + 1 DX(mg) = nint (real(nx - nx1) / (NX(mg) - nx1)) nx1 = (DX2(mg) - DX1(mg) + 1) / DX(mg) nx = nx - NX(mg) ny = ny - NY(mg) if (BX1(mg) > DX2(mg)) { DX2(mg) = min (NX(mg), DX2(mg) - nx) DX1(mg) = max (1, DX2(mg) - nx1 + 1) DX2(mg) = min (NX(mg), DX1(mg) + nx1 - 1) BX1(mg) = max (DX2(mg) + 1, BX1(mg) - nx) BX2(mg) = max (BX1(mg) + 1, BX2(mg) - nx) } else { DX2(mg) = min (NX(mg), DX1(mg) + nx1 - 1) } BY2(mg) = min (NY(mg), BY2(mg) - ny) DY2(mg) = min (NY(mg), DY2(mg) - ny) # Record DATASEC and BIASSEC. call sprintf (section, SZ_LINE, "[%d:%d,%d:%d]") call pargi (DX1(mg)) call pargi (DX2(mg)) call pargi (DY1(mg)) call pargi (DY2(mg)) call hdmpstr (im, "datasec", section) call sprintf (section, SZ_LINE, "[%d:%d,%d:%d]") call pargi (BX1(mg)) call pargi (BX2(mg)) call pargi (BY1(mg)) call pargi (BY2(mg)) call hdmpstr (im, "biassec", section) # Set CCDNAME. if (CCDNAME(mg) == NULL) { call sprintf (key, SZ_LINE, "ccd%.5s") call pargstr (Memc[AMPID(mg)]) call hdmgstr (im, key, section, SZ_LINE) if (section[1] != EOS) { i = strlen (section) call malloc (CCDNAME(mg), i, TY_CHAR) call strcpy (section, Memc[CCDNAME(mg)], i) } } # Set OTF directory. call hdmgstr (im, "otfdir", section, SZ_LINE) if (section[1] != EOS) call hdmpstr (im, "otfdir", section) end # MOS_COMPGEOM -- Calculate mosgeom structure for composite of input images. pointer procedure mg_compgeom (mi) pointer mi #I Pointer to mosim structure for input images. pointer mgout #O Pointer to composite mosgeom structure. pointer mgin1, mgin2, ptr int i, j, k, ninput, xgap, ygap, gap, x1, x2, y1, y2, clgeti(), mg_sort() bool streq() extern mg_sort #include "mosproc.com" define xadjust_ 10 define yadjust_ 20 begin # Return null pointer if input structure is null. if (mi == NULL) return (NULL) ninput = MI_NIMS(mi) call qsort (MI_MG(mi,1), ninput, mg_sort) do i = 1, ninput MI_IM(mi,i) = MG_IM(MI_MG(mi,i)) # Add gaps if requested. xgap = clgeti ("mimpars.xgap") if (xgap > 0) { xadjust_ do i = 1, ninput-1 { mgin1 = MI_MG(mi,i) do j = i+1, ninput { mgin2 = MI_MG(mi,j) if (CX1(mgin2) < CX2(mgin1)) { ptr = mgin1 mgin1 = mgin2 mgin2 = ptr } x2 = CX2(mgin1) gap = CX1(mgin2) - x2 if (gap < 1 || gap >= xgap) next if (CCDNAME(mgin1)!=NULL && CCDNAME(mgin2)!=NULL) if (streq (Memc[CCDNAME(mgin1)], Memc[CCDNAME(mgin2)])) next if (CY1(mgin2) > CY2(mgin1) || CY2(mgin2) < CY1(mgin1)) next gap = xgap - gap do k = 1, ninput { mgin2 = MI_MG(mi,k) if (CX1(mgin2) <= x2) next if (CCDNAME(mgin1)!=NULL && CCDNAME(mgin2)!=NULL) if (streq (Memc[CCDNAME(mgin1)], Memc[CCDNAME(mgin2)])) next CX1(mgin2) = CX1(mgin2) + gap CX2(mgin2) = CX2(mgin2) + gap } goto xadjust_ } } } ygap = clgeti ("mimpars.ygap") if (ygap > 0) { yadjust_ do i = 1, ninput-1 { mgin1 = MI_MG(mi,i) do j = i+1, ninput { mgin2 = MI_MG(mi,j) if (CY1(mgin2) < CY2(mgin1)) { ptr = mgin1 mgin1 = mgin2 mgin2 = ptr } y2 = CY2(mgin1) gap = CY1(mgin2) - y2 if (gap < 1 || gap >= ygap) next if (CCDNAME(mgin1)!=NULL && CCDNAME(mgin2)!=NULL) if (streq (Memc[CCDNAME(mgin1)], Memc[CCDNAME(mgin2)])) next if (CX1(mgin2) > CX2(mgin1) || CX2(mgin2) < CX1(mgin1)) next gap = ygap - gap do k = 1, ninput { mgin2 = MI_MG(mi,k) if (CY1(mgin2) <= y2) next if (CCDNAME(mgin1)!=NULL && CCDNAME(mgin2)!=NULL) if (streq (Memc[CCDNAME(mgin1)], Memc[CCDNAME(mgin2)])) next CY1(mgin2) = CY1(mgin2) + gap CY2(mgin2) = CY2(mgin2) + gap } goto yadjust_ } } } # Allocate space for mosgeom structure call calloc (mgout, LEN_MOSGEOM, TY_STRUCT) # Allocate and initialise the Index vector call calloc (IMIDX(mgout), IM_MAXDIM, TY_LONG) # Determine dimensions of composite image # Retain the rectangle which contains the union of the CCD sections mgin1 = MI_MG(mi, 1) x1 = CX1(mgin1) x2 = CX2(mgin1) y1 = CY1(mgin1) y2 = CY2(mgin1) do i = 2, ninput { mgin1 = MI_MG(mi, i) x1 = min (x1, CX1(mgin1)) x2 = max (x2, CX2(mgin1)) y1 = min (y1, CY1(mgin1)) y2 = max (y2, CY2(mgin1)) } NX(mgout) = x2 - x1 + 1 NY(mgout) = y2 - y1 + 1 CX1(mgout) = x1 CX2(mgout) = x2 CY1(mgout) = y1 CY2(mgout) = y2 DX1(mgout) = 1 DX2(mgout) = NX(mgout) DY1(mgout) = 1 DY2(mgout) = NY(mgout) TX1(mgout) = 1 TX2(mgout) = NX(mgout) TY1(mgout) = 1 TY2(mgout) = NY(mgout) BX1(mgout) = 0 BX2(mgout) = 0 BY1(mgout) = 0 BY2(mgout) = 0 CCDNAME(mgout) = NULL AMPID(mgout) = NULL PROC(mgout) = NO DOBIAS(mgout) = NO DOZERO(mgout) = NO DOFLAT(mgout) = NO DZIM(mgout) = NULL DFIM(mgout) = NULL BIAS(mgout) = 0.0 OVRSCN(mgout) = NULL GAIN(mgout) = 1.0 DARK(mgout) = 0.0 CKNODATA(mgout) = NO NODATA(mgout) = NO return (mgout) end # MG_SORT -- Sort elements. int procedure mg_sort (mi1, mi2) pointer mi1, mi2 begin if (CY1(mi1) < CY1(mi2)) return (-1) else if (CY1(mi1) > CY1(mi2)) return (1) else if (CX1(mi1) < CX1(mi2)) return (-1) else if (CX1(mi1) > CX1(mi2)) return (1) else return (0) end # MG_FREE -- Free associated mosgeom structure. procedure mg_free (mg) pointer mg #I Pointer to mosgeom structure for image begin if (mg != NULL) { if (DZIM(mg) != NULL) call imunmap (DZIM(mg)) if (DFIM(mg) != NULL) call imunmap (DFIM(mg)) if (IMIDX(mg) != NULL) call mfree (IMIDX(mg), TY_LONG) if (CCDNAME(mg) != NULL) call mfree (CCDNAME(mg), TY_CHAR) if (AMPID(mg) != NULL) call mfree (AMPID(mg), TY_CHAR) if (OVRSCN(mg) != NULL) call mfree (OVRSCN(mg), TY_REAL) call mfree (mg, TY_STRUCT) } end # MG_DUMP -- Dump contents of mosgeom structure procedure mg_dump(mg) pointer mg # Mosgeom strudture to dump. begin if (CCDNAME(mg) != NULL) { call eprintf ("CCDNAME=%s\n") call pargstr (Memc[CCDNAME(mg)]) } else { call pargstr ("undefined") } if (AMPID(mg) != NULL) { call eprintf ("AMPID=%s\n") call pargstr (Memc[AMPID(mg)]) } else { call pargstr ("undefined") } call eprintf ("NX=%d NY= %d\n") call pargi (NX(mg)) call pargi (NY(mg)) call eprintf ("IMIDX=%d: ") call pargi (IMIDX(mg)) if (IMIDX(mg) != NULL) { call eprintf ("(%d %d %d %d %d %d %d)\n") call pargi (Meml(IMIDX(mg))) call pargi (Meml(IMIDX(mg)+1)) call pargi (Meml(IMIDX(mg)+2)) call pargi (Meml(IMIDX(mg)+3)) call pargi (Meml(IMIDX(mg)+4)) call pargi (Meml(IMIDX(mg)+5)) call pargi (Meml(IMIDX(mg)+6)) } else { call eprintf ("undefined\n") } call eprintf (" CCDSEC: x1=%d \tx2=%d \ty1=%d \ty2=%d\n") call pargi (CX1(mg)) call pargi (CX2(mg)) call pargi (CY1(mg)) call pargi (CY2(mg)) call eprintf ("DATASEC: x1=%d \tx2=%d \ty1=%d \ty2=%d\n") call pargi (DX1(mg)) call pargi (DX2(mg)) call pargi (DY1(mg)) call pargi (DY2(mg)) call eprintf ("TRIMSEC: x1=%d \tx2=%d \ty1=%d \ty2=%d\n") call pargi (TX1(mg)) call pargi (TX2(mg)) call pargi (TY1(mg)) call pargi (TY2(mg)) call eprintf ("BIASSEC: x1=%d \tx2=%d \ty1=%d \ty2=%d\n") call pargi (BX1(mg)) call pargi (BX2(mg)) call pargi (BY1(mg)) call pargi (BY2(mg)) call eprintf ("Offset=%f Gain=%f Dark=%f -->Overscan=%d\n") call pargr (BIAS(mg)) call pargr (GAIN(mg)) call pargr (DARK(mg)) call pargi (OVRSCN(mg)) end # MG_AMPID -- Get AMPID for an image. procedure mg_ampid (im, ampid, maxch) pointer im #I IMIO pointer for image. char ampid[ARB] #O amplifier id string int maxch #I Maximum length of ampid. begin call hdmgstr (im, "amp", ampid, maxch) if (ampid[1] == EOS) call hdmgstr (im, "imageid", ampid, maxch) if (ampid[1] == EOS) { call hdmgstr (im, "extname", ampid, maxch) if (ampid[1] == EOS) call mg_ampname (im, ampid, maxch) else call hdmname (ampid, ampid, maxch) } end # MG_AMPNAME -- Derive the amplifier name from the image name. # The assumption is that the image name is of the form # # rootname_ampname.imh procedure mg_ampname (im, ampname, maxch) pointer im #I IMIO pointer for image. char ampname[maxch] #O Amplifier name. int maxch #I Max chars in amplname. int brk, brkend pointer sp, imname, imroot int stridxs() begin call smark (sp) call salloc (imname, SZ_LINE, TY_CHAR) call salloc (imroot, SZ_LINE, TY_CHAR) call imstats (im, IM_IMAGENAME, Memc[imname], SZ_LINE) call xt_imroot (Memc[imname], Memc[imroot], SZ_LINE) brk = stridxs ("_", Memc[imroot]) brkend = stridxs (".", Memc[imroot+brk]) if (brk > 0) { # # Beware of filenames of the form ../*.imh and ./*.imh with no ampid ! # if (strncmp (Memc[imroot+brk], "/", 1) == 0) { # ampname[1] = EOS # # } else { Memc[imroot+brk+brkend-1] = EOS call strcpy (Memc[imroot+brk], ampname, maxch) # } } else { ampname[1] = EOS } call sfree (sp) end # MG_ROOTNAME -- Derive the rootname from the image name. # The assumption is that the image name is of the form # # rootname_ampname.imh # # Our job is to strip off the .ampname and image type extension. # If there is no extension then return the entire image name. procedure mg_rootname (image, rootname, maxch) char image[ARB] #I Image name. char rootname[maxch] #O Rootname of image. int maxch #I Max chars in rootname. int brk pointer sp, imroot int stridxs() begin call smark (sp) call salloc (imroot, SZ_LINE, TY_CHAR) call xt_imroot (image, Memc[imroot], SZ_LINE) brk = stridxs ("_", Memc[imroot]) if (brk > 0) { # # Beware of filenames of the form ../*.imh and ./*.imh with no ampid ! # if (strncmp (Memc[imroot+brk], "/", 1) == 0) { # call strcpy (Memc[imroot], rootname, maxch) # # } else { brk = min (brk-1, maxch) call strcpy (Memc[imroot], rootname, brk) # } } else { call strcpy (Memc[imroot], rootname, maxch) } call sfree (sp) end # MG_C2IM -- Convert a mosaic coordinate to an image coordinate. procedure mg_c2im (mi, x, y, im, xim, yim) pointer mi #I MOSIM structure real x, y #I Coordinate in composite geometry pointer im #O Image pointer real xim, yim #O Coordinate in image int i real cx1, cx2, cy1, cy2 pointer cmg, mg begin cmg = MI_CMG(mi) do i = 1, MI_NIMS(mi) { mg = MI_MG(mi,i) cx1 = CX1(mg) - 0.5 cx2 = CX2(mg) + 0.5 cy1 = CY1(mg) - 0.5 cy2 = CY2(mg) + 0.5 if (x < cx1 || x > cx2 || y < cy1 || y > cy2) next im = MI_IM(mi,i) xim = (x - CX1(mg) - (DX(mg) - 1) / 2.) / DX(mg) + DX1(mg) yim = (y - CY1(mg) - (DY(mg) - 1) / 2.) / DY(mg) + DY1(mg) return } call error (1, "Mosaic coordinate outside any image") end # MG_IM2C -- Convert an image coordinate to a mosaic coordinate. procedure mg_im2c (im, xim, yim, mi, x, y) pointer im #I Image pointer real xim, yim #I Coordinate in image pointer mi #I MOSIM structure real x, y #0 Coordinate in composite geometry int i pointer mg begin do i = 1, MI_NIMS(mi) { if (im != MI_IM(mi,i)) next mg = MI_MG(mi,i) x = (xim - DX1(mg)) * DX(mg) + CX1(mg) + (DX(mg) - 1) / 2. y = (yim - DY1(mg)) * DY(mg) + CY1(mg) + (DY(mg) - 1) / 2. return } call error (1, "Image is not in the mosaic") end # MKDETSEC -- Make a detector section from the WCS. # This is relative to the image where nim is zero. procedure mkdetsec (mg, nim, wref, lref, section, maxchar) pointer mg #I Mosaic geometry structure int nim #I Image number double wref[4] #U Reference WCS coordinate double lref[4] #U Reference logical coordinate char section[maxchar] #O Detector section int maxchar #I Maximum characters in detector section double l[4], c1, c2, l1, l2 pointer mw, ct, mw_openim(), mw_sctran errchk mw_openim, mw_sctran, mw_ctrand begin # Open WCS. mw = mw_openim (MG_IM(mg)) # Use the tangent point of the first image as the reference. if (nim == 1) { call mw_gwtermd (mw, lref, wref, l, 2) ct = mw_sctran (mw, "world", "logical", 3) call mw_c2trand (ct, wref[1], wref[2], lref[1], lref[2]) # Compute second reference coordinate for determining flips. if (DX1(mg) < DX2(mg)) lref[3] = lref[1] + 1 else lref[3] = lref[1] - 1 if (DY1(mg) < DY2(mg)) lref[4] = lref[2] + 1 else lref[4] = lref[2] - 1 ct = mw_sctran (mw, "logical", "world", 3) call mw_c2trand (ct, lref[3], lref[4], wref[3], wref[4]) call amovd (lref, l, 4) # Find offsets relative to the first image reference coordinates. } else { ct = mw_sctran (mw, "world", "logical", 3) call mw_c2trand (ct, wref[1], wref[2], l[1], l[2]) call mw_c2trand (ct, wref[3], wref[4], l[3], l[4]) } # Compute logical detector coordinates. if ((lref[3]-lref[1])*(l[3]-l[1]) > 0.) { c1 = DX1(mg) + (lref[1] - l[1]) c2 = DX2(mg) + (lref[1] - l[1]) } else { c1 = DX2(mg) + (lref[1] - (NX(mg) - l[1] + 1)) c2 = DX1(mg) + (lref[1] - (NX(mg) - l[1] + 1)) } if ((lref[4]-lref[2])*(l[4]-l[2]) > 0.) { l1 = DY1(mg) + (lref[2] - l[2]) l2 = DY2(mg) + (lref[2] - l[2]) } else { l1 = DY2(mg) + (lref[2] - (NY(mg) - l[2] + 1)) l2 = DY1(mg) + (lref[2] - (NY(mg) - l[2] + 1)) } call mw_close (mw) # Format the detector section. call sprintf (section, maxchar, "[%d:%d,%d:%d]") call pargi (nint(c1)) call pargi (nint(c2)) call pargi (nint(l1)) call pargi (nint(l2)) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mosproc.com�����������������������������������������������0000664�0000000�0000000�00000000353�13321663143�0021677�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MOSPROC.COM -- Common for processing flags. bool trim # Trim images int proc # Proc flag real blank # Blank fill value real sample # Sample size for determining average overscan level common /mosproc/ trim, proc, blank, sample �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mosproc.h�������������������������������������������������0000664�0000000�0000000�00000002512�13321663143�0021347�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MOSQPROC.H -- Definitions for values of the proc flag and associated macros # The value of the flag are defined as bit fields so that it is possible to # add corrections to form a unique combined correction. define D 001B # subtract Dark define G 002B # adjust Gain define C 010B # subtract Constant overscan. define A 020B # subtract Average of overscan. define L 040B # subtract Line overscan. define F 100B # subtract Fitted overscan. # The following combinations are possible. define NONE 000B # No processing define DG 003B # No overscan + Dark + Gain define CD 011B # Constant overscan + Dark define CG 012B # Constant overscan + Gain define CDG 013B # Constant overscan + Dark + Gain define AD 021B # Average overscan + Dark define AG 022B # Average overscan + Gain define ADG 023B # Average overscan + Dark + Gain define LD 041B # Line overscan + Dark define LG 042B # Line overscan + Gain define LDG 043B # Line overscan + Dark + Gain define FD 101B # Fitted overscan + Dark define FG 102B # Fitted overscan + Gain define FDG 103B # Fitted overscan + Dark + Gain define OT_DICT "|none|constant|average|line|fit|" define OT_NONE 1 define OT_CONST 2 define OT_AVG 3 define OT_LINE 4 define OT_FIT 5 # Sample size for average as fraction of height of overscan strip define SAMPLE 0.0025 ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mscg.gx���������������������������������������������������0000664�0000000�0000000�00000027160�13321663143�0021013�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosgeom.h" $for (silrd) # MSCL2 -- Get line of data. pointer procedure mscl2$t (mg, line) pointer mg #I MOSGEOM pointer int line #I Line int i, nc, b1, b2, nb real bias pointer im, dzbuf, dfbuf, inbuf, outbuf pointer imgl2$t() $if (datatype == csir) real asum$t() $else $if (datatype == ld) double asum$t() $else PIXEL procedure asum$t() $endif $endif $if (datatype != s) pointer mscbuf(), imgl2s() real asums() $endif $if (datatype != r) pointer imgl2r() $endif $if (datatype != i) pointer imgl2i() $endif begin im = MG_IM(mg) nc = IM_LEN(im,1) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgl2s (im, line) IM_PIXTYPE(im) = TY_USHORT $if (datatype == s) outbuf = inbuf $else outbuf = mscbuf (nc, TY_PIXEL) $endif if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { inbuf = imgl2$t (im, line) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asum$t (Mem$t[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (outbuf) end # MSCNL -- Get next line of data. int procedure mscnl$t (mg, outbuf, v) pointer mg #I MOSGEOM pointer pointer outbuf #I Data buffer long v[ARB] #I Vector int i, nc, b1, b2, nb, stat long vf[IM_MAXDIM] real bias pointer im, dzbuf, dfbuf, inbuf pointer imgnl$t() $if (datatype == csir) real asum$t() $else $if (datatype == ld) double asum$t() $else PIXEL procedure asum$t() $endif $endif $if (datatype != s) pointer mscbuf(), imgnls() real asums() $endif $if (datatype != r) pointer imgnlr() $endif $if (datatype != i) pointer imgnli() $endif begin im = MG_IM(mg) nc = IM_LEN(im,1) call amovl (v, vf, IM_NDIM(im)) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT stat = imgnls (im, inbuf, v) if (stat == EOF) return (stat) IM_PIXTYPE(im) = TY_USHORT $if (datatype == s) outbuf = inbuf $else outbuf = mscbuf (nc, TY_PIXEL) $endif if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (stat) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuproc$t (Mems[inbuf], Mem$t[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { stat = imgnl$t (im, inbuf, v) outbuf = inbuf if (PROC(mg) == NO) return (stat) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asum$t (Mem$t[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscproc$t (Mem$t[inbuf], Mem$t[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (stat) end # MSCS2 -- Get section of data. pointer procedure mscs2$t (mg, x1, x2, y1, y2) pointer mg #I MOSGEOM pointer int x1, x2, y1, y2 #I Section int i, c1, c2, nc, nl, np, b1, b2, nb, line real bias pointer im, dzbuf, dfbuf, inbuf, outbuf, inptr, outptr pointer imgs2$t(), imgl2i(), imgl2r() $if (datatype == csir) real asum$t() $else $if (datatype == ld) double asum$t() $else PIXEL procedure asum$t() $endif $endif $if (datatype != s) pointer mscbuf(), imgs2s() real asums() $endif begin im = MG_IM(mg) if (PROC(mg) == NO) { c1 = x1 c2 = x2 } else { c1 = 1 c2 = IM_LEN(im,1) } nc = x2 - x1 + 1 nl = y2 - y1 + 1 np = nc * nl if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgs2s (im, c1, c2, y1, y2) IM_PIXTYPE(im) = TY_USHORT $if (datatype == s) outbuf = inbuf $else outbuf = mscbuf (np, TY_PIXEL) $endif if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, np-1 if (Mems[inbuf+i] != 0) break if (i == np) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuproc$t (Mems[inbuf], Mem$t[outbuf], np, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= c2) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuproc$t (Mems[inptr], Mem$t[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscuproc$t (Mems[inptr], Mem$t[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuproc$t (Mems[inptr], Mem$t[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuproc$t (Mems[inptr], Mem$t[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } else { inbuf = imgs2$t (im, c1, c2, y1, y2) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= nc) bias = asum$t (Mem$t[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscproc$t (Mem$t[inptr], Mem$t[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscproc$t (Mem$t[inptr], Mem$t[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscproc$t (Mem$t[inptr], Mem$t[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscproc$t (Mem$t[inptr], Mem$t[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } return (outbuf) end # MSCUPROC - Process unsigned input. procedure mscuproc$t (in, out, n, bias, zero, flat, ccdmean) short in[ARB] PIXEL out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call achts$t (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCPROC - Process input. procedure mscproc$t (in, out, n, bias, zero, flat, ccdmean) PIXEL in[ARB] PIXEL out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call amov$t (in, out, n) else do i = 1, n out[i] = in[i] - bias } end $endfor # MSCBUF -- Maintain buffer when data type conversion from IMIO is needed. pointer procedure mscbuf (buflen, buftype) int buflen #I buffer length int buftype #I buffer type int n, type pointer buf data n/0/, type/0/, buf/NULL/ begin if (buflen == n && buftype == type) return (buf) if (buftype != type) { call mfree (buf, type) n = 0 } if (n == 0) call malloc (buf, buflen, buftype) else call realloc (buf, buflen, buftype) n = buflen type = buftype return (buf) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/mscg.x����������������������������������������������������0000664�0000000�0000000�00000147131�13321663143�0020645�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include "mosgeom.h" # MSCL2 -- Get line of data. pointer procedure mscl2s (mg, line) pointer mg #I MOSGEOM pointer int line #I Line int i, nc, b1, b2, nb real bias pointer im, dzbuf, dfbuf, inbuf, outbuf pointer imgl2s() real asums() pointer imgl2r() pointer imgl2i() begin im = MG_IM(mg) nc = IM_LEN(im,1) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgl2s (im, line) IM_PIXTYPE(im) = TY_USHORT outbuf = inbuf if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocs (Mems[inbuf], Mems[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { inbuf = imgl2s (im, line) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (outbuf) end # MSCNL -- Get next line of data. int procedure mscnls (mg, outbuf, v) pointer mg #I MOSGEOM pointer pointer outbuf #I Data buffer long v[ARB] #I Vector int i, nc, b1, b2, nb, stat long vf[IM_MAXDIM] real bias pointer im, dzbuf, dfbuf, inbuf pointer imgnls() real asums() pointer imgnlr() pointer imgnli() begin im = MG_IM(mg) nc = IM_LEN(im,1) call amovl (v, vf, IM_NDIM(im)) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT stat = imgnls (im, inbuf, v) if (stat == EOF) return (stat) IM_PIXTYPE(im) = TY_USHORT outbuf = inbuf if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocs (Mems[inbuf], Mems[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (stat) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { stat = imgnls (im, inbuf, v) outbuf = inbuf if (PROC(mg) == NO) return (stat) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocs (Mems[inbuf], Mems[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (stat) end # MSCS2 -- Get section of data. pointer procedure mscs2s (mg, x1, x2, y1, y2) pointer mg #I MOSGEOM pointer int x1, x2, y1, y2 #I Section int i, c1, c2, nc, nl, np, b1, b2, nb, line real bias pointer im, dzbuf, dfbuf, inbuf, outbuf, inptr, outptr pointer imgs2s(), imgl2i(), imgl2r() real asums() begin im = MG_IM(mg) if (PROC(mg) == NO) { c1 = x1 c2 = x2 } else { c1 = 1 c2 = IM_LEN(im,1) } nc = x2 - x1 + 1 nl = y2 - y1 + 1 np = nc * nl if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgs2s (im, c1, c2, y1, y2) IM_PIXTYPE(im) = TY_USHORT outbuf = inbuf if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, np-1 if (Mems[inbuf+i] != 0) break if (i == np) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocs (Mems[inbuf], Mems[outbuf], np, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= c2) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocs (Mems[inptr], Mems[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscuprocs (Mems[inptr], Mems[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocs (Mems[inptr], Mems[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocs (Mems[inptr], Mems[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } else { inbuf = imgs2s (im, c1, c2, y1, y2) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= nc) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocs (Mems[inptr], Mems[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscprocs (Mems[inptr], Mems[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocs (Mems[inptr], Mems[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocs (Mems[inptr], Mems[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } return (outbuf) end # MSCUPROC - Process unsigned input. procedure mscuprocs (in, out, n, bias, zero, flat, ccdmean) short in[ARB] short out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call achtss (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCPROC - Process input. procedure mscprocs (in, out, n, bias, zero, flat, ccdmean) short in[ARB] short out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call amovs (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCL2 -- Get line of data. pointer procedure mscl2i (mg, line) pointer mg #I MOSGEOM pointer int line #I Line int i, nc, b1, b2, nb real bias pointer im, dzbuf, dfbuf, inbuf, outbuf pointer imgl2i() real asumi() pointer mscbuf(), imgl2s() real asums() pointer imgl2r() begin im = MG_IM(mg) nc = IM_LEN(im,1) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgl2s (im, line) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_INT) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuproci (Mems[inbuf], Memi[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { inbuf = imgl2i (im, line) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asumi (Memi[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (outbuf) end # MSCNL -- Get next line of data. int procedure mscnli (mg, outbuf, v) pointer mg #I MOSGEOM pointer pointer outbuf #I Data buffer long v[ARB] #I Vector int i, nc, b1, b2, nb, stat long vf[IM_MAXDIM] real bias pointer im, dzbuf, dfbuf, inbuf pointer imgnli() real asumi() pointer mscbuf(), imgnls() real asums() pointer imgnlr() begin im = MG_IM(mg) nc = IM_LEN(im,1) call amovl (v, vf, IM_NDIM(im)) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT stat = imgnls (im, inbuf, v) if (stat == EOF) return (stat) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_INT) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuproci (Mems[inbuf], Memi[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (stat) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuproci (Mems[inbuf], Memi[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { stat = imgnli (im, inbuf, v) outbuf = inbuf if (PROC(mg) == NO) return (stat) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asumi (Memi[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscproci (Memi[inbuf], Memi[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (stat) end # MSCS2 -- Get section of data. pointer procedure mscs2i (mg, x1, x2, y1, y2) pointer mg #I MOSGEOM pointer int x1, x2, y1, y2 #I Section int i, c1, c2, nc, nl, np, b1, b2, nb, line real bias pointer im, dzbuf, dfbuf, inbuf, outbuf, inptr, outptr pointer imgs2i(), imgl2i(), imgl2r() real asumi() pointer mscbuf(), imgs2s() real asums() begin im = MG_IM(mg) if (PROC(mg) == NO) { c1 = x1 c2 = x2 } else { c1 = 1 c2 = IM_LEN(im,1) } nc = x2 - x1 + 1 nl = y2 - y1 + 1 np = nc * nl if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgs2s (im, c1, c2, y1, y2) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (np, TY_INT) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, np-1 if (Mems[inbuf+i] != 0) break if (i == np) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuproci (Mems[inbuf], Memi[outbuf], np, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= c2) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuproci (Mems[inptr], Memi[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscuproci (Mems[inptr], Memi[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuproci (Mems[inptr], Memi[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuproci (Mems[inptr], Memi[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } else { inbuf = imgs2i (im, c1, c2, y1, y2) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= nc) bias = asumi (Memi[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscproci (Memi[inptr], Memi[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscproci (Memi[inptr], Memi[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscproci (Memi[inptr], Memi[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscproci (Memi[inptr], Memi[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } return (outbuf) end # MSCUPROC - Process unsigned input. procedure mscuproci (in, out, n, bias, zero, flat, ccdmean) short in[ARB] int out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call achtsi (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCPROC - Process input. procedure mscproci (in, out, n, bias, zero, flat, ccdmean) int in[ARB] int out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call amovi (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCL2 -- Get line of data. pointer procedure mscl2l (mg, line) pointer mg #I MOSGEOM pointer int line #I Line int i, nc, b1, b2, nb real bias pointer im, dzbuf, dfbuf, inbuf, outbuf pointer imgl2l() double asuml() pointer mscbuf(), imgl2s() real asums() pointer imgl2r() pointer imgl2i() begin im = MG_IM(mg) nc = IM_LEN(im,1) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgl2s (im, line) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_LONG) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocl (Mems[inbuf], Meml[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { inbuf = imgl2l (im, line) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asuml (Meml[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (outbuf) end # MSCNL -- Get next line of data. int procedure mscnll (mg, outbuf, v) pointer mg #I MOSGEOM pointer pointer outbuf #I Data buffer long v[ARB] #I Vector int i, nc, b1, b2, nb, stat long vf[IM_MAXDIM] real bias pointer im, dzbuf, dfbuf, inbuf pointer imgnll() double asuml() pointer mscbuf(), imgnls() real asums() pointer imgnlr() pointer imgnli() begin im = MG_IM(mg) nc = IM_LEN(im,1) call amovl (v, vf, IM_NDIM(im)) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT stat = imgnls (im, inbuf, v) if (stat == EOF) return (stat) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_LONG) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocl (Mems[inbuf], Meml[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (stat) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocl (Mems[inbuf], Meml[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { stat = imgnll (im, inbuf, v) outbuf = inbuf if (PROC(mg) == NO) return (stat) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asuml (Meml[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocl (Meml[inbuf], Meml[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (stat) end # MSCS2 -- Get section of data. pointer procedure mscs2l (mg, x1, x2, y1, y2) pointer mg #I MOSGEOM pointer int x1, x2, y1, y2 #I Section int i, c1, c2, nc, nl, np, b1, b2, nb, line real bias pointer im, dzbuf, dfbuf, inbuf, outbuf, inptr, outptr pointer imgs2l(), imgl2i(), imgl2r() double asuml() pointer mscbuf(), imgs2s() real asums() begin im = MG_IM(mg) if (PROC(mg) == NO) { c1 = x1 c2 = x2 } else { c1 = 1 c2 = IM_LEN(im,1) } nc = x2 - x1 + 1 nl = y2 - y1 + 1 np = nc * nl if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgs2s (im, c1, c2, y1, y2) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (np, TY_LONG) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, np-1 if (Mems[inbuf+i] != 0) break if (i == np) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocl (Mems[inbuf], Meml[outbuf], np, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= c2) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocl (Mems[inptr], Meml[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscuprocl (Mems[inptr], Meml[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocl (Mems[inptr], Meml[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocl (Mems[inptr], Meml[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } else { inbuf = imgs2l (im, c1, c2, y1, y2) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= nc) bias = asuml (Meml[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocl (Meml[inptr], Meml[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscprocl (Meml[inptr], Meml[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocl (Meml[inptr], Meml[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocl (Meml[inptr], Meml[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } return (outbuf) end # MSCUPROC - Process unsigned input. procedure mscuprocl (in, out, n, bias, zero, flat, ccdmean) short in[ARB] long out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call achtsl (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCPROC - Process input. procedure mscprocl (in, out, n, bias, zero, flat, ccdmean) long in[ARB] long out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call amovl (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCL2 -- Get line of data. pointer procedure mscl2r (mg, line) pointer mg #I MOSGEOM pointer int line #I Line int i, nc, b1, b2, nb real bias pointer im, dzbuf, dfbuf, inbuf, outbuf pointer imgl2r() real asumr() pointer mscbuf(), imgl2s() real asums() pointer imgl2i() begin im = MG_IM(mg) nc = IM_LEN(im,1) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgl2s (im, line) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_REAL) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocr (Mems[inbuf], Memr[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { inbuf = imgl2r (im, line) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asumr (Memr[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (outbuf) end # MSCNL -- Get next line of data. int procedure mscnlr (mg, outbuf, v) pointer mg #I MOSGEOM pointer pointer outbuf #I Data buffer long v[ARB] #I Vector int i, nc, b1, b2, nb, stat long vf[IM_MAXDIM] real bias pointer im, dzbuf, dfbuf, inbuf pointer imgnlr() real asumr() pointer mscbuf(), imgnls() real asums() pointer imgnli() begin im = MG_IM(mg) nc = IM_LEN(im,1) call amovl (v, vf, IM_NDIM(im)) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT stat = imgnls (im, inbuf, v) if (stat == EOF) return (stat) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_REAL) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocr (Mems[inbuf], Memr[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (stat) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocr (Mems[inbuf], Memr[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { stat = imgnlr (im, inbuf, v) outbuf = inbuf if (PROC(mg) == NO) return (stat) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asumr (Memr[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocr (Memr[inbuf], Memr[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (stat) end # MSCS2 -- Get section of data. pointer procedure mscs2r (mg, x1, x2, y1, y2) pointer mg #I MOSGEOM pointer int x1, x2, y1, y2 #I Section int i, c1, c2, nc, nl, np, b1, b2, nb, line real bias pointer im, dzbuf, dfbuf, inbuf, outbuf, inptr, outptr pointer imgs2r(), imgl2i(), imgl2r() real asumr() pointer mscbuf(), imgs2s() real asums() begin im = MG_IM(mg) if (PROC(mg) == NO) { c1 = x1 c2 = x2 } else { c1 = 1 c2 = IM_LEN(im,1) } nc = x2 - x1 + 1 nl = y2 - y1 + 1 np = nc * nl if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgs2s (im, c1, c2, y1, y2) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (np, TY_REAL) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, np-1 if (Mems[inbuf+i] != 0) break if (i == np) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocr (Mems[inbuf], Memr[outbuf], np, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= c2) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocr (Mems[inptr], Memr[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscuprocr (Mems[inptr], Memr[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocr (Mems[inptr], Memr[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocr (Mems[inptr], Memr[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } else { inbuf = imgs2r (im, c1, c2, y1, y2) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= nc) bias = asumr (Memr[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocr (Memr[inptr], Memr[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscprocr (Memr[inptr], Memr[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocr (Memr[inptr], Memr[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocr (Memr[inptr], Memr[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } return (outbuf) end # MSCUPROC - Process unsigned input. procedure mscuprocr (in, out, n, bias, zero, flat, ccdmean) short in[ARB] real out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call achtsr (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCPROC - Process input. procedure mscprocr (in, out, n, bias, zero, flat, ccdmean) real in[ARB] real out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call amovr (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCL2 -- Get line of data. pointer procedure mscl2d (mg, line) pointer mg #I MOSGEOM pointer int line #I Line int i, nc, b1, b2, nb real bias pointer im, dzbuf, dfbuf, inbuf, outbuf pointer imgl2d() double asumd() pointer mscbuf(), imgl2s() real asums() pointer imgl2r() pointer imgl2i() begin im = MG_IM(mg) nc = IM_LEN(im,1) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgl2s (im, line) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_DOUBLE) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocd (Mems[inbuf], Memd[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { inbuf = imgl2d (im, line) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asumd (Memd[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) dfbuf = imgl2i (DFIM(mg), line) call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (outbuf) end # MSCNL -- Get next line of data. int procedure mscnld (mg, outbuf, v) pointer mg #I MOSGEOM pointer pointer outbuf #I Data buffer long v[ARB] #I Vector int i, nc, b1, b2, nb, stat long vf[IM_MAXDIM] real bias pointer im, dzbuf, dfbuf, inbuf pointer imgnld() double asumd() pointer mscbuf(), imgnls() real asums() pointer imgnlr() pointer imgnli() begin im = MG_IM(mg) nc = IM_LEN(im,1) call amovl (v, vf, IM_NDIM(im)) if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT stat = imgnls (im, inbuf, v) if (stat == EOF) return (stat) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (nc, TY_DOUBLE) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, nc-1 if (Mems[inbuf+i] != 0) break if (i == nc) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocd (Mems[inbuf], Memd[outbuf], nc, -32768., INDEFR, INDEFI, INDEFR) return (stat) } # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asums (Mems[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocd (Mems[inbuf], Memd[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } else { stat = imgnld (im, inbuf, v) outbuf = inbuf if (PROC(mg) == NO) return (stat) # Process data. bias = 0. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) if (b1 >= 1 && b2 <= nc) { nb = b2 - b1 + 1 bias = asumd (Memd[inbuf+b1-1], nb)/ nb } } if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call amovl (v, vf, IM_NDIM(im)) stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { stat = imgnlr (DZIM(mg), dzbuf, vf) call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { stat = imgnli (DFIM(mg), dfbuf, vf) call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocd (Memd[inbuf], Memd[outbuf], nc, bias, INDEFR, INDEFI, INDEFR) } return (stat) end # MSCS2 -- Get section of data. pointer procedure mscs2d (mg, x1, x2, y1, y2) pointer mg #I MOSGEOM pointer int x1, x2, y1, y2 #I Section int i, c1, c2, nc, nl, np, b1, b2, nb, line real bias pointer im, dzbuf, dfbuf, inbuf, outbuf, inptr, outptr pointer imgs2d(), imgl2i(), imgl2r() double asumd() pointer mscbuf(), imgs2s() real asums() begin im = MG_IM(mg) if (PROC(mg) == NO) { c1 = x1 c2 = x2 } else { c1 = 1 c2 = IM_LEN(im,1) } nc = x2 - x1 + 1 nl = y2 - y1 + 1 np = nc * nl if (MG_USHORT(mg) == YES) { IM_PIXTYPE(im) = TY_SHORT inbuf = imgs2s (im, c1, c2, y1, y2) IM_PIXTYPE(im) = TY_USHORT outbuf = mscbuf (np, TY_DOUBLE) if (CKNODATA(mg) == YES) { NODATA(mg) = NO do i = 0, np-1 if (Mems[inbuf+i] != 0) break if (i == np) { NODATA(mg) = YES return (outbuf) } } if (PROC(mg) == NO) { call mscuprocd (Mems[inbuf], Memd[outbuf], np, -32768., INDEFR, INDEFI, INDEFR) return (outbuf) } # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= c2) bias = asums (Mems[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocd (Mems[inptr], Memd[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscuprocd (Mems[inptr], Memd[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscuprocd (Mems[inptr], Memd[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscuprocd (Mems[inptr], Memd[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } else { inbuf = imgs2d (im, c1, c2, y1, y2) outbuf = inbuf if (PROC(mg) == NO) return (outbuf) # Process data. if (DOBIAS(mg) == YES) { b1 = min (BX1(mg), BX2(mg)) b2 = max (BX1(mg), BX2(mg)) nb = b2 - b1 + 1 } else { b1 = 0 b2 = 0 } do line = y1, y2 { inptr = inbuf + (line - y1) * (c2 - c1 + 1) bias = 0. if (b1 >= 1 && b2 <= nc) bias = asumd (Memd[inptr+b1-1], nb)/ nb inptr = inbuf + (line - y1) * (c2 - c1 + 1) + x1 - 1 outptr = outbuf + (line - y1) * nc if (DOZERO(mg) == YES && DOFLAT(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocd (Memd[inptr], Memd[outptr], nc, bias, Memr[dzbuf], Memi[dfbuf], CCDMEAN(mg)) } else if (DOZERO(mg) == YES) { dzbuf = imgl2r (DZIM(mg), line) + x1 - 1 call mscprocd (Memd[inptr], Memd[outptr], nc, bias, Memr[dzbuf], INDEFI, INDEFR) } else if (DOFLAT(mg) == YES) { dfbuf = imgl2i (DFIM(mg), line) + x1 - 1 call mscprocd (Memd[inptr], Memd[outptr], nc, bias, INDEFR, Memi[dfbuf], CCDMEAN(mg)) } else call mscprocd (Memd[inptr], Memd[outptr], nc, bias, INDEFR, INDEFI, INDEFR) } } return (outbuf) end # MSCUPROC - Process unsigned input. procedure mscuprocd (in, out, n, bias, zero, flat, ccdmean) short in[ARB] double out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call achtsd (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCPROC - Process input. procedure mscprocd (in, out, n, bias, zero, flat, ccdmean) double in[ARB] double out[ARB] int n real bias real zero[ARB] int flat[ARB] real ccdmean int i real val begin if (!IS_INDEFR(ccdmean) && !IS_INDEFR(zero[1])) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - zero[i] - bias) / val } } else if (!IS_INDEFR(ccdmean)) { do i = 1, n { val = flat[i] / ccdmean if (val <= 0.) val = 1. out[i] = (in[i] - bias) / val } } else if (!IS_INDEFR(zero[1])) { do i = 1, n out[i] = in[i] - zero[i] - bias } else { if (bias == 0.) call amovd (in, out, n) else do i = 1, n out[i] = in[i] - bias } end # MSCBUF -- Maintain buffer when data type conversion from IMIO is needed. pointer procedure mscbuf (buflen, buftype) int buflen #I buffer length int buftype #I buffer type int n, type pointer buf data n/0/, type/0/, buf/NULL/ begin if (buflen == n && buftype == type) return (buf) if (buftype != type) { call mfree (buf, type) n = 0 } if (n == 0) call malloc (buf, buflen, buftype) else call realloc (buf, buflen, buftype) n = buflen type = buftype return (buf) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/proc.x����������������������������������������������������0000664�0000000�0000000�00000006414�13321663143�0020655�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include "mosproc.h" include "mosgeom.h" # PROCSET -- Set value of proc flag according to task parameters. procedure procset () #pointer sp, buffer #int otype # #int clgwrd() #bool clgetb() #real clgetr() include "mosproc.com" begin proc = NONE # call smark (sp) # call salloc (buffer, SZ_LINE, TY_CHAR) # # trim = clgetb ("trim") # # # Overscan subtraction # otype = clgwrd ("overscan", Memc[buffer], SZ_LINE, OT_DICT) # switch (otype) { # case OT_CONST: # proc = C # case OT_AVG: # proc = A # case OT_LINE: # proc = L # case OT_FIT: # proc = F # default: # proc = NONE # } # # # Gain correction # if (clgetb ("gain")) # proc = proc + G # # # Dark subtraction # if (clgetb ("dark")) # proc = proc + D # # blank = clgetr("blank") # # # For now use a fixed sample size # sample = SAMPLE end # Bias, Dark and Gain correct (or uncorrect) the z1 and z2 values. procedure zproc (inmg, z1, z2, ninput, proc, direction) pointer inmg[ARB] # Array of mosgeom structures. real z1[ARB] # Array of z1 values. real z2[ARB] # Array of z2 values. int ninput # Number of values. int proc # Processing flag. int direction # UNCORRECT = 0, CORRECT = 1 int i real k1, k2 begin if (direction == 1) { switch (proc) { # return imediately if no processing is required. case NONE: return case D: do i = 1, ninput { k1 = DARK(inmg[i]) z1[i] = z1[i] - k1 z2[i] = z2[i] - k1 } case C, A: do i = 1, ninput { k1 = BIAS(inmg[i]) z1[i] = z1[i] - k1 z2[i] = z2[i] - k1 } case CD, AD: do i = 1, ninput { k1 = BIAS(inmg[i]) + DARK(inmg[i]) z1[i] = z1[i] - k1 z2[i] = z2[i] - k1 } case G: do i = 1, ninput { k2 = GAIN(inmg[i]) z1[i] = z1[i] * k2 z2[i] = z2[i] * k2 } case DG: do i = 1, ninput { k1 = DARK(inmg[i]) k2 = GAIN(inmg[i]) z1[i] = (z1[i] - k1) * k2 z2[i] = (z2[i] - k1) * k2 } case CG, AG: do i = 1, ninput { k1 = BIAS(inmg[i]) k2 = GAIN(inmg[i]) z1[i] = (z1[i] - k1) * k2 z2[i] = (z2[i] - k1) * k2 } case CDG, ADG: do i = 1, ninput { k1 = BIAS(inmg[i]) + DARK(inmg[i]) k2 = GAIN(inmg[i]) z1[i] = (z1[i] - k1) * k2 z2[i] = (z2[i] - k1) * k2 } } } else { switch (proc) { case NONE: return case D: do i = 1, ninput { k1 = DARK(inmg[i]) z1[i] = z1[i] + k1 z2[i] = z2[i] + k1 } case C, A: do i = 1, ninput { k1 = BIAS(inmg[i]) z1[i] = z1[i] + k1 z2[i] = z2[i] + k1 } case CD, AD: do i = 1, ninput { k1 = BIAS(inmg[i]) + DARK(inmg[i]) z1[i] = z1[i] + k1 z2[i] = z2[i] + k1 } case G: do i = 1, ninput { k2 = GAIN(inmg[i]) z1[i] = z1[i] / k2 z2[i] = z2[i] / k2 } case DG: do i = 1, ninput { k1 = DARK(inmg[i]) k2 = GAIN(inmg[i]) z1[i] = k1 + (z1[i] / k2) z2[i] = k1 + (z2[i] / k2) } case CG, AG: do i = 1, ninput { k1 = BIAS(inmg[i]) k2 = GAIN(inmg[i]) z1[i] = k1 + (z1[i] / k2) z2[i] = k1 + (z2[i] / k2) } case CDG, ADG: do i = 1, ninput { k1 = BIAS(inmg[i]) + DARK(inmg[i]) k2 = GAIN(inmg[i]) z1[i] = k1 + (z1[i] / k2) z2[i] = k1 + (z2[i] / k2) } } } end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/sigm2.gx��������������������������������������������������0000664�0000000�0000000�00000106306�13321663143�0021103�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# This version differs only in calling the zt_fp instead of xt_fp routines. # The zt_fp routiens are a version that calls the msc routines to get data. # Also there is a bug fix in sigm2_setup which is why there is a version here. include include include include "xtfixpix.h" include "mosgeom.h" # Scaled image descriptor for 2-dim images define SI_LEN 19 define SI_MAXDIM 2 # images of 2 dimensions supported define SI_NBUFS 3 # nbuffers used by SIGL2 define SI_IM Memi[$1] # pointer to input image header define SI_FP Memi[$1+1] # pointer to fixpix structure define SI_GRID Memi[$1+2+$2-1] # pointer to array of X coords define SI_NPIX Memi[$1+4+$2-1] # number of X coords define SI_BAVG Memi[$1+6+$2-1] # X block averaging factor define SI_INTERP Memi[$1+8+$2-1] # interpolate X axis define SI_BUF Memi[$1+10+$2-1]# line buffers define SI_BUFY Memi[$1+13+$2-1]# Y values of buffers define SI_ORDER Memi[$1+15] # interpolator order define SI_TYBUF Memi[$1+16] # buffer type define SI_XOFF Memi[$1+17] # offset in input image to first X define SI_INIT Memi[$1+18] # YES until first i/o is done define OUTBUF SI_BUF($1,3) define SI_TOL (1E-5) # close to a pixel define INTVAL (abs ($1 - nint($1)) < ($2)) define SWAPI {tempi=$2;$2=$1;$1=tempi} define SWAPP {tempp=$2;$2=$1;$1=tempp} define NOTSET (-9999) # SIGM2_SETUP -- Set up the spatial transformation for SIGL2[SR]. Compute # the block averaging factors (1 if no block averaging is required) and # the sampling grid points, i.e., pixel coordinates of the output pixels in # the input image. pointer procedure zigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) pointer im # the input image pointer pm # pixel mask real px1, px2 # range in X to be sampled on an even grid int nx # number of output pixels in X int xblk # blocking factor in x real py1, py2 # range in Y to be sampled on an even grid int ny # number of output pixels in Y int yblk # blocking factor in y int order # interpolator order (0=replicate, 1=linear) int npix, noldpix, nbavpix, i, j int npts[SI_MAXDIM] # number of output points for axis int blksize[SI_MAXDIM] # block averaging factor (npix per block) real tau[SI_MAXDIM] # tau = p(i+1) - p(i) in fractional pixels real p1[SI_MAXDIM] # starting pixel coords in each axis real p2[SI_MAXDIM] # ending pixel coords in each axis real scalar, start pointer si, gp, xt_fpinit() begin iferr (call calloc (si, SI_LEN, TY_STRUCT)) call erract (EA_FATAL) SI_IM(si) = im SI_FP(si) = xt_fpinit (pm, 1, INDEFI) SI_NPIX(si,1) = nx SI_NPIX(si,2) = ny SI_ORDER(si) = order SI_INIT(si) = YES p1[1] = px1 # X = index 1 p2[1] = px2 npts[1] = nx blksize[1] = xblk p1[2] = py1 # Y = index 2 p2[2] = py2 npts[2] = ny blksize[2] = yblk # Compute block averaging factors if not defined. # If there is only one pixel then the block average is the average # between the first and last point. do i = 1, SI_MAXDIM { if ((blksize[i] >= 1) && !IS_INDEFI (blksize[i])) { if (npts[i] == 1) tau[i] = 0. else tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) } else { if (npts[i] == 1) { tau[i] = 0. blksize[i] = int (p2[i] - p1[i] + 1 + SI_TOL) } else { tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) if (tau[i] >= 2.0) { # If nx or ny is not an integral multiple of the block # averaging factor, noldpix is the next larger number # which is an integral multiple. When the image is # block averaged pixels will be replicated as necessary # to fill the last block out to this size. blksize[i] = int (tau[i] + SI_TOL) npix = p2[i] - p1[i] + 1 noldpix = (npix+blksize[i]-1) / blksize[i] * blksize[i] nbavpix = noldpix / blksize[i] scalar = real (nbavpix - 1) / real (noldpix - 1) p1[i] = (p1[i] - 1.0) * scalar + 1.0 p2[i] = (p2[i] - 1.0) * scalar + 1.0 tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) } else blksize[i] = 1 } } } SI_BAVG(si,1) = blksize[1] SI_BAVG(si,2) = blksize[2] # if (IS_INDEFI (xblk)) # xblk = blksize[1] # if (IS_INDEFI (yblk)) # yblk = blksize[2] # Allocate and initialize the grid arrays, specifying the X and Y # coordinates of each pixel in the output image, in units of pixels # in the input (possibly block averaged) image. do i = 1, SI_MAXDIM { # The X coordinate is special. We do not want to read entire # input image lines if only a range of input X values are needed. # Since the X grid vector passed to ALUI (the interpolator) must # contain explicit offsets into the vector being interpolated, # we must generate interpolator grid points starting near 1.0. # The X origin, used to read the block averaged input line, is # given by XOFF. if (i == 1) { SI_XOFF(si) = int (p1[i] + SI_TOL) start = p1[1] - int (p1[i] + SI_TOL) + 1.0 } else start = p1[i] # Do the axes need to be interpolated? if (INTVAL(start,SI_TOL) && (abs (tau[i]-nint(tau[i]))*npts[i] < 1)) SI_INTERP(si,i) = NO else SI_INTERP(si,i) = YES # Allocate grid buffer and set the grid points. iferr (call malloc (gp, npts[i], TY_REAL)) call erract (EA_FATAL) SI_GRID(si,i) = gp if (SI_ORDER(si) <= 0) { do j = 0, npts[i]-1 Memr[gp+j] = int (start + (j * tau[i]) + 0.5 + SI_TOL) } else { do j = 0, npts[i]-1 Memr[gp+j] = start + (j * tau[i]) } } return (si) end # SIGM2S -- Get a line of type short from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure yigm2s (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer si_blmavgs() errchk si_blmavgs begin nraw = IM_LEN(SI_IM(si),1) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_SHORT) SI_TYBUF(si) = TY_SHORT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_SHORT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_samples (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxs (Mems[rawline], nraw, Memr[SI_GRID(si,1)], Mems[SI_BUF(si,i)], npix) } else { call aluis (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxs (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SIGM2I -- Get a line of type int from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure yigm2i (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer si_blmavgi() errchk si_blmavgi begin nraw = IM_LEN(SI_IM(si),1) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (si_blmavgi (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_INT) SI_TYBUF(si) = TY_INT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_INT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = si_blmavgi (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovi (Memi[rawline], Memi[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_samplei (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxi (Memi[rawline], nraw, Memr[SI_GRID(si,1)], Memi[SI_BUF(si,i)], npix) } else { call aluii (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxi (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsui (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVGI -- Get a line from a block averaged image of type integer. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure si_blmavgi (im, fp, x1, x2, y, xbavg, ybavg, order) pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum int blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer xt_fpi() errchk xt_fpi begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "si_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "si_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (xt_fpi (fp, im, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "si_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = xt_fpi (fp, im, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Memi[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax blk1 = blk2 } } else call abavi (Memi[a], Memi[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Memi[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Memi[a+j-1] count = count + 1 } Memi[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Memi[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Memi[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] / real(nlines_in_sum) } } call sfree (sp) return (a) end $for (sir) # SIGM2 -- Get a line of data from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure zigm2$t (mg, si, lineno) pointer mg # pointer to MOSGEOM descriptor pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer zi_blmavg$t() errchk zi_blmavg$t begin nraw = IM_LEN(SI_IM(si)) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (zi_blmavg$t (mg, SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_PIXEL) SI_TYBUF(si) = TY_PIXEL SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_PIXEL) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = zi_blmavg$t (mg, SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amov$t (Mem$t[rawline], Mem$t[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_sample$t (Mem$t[rawline], Mem$t[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_max$t (Mem$t[rawline], nraw, Memr[SI_GRID(si,1)], Mem$t[SI_BUF(si,i)], npix) } else { call alui$t (Mem$t[rawline], Mem$t[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amax$t (Mem$t[SI_BUF(si,1)], Mem$t[SI_BUF(si,2)], Mem$t[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsu$t (Mem$t[SI_BUF(si,1)], Mem$t[SI_BUF(si,2)], Mem$t[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVG -- Get a line from a block averaged image of type short. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure zi_blmavg$t (mg, im, fp, x1, x2, y, xbavg, ybavg, order) pointer mg # mosgeom descriptor pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum PIXEL blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer zt_fp$t() errchk zt_fp$t begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "zi_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "zi_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (zt_fp$t (fp, mg, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "zi_blmavg: block number out of range") $if (datatype == sil) if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } $else if (ybavg > 1) { call salloc (b, nblks_x, TY_PIXEL) call aclr$t (Mem$t[b], nblks_x) nlines_in_sum = 0 } $endif # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = zt_fp$t (fp, mg, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Mem$t[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Mem$t[k]) Mem$t[a+j-1] = blkmax blk1 = blk2 } } else call abav$t (Mem$t[a], Mem$t[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Mem$t[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Mem$t[k]) Mem$t[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Mem$t[a+j-1] count = count + 1 } Mem$t[a+nblks_x-1] = sum / count } } } $if (datatype == sil) # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Mem$t[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Mem$t[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Mem$t[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Mem$t[a+i] = Meml[b+i] / real(nlines_in_sum) } } $else # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) call amaxr (Memr[a], Memr[b], Memr[b], nblks_x) else { call aaddr (Memr[a], Memr[b], Memr[b], nblks_x) nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) call amov$t (Mem$t[b], Mem$t[a], nblks_x) else call adivk$t (Mem$t[b], real(nlines_in_sum), Mem$t[a], nblks_x) } $endif call sfree (sp) return (a) end # SI_MAXS -- Resample a line via maximum value. procedure zi_max$t (a, na, x, b, nb) PIXEL a[na] # input array int na # input size real x[nb] # sample grid PIXEL b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure zt_fp$t (fp, mg, line, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer im, mscl2$t(), zt_fps$t() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2$t (mg, line)) im = MG_IM(mg) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (zt_fps$t (fp, mg, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure zt_fps$t (fp, mg, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] $if (datatype == silr) real a, b, c, d, val $else PIXEL a, b, c, d, val $endif PIXEL indef pointer im, pm, data, bp bool pm_linenotempty() pointer mscl2$t(), zt_fpval$t() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2$t (mg, line)) # Initialize im = MG_IM(mg) pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_PIXEL call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEF call amovk$t (indef, Mem$t[FP_V1(fp,1)], ncols) call amovk$t (indef, Mem$t[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (mscl2$t (mg, line)) else return (zt_fpval$t (fp, mg, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Mem$t[data+c1-1] else a = Mem$t[data+c2-1] if (c2 <= col2) b = (Mem$t[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call parg$t (Mem$t[data+i-1]) $if (datatype == silr) call pargr (val) $else call parg$t (val) $endif if (c1 >= col1) { call fprintf (fd, "%4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, "%4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Mem$t[FP_V1(fp,j)] else c = Mem$t[FP_V2(fp,j)] if (l2 <= line2) { d = (Mem$t[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call parg$t (Mem$t[data+i-1]) $if (datatype == silr) call pargr (val) $else call parg$t (val) $endif if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } $if (datatype == sil) Mem$t[data+i-1] = nint (val) $else Mem$t[data+i-1] = val $endif } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure zt_fpval$t (fp, mg, line) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int i pointer im, data, mscl2$t() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. im = MG_IM(mg) if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mem$t[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Mem$t[FP_V2(fp,i)] = 0. } return (NULL) } data = mscl2$t (mg, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mem$t[FP_V1(fp,i)] = Mem$t[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Mem$t[FP_V2(fp,i)] = Mem$t[data+FP_COL(fp,i)-1] } return (data) end # SI_SAMPLE -- Resample a line via nearest neighbor, rather than linear # interpolation (ALUI). The calling sequence is the same as for ALUII. procedure zi_sample$t (a, b, x, npix) PIXEL a[ARB], b[ARB] # input, output data arrays real x[ARB] # sample grid int npix, i begin do i = 1, npix b[i] = a[int(x[i])] end $endfor ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/sigm2.x���������������������������������������������������0000664�0000000�0000000�00000200225�13321663143�0020727�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# This version differs only in calling the zt_fp instead of xt_fp routines. # The zt_fp routiens are a version that calls the msc routines to get data. # Also there is a bug fix in sigm2_setup which is why there is a version here. include include include include "xtfixpix.h" include "mosgeom.h" # Scaled image descriptor for 2-dim images define SI_LEN 19 define SI_MAXDIM 2 # images of 2 dimensions supported define SI_NBUFS 3 # nbuffers used by SIGL2 define SI_IM Memi[$1] # pointer to input image header define SI_FP Memi[$1+1] # pointer to fixpix structure define SI_GRID Memi[$1+2+$2-1] # pointer to array of X coords define SI_NPIX Memi[$1+4+$2-1] # number of X coords define SI_BAVG Memi[$1+6+$2-1] # X block averaging factor define SI_INTERP Memi[$1+8+$2-1] # interpolate X axis define SI_BUF Memi[$1+10+$2-1]# line buffers define SI_BUFY Memi[$1+13+$2-1]# Y values of buffers define SI_ORDER Memi[$1+15] # interpolator order define SI_TYBUF Memi[$1+16] # buffer type define SI_XOFF Memi[$1+17] # offset in input image to first X define SI_INIT Memi[$1+18] # YES until first i/o is done define OUTBUF SI_BUF($1,3) define SI_TOL (1E-5) # close to a pixel define INTVAL (abs ($1 - nint($1)) < ($2)) define SWAPI {tempi=$2;$2=$1;$1=tempi} define SWAPP {tempp=$2;$2=$1;$1=tempp} define NOTSET (-9999) # SIGM2_SETUP -- Set up the spatial transformation for SIGL2[SR]. Compute # the block averaging factors (1 if no block averaging is required) and # the sampling grid points, i.e., pixel coordinates of the output pixels in # the input image. pointer procedure zigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) pointer im # the input image pointer pm # pixel mask real px1, px2 # range in X to be sampled on an even grid int nx # number of output pixels in X int xblk # blocking factor in x real py1, py2 # range in Y to be sampled on an even grid int ny # number of output pixels in Y int yblk # blocking factor in y int order # interpolator order (0=replicate, 1=linear) int npix, noldpix, nbavpix, i, j int npts[SI_MAXDIM] # number of output points for axis int blksize[SI_MAXDIM] # block averaging factor (npix per block) real tau[SI_MAXDIM] # tau = p(i+1) - p(i) in fractional pixels real p1[SI_MAXDIM] # starting pixel coords in each axis real p2[SI_MAXDIM] # ending pixel coords in each axis real scalar, start pointer si, gp, xt_fpinit() begin iferr (call calloc (si, SI_LEN, TY_STRUCT)) call erract (EA_FATAL) SI_IM(si) = im SI_FP(si) = xt_fpinit (pm, 1, INDEFI) SI_NPIX(si,1) = nx SI_NPIX(si,2) = ny SI_ORDER(si) = order SI_INIT(si) = YES p1[1] = px1 # X = index 1 p2[1] = px2 npts[1] = nx blksize[1] = xblk p1[2] = py1 # Y = index 2 p2[2] = py2 npts[2] = ny blksize[2] = yblk # Compute block averaging factors if not defined. # If there is only one pixel then the block average is the average # between the first and last point. do i = 1, SI_MAXDIM { if ((blksize[i] >= 1) && !IS_INDEFI (blksize[i])) { if (npts[i] == 1) tau[i] = 0. else tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) } else { if (npts[i] == 1) { tau[i] = 0. blksize[i] = int (p2[i] - p1[i] + 1 + SI_TOL) } else { tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) if (tau[i] >= 2.0) { # If nx or ny is not an integral multiple of the block # averaging factor, noldpix is the next larger number # which is an integral multiple. When the image is # block averaged pixels will be replicated as necessary # to fill the last block out to this size. blksize[i] = int (tau[i] + SI_TOL) npix = p2[i] - p1[i] + 1 noldpix = (npix+blksize[i]-1) / blksize[i] * blksize[i] nbavpix = noldpix / blksize[i] scalar = real (nbavpix - 1) / real (noldpix - 1) p1[i] = (p1[i] - 1.0) * scalar + 1.0 p2[i] = (p2[i] - 1.0) * scalar + 1.0 tau[i] = (p2[i] - p1[i]) / (npts[i] - 1) } else blksize[i] = 1 } } } SI_BAVG(si,1) = blksize[1] SI_BAVG(si,2) = blksize[2] # if (IS_INDEFI (xblk)) # xblk = blksize[1] # if (IS_INDEFI (yblk)) # yblk = blksize[2] # Allocate and initialize the grid arrays, specifying the X and Y # coordinates of each pixel in the output image, in units of pixels # in the input (possibly block averaged) image. do i = 1, SI_MAXDIM { # The X coordinate is special. We do not want to read entire # input image lines if only a range of input X values are needed. # Since the X grid vector passed to ALUI (the interpolator) must # contain explicit offsets into the vector being interpolated, # we must generate interpolator grid points starting near 1.0. # The X origin, used to read the block averaged input line, is # given by XOFF. if (i == 1) { SI_XOFF(si) = int (p1[i] + SI_TOL) start = p1[1] - int (p1[i] + SI_TOL) + 1.0 } else start = p1[i] # Do the axes need to be interpolated? if (INTVAL(start,SI_TOL) && (abs (tau[i]-nint(tau[i]))*npts[i] < 1)) SI_INTERP(si,i) = NO else SI_INTERP(si,i) = YES # Allocate grid buffer and set the grid points. iferr (call malloc (gp, npts[i], TY_REAL)) call erract (EA_FATAL) SI_GRID(si,i) = gp if (SI_ORDER(si) <= 0) { do j = 0, npts[i]-1 Memr[gp+j] = int (start + (j * tau[i]) + 0.5 + SI_TOL) } else { do j = 0, npts[i]-1 Memr[gp+j] = start + (j * tau[i]) } } return (si) end # SIGM2S -- Get a line of type short from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure yigm2s (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer si_blmavgs() errchk si_blmavgs begin nraw = IM_LEN(SI_IM(si),1) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_SHORT) SI_TYBUF(si) = TY_SHORT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_SHORT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = si_blmavgs (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_samples (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxs (Mems[rawline], nraw, Memr[SI_GRID(si,1)], Mems[SI_BUF(si,i)], npix) } else { call aluis (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxs (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SIGM2I -- Get a line of type int from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure yigm2i (si, lineno) pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer yi_blmavgi() errchk yi_blmavgi begin nraw = IM_LEN(SI_IM(si),1) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (yi_blmavgi (SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_INT) SI_TYBUF(si) = TY_INT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_INT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = yi_blmavgi (SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovi (Memi[rawline], Memi[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_samplei (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxi (Memi[rawline], nraw, Memr[SI_GRID(si,1)], Memi[SI_BUF(si,i)], npix) } else { call aluii (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxi (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsui (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVGI -- Get a line from a block averaged image of type integer. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure yi_blmavgi (im, fp, x1, x2, y, xbavg, ybavg, order) pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum int blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer xt_fpi() errchk xt_fpi begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "si_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "si_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (xt_fpi (fp, im, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "si_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = xt_fpi (fp, im, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Memi[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax blk1 = blk2 } } else call abavi (Memi[a], Memi[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Memi[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Memi[a+j-1] count = count + 1 } Memi[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Memi[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Memi[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] / real(nlines_in_sum) } } call sfree (sp) return (a) end # SIGM2 -- Get a line of data from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure zigm2s (mg, si, lineno) pointer mg # pointer to MOSGEOM descriptor pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer zi_blmavgs() errchk zi_blmavgs begin nraw = IM_LEN(SI_IM(si)) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (zi_blmavgs (mg, SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_SHORT) SI_TYBUF(si) = TY_SHORT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_SHORT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = zi_blmavgs (mg, SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovs (Mems[rawline], Mems[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_samples (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxs (Mems[rawline], nraw, Memr[SI_GRID(si,1)], Mems[SI_BUF(si,i)], npix) } else { call aluis (Mems[rawline], Mems[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxs (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsus (Mems[SI_BUF(si,1)], Mems[SI_BUF(si,2)], Mems[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVG -- Get a line from a block averaged image of type short. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure zi_blmavgs (mg, im, fp, x1, x2, y, xbavg, ybavg, order) pointer mg # mosgeom descriptor pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum short blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer zt_fps() errchk zt_fps begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "zi_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "zi_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (zt_fps (fp, mg, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "zi_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = zt_fps (fp, mg, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Mems[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Mems[k]) Mems[a+j-1] = blkmax blk1 = blk2 } } else call abavs (Mems[a], Mems[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Mems[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Mems[k]) Mems[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Mems[a+j-1] count = count + 1 } Mems[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Mems[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Mems[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Mems[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Mems[a+i] = Meml[b+i] / real(nlines_in_sum) } } call sfree (sp) return (a) end # SI_MAXS -- Resample a line via maximum value. procedure zi_maxs (a, na, x, b, nb) short a[na] # input array int na # input size real x[nb] # sample grid short b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure zt_fps (fp, mg, line, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer im, mscl2s(), zt_fpss() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2s (mg, line)) im = MG_IM(mg) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (zt_fpss (fp, mg, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure zt_fpss (fp, mg, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val short indef pointer im, pm, data, bp bool pm_linenotempty() pointer mscl2s(), zt_fpvals() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2s (mg, line)) # Initialize im = MG_IM(mg) pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_SHORT call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFS call amovks (indef, Mems[FP_V1(fp,1)], ncols) call amovks (indef, Mems[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (mscl2s (mg, line)) else return (zt_fpvals (fp, mg, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Mems[data+c1-1] else a = Mems[data+c2-1] if (c2 <= col2) b = (Mems[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargs (Mems[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, "%4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, "%4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Mems[FP_V1(fp,j)] else c = Mems[FP_V2(fp,j)] if (l2 <= line2) { d = (Mems[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargs (Mems[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Mems[data+i-1] = nint (val) } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure zt_fpvals (fp, mg, line) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int i pointer im, data, mscl2s() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. im = MG_IM(mg) if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mems[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Mems[FP_V2(fp,i)] = 0. } return (NULL) } data = mscl2s (mg, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Mems[FP_V1(fp,i)] = Mems[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Mems[FP_V2(fp,i)] = Mems[data+FP_COL(fp,i)-1] } return (data) end # SI_SAMPLE -- Resample a line via nearest neighbor, rather than linear # interpolation (ALUI). The calling sequence is the same as for ALUII. procedure zi_samples (a, b, x, npix) short a[ARB], b[ARB] # input, output data arrays real x[ARB] # sample grid int npix, i begin do i = 1, npix b[i] = a[int(x[i])] end # SIGM2 -- Get a line of data from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure zigm2i (mg, si, lineno) pointer mg # pointer to MOSGEOM descriptor pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer zi_blmavgi() errchk zi_blmavgi begin nraw = IM_LEN(SI_IM(si)) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (zi_blmavgi (mg, SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_INT) SI_TYBUF(si) = TY_INT SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_INT) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = zi_blmavgi (mg, SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovi (Memi[rawline], Memi[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_samplei (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxi (Memi[rawline], nraw, Memr[SI_GRID(si,1)], Memi[SI_BUF(si,i)], npix) } else { call aluii (Memi[rawline], Memi[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxi (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsui (Memi[SI_BUF(si,1)], Memi[SI_BUF(si,2)], Memi[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVG -- Get a line from a block averaged image of type short. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure zi_blmavgi (mg, im, fp, x1, x2, y, xbavg, ybavg, order) pointer mg # mosgeom descriptor pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum int blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer zt_fpi() errchk zt_fpi begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "zi_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "zi_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (zt_fpi (fp, mg, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "zi_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_LONG) call aclrl (Meml[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = zt_fpi (fp, mg, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Memi[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax blk1 = blk2 } } else call abavi (Memi[a], Memi[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Memi[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Memi[k]) Memi[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Memi[a+j-1] count = count + 1 } Memi[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) { do j = 0, nblks_x-1 Meml[b+j] = max (Meml[b+j], long (Memi[a+j])) } else { do j = 0, nblks_x-1 Meml[b+j] = Meml[b+j] + Memi[a+j] nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] } else { do i = 0, nblks_x-1 Memi[a+i] = Meml[b+i] / real(nlines_in_sum) } } call sfree (sp) return (a) end # SI_MAXS -- Resample a line via maximum value. procedure zi_maxi (a, na, x, b, nb) int a[na] # input array int na # input size real x[nb] # sample grid int b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure zt_fpi (fp, mg, line, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer im, mscl2i(), zt_fpsi() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2i (mg, line)) im = MG_IM(mg) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (zt_fpsi (fp, mg, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure zt_fpsi (fp, mg, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val int indef pointer im, pm, data, bp bool pm_linenotempty() pointer mscl2i(), zt_fpvali() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2i (mg, line)) # Initialize im = MG_IM(mg) pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_INT call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFI call amovki (indef, Memi[FP_V1(fp,1)], ncols) call amovki (indef, Memi[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (mscl2i (mg, line)) else return (zt_fpvali (fp, mg, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Memi[data+c1-1] else a = Memi[data+c2-1] if (c2 <= col2) b = (Memi[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargi (Memi[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, "%4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, "%4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Memi[FP_V1(fp,j)] else c = Memi[FP_V2(fp,j)] if (l2 <= line2) { d = (Memi[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargi (Memi[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Memi[data+i-1] = nint (val) } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure zt_fpvali (fp, mg, line) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int i pointer im, data, mscl2i() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. im = MG_IM(mg) if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memi[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Memi[FP_V2(fp,i)] = 0. } return (NULL) } data = mscl2i (mg, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memi[FP_V1(fp,i)] = Memi[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Memi[FP_V2(fp,i)] = Memi[data+FP_COL(fp,i)-1] } return (data) end # SI_SAMPLE -- Resample a line via nearest neighbor, rather than linear # interpolation (ALUI). The calling sequence is the same as for ALUII. procedure zi_samplei (a, b, x, npix) int a[ARB], b[ARB] # input, output data arrays real x[ARB] # sample grid int npix, i begin do i = 1, npix b[i] = a[int(x[i])] end # SIGM2 -- Get a line of data from a scaled image. Block averaging is # done by a subprocedure; this procedure gets a line from a possibly block # averaged image and if necessary interpolates it to the grid points of the # output line. pointer procedure zigm2r (mg, si, lineno) pointer mg # pointer to MOSGEOM descriptor pointer si # pointer to SI descriptor int lineno pointer rawline, tempp, gp int i, new_y[2], tempi, curbuf, altbuf int nraw, npix, nblks_y, ybavg, x1, x2 real x, y, weight_1, weight_2 pointer zi_blmavgr() errchk zi_blmavgr begin nraw = IM_LEN(SI_IM(si)) npix = SI_NPIX(si,1) # Determine the range of X (in pixels on the block averaged input image) # required for the interpolator. gp = SI_GRID(si,1) x1 = SI_XOFF(si) x = Memr[gp+npix-1] x2 = x1 + int(x) if (INTVAL(x,SI_TOL)) x2 = x2 - 1 x2 = max (x1 + 1, x2) gp = SI_GRID(si,2) y = Memr[gp+lineno-1] # The following is an optimization provided for the case when it is # not necessary to interpolate in either X or Y. Block averaging is # permitted. if (SI_INTERP(si,1) == NO && SI_INTERP(si,2) == NO) return (zi_blmavgr (mg, SI_IM(si), SI_FP(si), x1, x2, int(y), SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si))) # If we are interpolating in Y two buffers are required, one for each # of the two input image lines required to interpolate in Y. The lines # stored in these buffers are interpolated in X to the output grid but # not in Y. Both buffers are not required if we are not interpolating # in Y, but we use them anyhow to simplify the code. if (SI_INIT(si) == YES) { do i = 1, 2 { if (SI_BUF(si,i) != NULL) call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_REAL) SI_TYBUF(si) = TY_REAL call mfree (SI_BUF(si,i), SI_TYBUF(si)) call malloc (SI_BUF(si,i), npix, TY_REAL) SI_TYBUF(si) = TY_REAL SI_BUFY(si,i) = NOTSET } if (OUTBUF(si) != NULL) call mfree (OUTBUF(si), SI_TYBUF(si)) call malloc (OUTBUF(si), npix, TY_REAL) SI_INIT(si) = NO } # If the Y value of the new line is not in range of the contents of the # current line buffers, refill one or both buffers. To refill we must # read a (possibly block averaged) input line and interpolate it onto # the X grid. The X and Y values herein are in the coordinate system # of the (possibly block averaged) input image. new_y[1] = int(y) new_y[2] = int(y) + 1 # Get the pair of lines whose integral Y values form an interval # containing the fractional Y value of the output line. Sometimes the # desired line will happen to be in the other buffer already, in which # case we just have to swap buffers. Often the new line will be the # current line, in which case nothing is done. This latter case occurs # frequently when the magnification ratio is large. curbuf = 1 altbuf = 2 do i = 1, 2 { if (new_y[i] == SI_BUFY(si,i)) { ; } else if (new_y[i] == SI_BUFY(si,altbuf)) { SWAPP (SI_BUF(si,1), SI_BUF(si,2)) SWAPI (SI_BUFY(si,1), SI_BUFY(si,2)) } else { # Get line and interpolate onto output grid. If interpolation # is not required merely copy data out. This code is set up # to always use two buffers; in effect, there is one buffer of # look ahead, even when Y[i] is integral. This means that we # will go out of bounds by one line at the top of the image. # This is handled by copying the last line. ybavg = SI_BAVG(si,2) nblks_y = (IM_LEN (SI_IM(si), 2) + ybavg-1) / ybavg if (new_y[i] <= nblks_y) rawline = zi_blmavgr (mg, SI_IM(si), SI_FP(si), x1, x2, new_y[i], SI_BAVG(si,1), SI_BAVG(si,2), SI_ORDER(si)) if (SI_INTERP(si,1) == NO) { call amovr (Memr[rawline], Memr[SI_BUF(si,i)], npix) } else if (SI_ORDER(si) == 0) { call zi_sampler (Memr[rawline], Memr[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } else if (SI_ORDER(si) == -1) { call zi_maxr (Memr[rawline], nraw, Memr[SI_GRID(si,1)], Memr[SI_BUF(si,i)], npix) } else { call aluir (Memr[rawline], Memr[SI_BUF(si,i)], Memr[SI_GRID(si,1)], npix) } SI_BUFY(si,i) = new_y[i] } SWAPI (altbuf, curbuf) } # We now have two line buffers straddling the output Y value, # interpolated to the X grid of the output line. To complete the # bilinear interpolation operation we take a weighted sum of the two # lines. If the range from SI_BUFY(si,1) to SI_BUFY(si,2) is repeatedly # interpolated in Y no additional i/o occurs and the linear # interpolation operation (ALUI) does not have to be repeated (only the # weighted sum is required). If the distance of Y from one of the # buffers is zero then we do not even have to take a weighted sum. # This is not unusual because we may be called with a magnification # of 1.0 in Y. weight_1 = 1.0 - (y - SI_BUFY(si,1)) weight_2 = 1.0 - weight_1 if (weight_1 < SI_TOL) return (SI_BUF(si,2)) else if (weight_2 < SI_TOL || SI_ORDER(si) == 0) return (SI_BUF(si,1)) else if (SI_ORDER(si) == -1) { call amaxr (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], Memr[OUTBUF(si)], npix) return (OUTBUF(si)) } else { call awsur (Memr[SI_BUF(si,1)], Memr[SI_BUF(si,2)], Memr[OUTBUF(si)], npix, weight_1, weight_2) return (OUTBUF(si)) } end # SI_BLMAVG -- Get a line from a block averaged image of type short. # For example, block averaging by a factor of 2 means that pixels 1 and 2 # are averaged to produce the first output pixel, 3 and 4 are averaged to # produce the second output pixel, and so on. If the length of an axis # is not an integral multiple of the block size then the last pixel in the # last block will be replicated to fill out the block; the average is still # defined even if a block is not full. pointer procedure zi_blmavgr (mg, im, fp, x1, x2, y, xbavg, ybavg, order) pointer mg # mosgeom descriptor pointer im # input image pointer fp # fixpix structure int x1, x2 # range of x blocks to be read int y # y block to be read int xbavg, ybavg # X and Y block averaging factors int order # averaging option real sum real blkmax pointer sp, a, b int nblks_x, nblks_y, ncols, nlines, xoff, blk1, blk2, i, j, k int first_line, nlines_in_sum, npix, nfull_blks, count pointer zt_fpr() errchk zt_fpr begin call smark (sp) ncols = IM_LEN(im,1) nlines = IM_LEN(im,2) xoff = (x1 - 1) * xbavg + 1 npix = min (ncols, xoff + (x2 - x1 + 1) * xbavg - 1) - xoff + 1 if ((xbavg < 1) || (ybavg < 1)) call error (1, "zi_blmavg: illegal block size") else if (x1 < 1 || x2 > ncols) call error (2, "zi_blmavg: column index out of bounds") else if ((xbavg == 1) && (ybavg == 1)) return (zt_fpr (fp, mg, y, NULL) + xoff - 1) nblks_x = (npix + xbavg-1) / xbavg nblks_y = (nlines + ybavg-1) / ybavg if (y < 1 || y > nblks_y) call error (2, "zi_blmavg: block number out of range") if (ybavg > 1) { call salloc (b, nblks_x, TY_REAL) call aclrr (Memr[b], nblks_x) nlines_in_sum = 0 } # Read and accumulate all input lines in the block. first_line = (y - 1) * ybavg + 1 do i = first_line, min (nlines, first_line + ybavg - 1) { # Get line from input image. a = zt_fpr (fp, mg, i, NULL) + xoff - 1 # Block average line in X. if (xbavg > 1) { # First block average only the full blocks. nfull_blks = npix / xbavg if (order == -1) { blk1 = a do j = 1, nfull_blks { blk2 = blk1 + xbavg blkmax = Memr[blk1] do k = blk1+1, blk2-1 blkmax = max (blkmax, Memr[k]) Memr[a+j-1] = blkmax blk1 = blk2 } } else call abavr (Memr[a], Memr[a], nfull_blks, xbavg) # Now average the final partial block, if any. if (nfull_blks < nblks_x) { if (order == -1) { blkmax = Memr[blk1] do k = blk1+1, a+npix-1 blkmax = max (blkmax, Memr[k]) Memr[a+j-1] = blkmax } else { sum = 0.0 count = 0 do j = nfull_blks * xbavg + 1, npix { sum = sum + Memr[a+j-1] count = count + 1 } Memr[a+nblks_x-1] = sum / count } } } # Add line into block sum. Keep track of number of lines in sum # so that we can compute block average later. if (ybavg > 1) { if (order == -1) call amaxr (Memr[a], Memr[b], Memr[b], nblks_x) else { call aaddr (Memr[a], Memr[b], Memr[b], nblks_x) nlines_in_sum = nlines_in_sum + 1 } } } # Compute the block average in Y from the sum of all lines block # averaged in X. Overwrite buffer A, the buffer returned by IMIO. # This is kosher because the block averaged line is never longer # than an input line. if (ybavg > 1) { if (order == -1) call amovr (Memr[b], Memr[a], nblks_x) else call adivkr (Memr[b], real(nlines_in_sum), Memr[a], nblks_x) } call sfree (sp) return (a) end # SI_MAXS -- Resample a line via maximum value. procedure zi_maxr (a, na, x, b, nb) real a[na] # input array int na # input size real x[nb] # sample grid real b[nb] # output arrays int nb # output size int i begin do i = 1, nb b[i] = max (a[int(x[i])], a[min(na,int(x[i]+1))]) end # XT_FP -- Get the specified line of image data and replace bad pixels by # interpolation. pointer procedure zt_fpr (fp, mg, line, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest pointer im, mscl2r(), zt_fpsr() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2r (mg, line)) im = MG_IM(mg) col1 = 1 col2 = IM_LEN(im,1) line1 = 1 line2 = IM_LEN(im,2) return (zt_fpsr (fp, mg, line, col1, col2, line1, line2, fd)) end # XT_FXS -- Get the specified line of image data and replace bad pixels by # interpolation within a specified section. pointer procedure zt_fpsr (fp, mg, line, col1, col2, line1, line2, fd) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int fd #I File descriptor for pixel list int col1, col2 #I Section of interest int line1, line2 #I Section of interest int i, j, nc, nl, ncols, c1, c2, l1, l2, l3, l4 long v[IM_MAXDIM] real a, b, c, d, val real indef pointer im, pm, data, bp bool pm_linenotempty() pointer mscl2r(), zt_fpvalr() begin # If there are no bad pixels just get the image line and return. if (fp == NULL) return (mscl2r (mg, line)) # Initialize im = MG_IM(mg) pm = FP_PM(fp) nc = IM_LEN(im,1) nl = IM_LEN(im,2) ncols = FP_NCOLS(fp) call amovkl (long(1), v, IM_MAXDIM) v[2] = line # If there might be column interpolation initialize value arrays. if (ncols > 0 && FP_PV1(fp) == NULL) { FP_PIXTYPE(fp) = TY_REAL call malloc (FP_PV1(fp), ncols, FP_PIXTYPE(fp)) call malloc (FP_PV2(fp), ncols, FP_PIXTYPE(fp)) indef = INDEFR call amovkr (indef, Memr[FP_V1(fp,1)], ncols) call amovkr (indef, Memr[FP_V2(fp,1)], ncols) } # If there are no bad pixels in the line and the line contains # no column interpolation endpoints return the data directly. # Otherwise get the line and fill in any endpoints that may # be used later. if (!pm_linenotempty (pm, v)) { if (line < FP_LMIN(fp) || line > FP_LMAX(fp)) return (mscl2r (mg, line)) else return (zt_fpvalr (fp, mg, line)) } # Get the pixel mask. call malloc (bp, nc, TY_SHORT) call pmglps (pm, v, Mems[bp], 0, nc, PIX_SRC) bp = bp - 1 # Check if any column interpolation endpoints are needed and # set them. Set any other endpoints on the same lines at # the same time. if (line >= FP_LMIN(fp) && line < FP_LMAX(fp)) { j = 1 do i = col1, col2 { if (Mems[bp+i] == FP_CVAL(fp)) { for (; j<=ncols && FP_COL(fp,j)!=i; j=j+1) ; for (; j<=ncols && FP_COL(fp,j)==i; j=j+1) { if (line>FP_L1(fp,j) && line col2) { c1 = c2 + 1 next } if (c1 >= col1) a = Memr[data+c1-1] else a = Memr[data+c2-1] if (c2 <= col2) b = (Memr[data+c2-1] - a) / (c2 - c1) else b = 0. } val = a + b * (i - c1) if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargr (Memr[data+i-1]) call pargr (val) if (c1 >= col1) { call fprintf (fd, "%4d %4d") call pargi (c1) call pargi (line) } if (c2 <= col2) { call fprintf (fd, "%4d %4d") call pargi (c2) call pargi (line) } call fprintf (fd, "\n") } } else { for (; j line2) next if (line > l1 && line < l2) { if (l1 >= line1) c = Memr[FP_V1(fp,j)] else c = Memr[FP_V2(fp,j)] if (l2 <= line2) { d = (Memr[FP_V2(fp,j)] - c) / (l2 - l1) val = c + d * (line - l1) } else val = c l3 = l1 l4 = l2 } } if (fd != NULL) { call fprintf (fd, "%4d %4d %8g %8g") call pargi (i) call pargi (line) call pargr (Memr[data+i-1]) call pargr (val) if (l1 >= line1) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l3) } if (l2 <= line2) { call fprintf (fd, "%4d %4d") call pargi (i) call pargi (l4) } call fprintf (fd, "\n") } } Memr[data+i-1] = val } for (c1=c2+1; c1<=col2 && Mems[bp+c1]==0; c1=c1+1) ; } call mfree (bp, TY_SHORT) return (data) end # XT_FPVAL -- Get data for the specified line and set the values for # all column interpolation endpoints which occur at that line. pointer procedure zt_fpvalr (fp, mg, line) pointer fp #I FIXPIX pointer pointer mg #I MOSGEOM pointer int line #I Line int i pointer im, data, mscl2r() begin # Set out of bounds values to 0. These are not used but we need # to cancel the INDEF values. im = MG_IM(mg) if (line < 1 || line > IM_LEN(im,2)) { do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memr[FP_V1(fp,i)] = 0. else if (line == FP_L2(fp,i)) Memr[FP_V2(fp,i)] = 0. } return (NULL) } data = mscl2r (mg, line) do i = 1, FP_NCOLS(fp) { if (line == FP_L1(fp,i)) Memr[FP_V1(fp,i)] = Memr[data+FP_COL(fp,i)-1] else if (line == FP_L2(fp,i)) Memr[FP_V2(fp,i)] = Memr[data+FP_COL(fp,i)-1] } return (data) end # SI_SAMPLE -- Resample a line via nearest neighbor, rather than linear # interpolation (ALUI). The calling sequence is the same as for ALUII. procedure zi_sampler (a, b, x, npix) real a[ARB], b[ARB] # input, output data arrays real x[ARB] # sample grid int npix, i begin do i = 1, npix b[i] = a[int(x[i])] end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0021525�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/mkpkg�������������������������������������������0000664�0000000�0000000�00000000623�13321663143�0022562�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# STARFOCUS. update: $call lsf ; lsf: $checkout libsf.a mscbin$ $update libsf.a $checkin libsf.a mscbin$ ; libsf.a: rngranges.x stfgraph.x starfocus.h stfprofile.x \ starfocus.h t_starfocus.x ../mosgeom.h\ ../mosim.h ../mosproc.h starfocus.h ; �������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/mscfocus.cl�������������������������������������0000664�0000000�0000000�00000003426�13321663143�0023674�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCFOCUS -- Mosaic focus measuring task. # This is customized to the NOAO header keywords. procedure mscfocus (images) string images {prompt="List of Mosaic focus images"} int frame = 1 {prompt="Display frame to use"} real level = 0.5 {prompt="Measurement level (fraction or percent)"} string size = "FWHM" {prompt="Size to display", enum="Radius|FWHM|GFWHM|MFWHM"} real scale = 0.25 {prompt="Pixel scale"} real radius = 10. {prompt="Measurement radius (pixels)"} real sbuffer = 5. {prompt="Sky buffer (pixels)"} real swidth = 5. {prompt="Sky width (pixels)"} real saturation = INDEF {prompt="Saturation level"} bool ignore_sat = no {prompt="Ignore objects with saturated pixels?"} int iterations = 2 {prompt="Number of radius adjustment iterations", min=1} string logfile = "logfile" {prompt="Logfile"} begin string ims, im, gap struct instrum ims = images sections (ims) | scan (im) instrum = "" hselect (im//"[0]", "instrume", yes) | scan (instrum) if (instrum == "Mosaic1.1") gap = "end" else gap = "beginning" #print ("\nMSCFOCUS: Estimate best focus from Mosaic focus images.") #print (" Mark the top star in each sequence unless the display is flipped.") #print (" More precisely mark the star with the largest y value.") print ("Mark the top star (in unflipped display).") set erract = "notrace" iferr { mscstarfocus (ims, focus="FOCSTART", fstep="FOCSTEP", nexposures="FOCNEXPO", step="FOCSHIFT", direction="+line", gap=gap, coords="markall", display=yes, frame=frame, imagecur="", graphcur="", level=level, size=size, beta=INDEF, scale=scale, radius=radius, sbuffer=sbuffer, swidth=swidth, saturation=saturation, ignore_sat=ignore_sat, xcenter=INDEF, ycenter=INDEF, logfile=logfile, iterations=iterations) } print ($errmsg) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/mscstarfocus.par��������������������������������0000664�0000000�0000000�00000002267�13321663143�0024754�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# STARFOCUS -- Determine best star focus. images,s,a,,,,"List of images" mimpars,pset,h,"",,,Mosaic image parameters focus,s,h,"1x1",,,"Focus values" fstep,s,h,"",,,"Focus step " nexposures,s,h,"1",,,"Number of exposures" step,s,h,"30",,,"Step in pixels" direction,s,h,"-line","-line|+line|-column|+column",,"Step direction" gap,s,h,"end","none|beginning|end",,"Double step gap " coords,s,h,"mark1","center|mark1|markall",,"Object coordinates" display,b,h,yes,,,"Display images?" frame,i,h,1,1,,"Display frame to use " level,r,h,0.5,,,"Measurement level (fraction or percent)" size,s,h,"FWHM","Radius|FWHM|GFWHM|MFWHM",,"Size to display" beta,r,h,INDEF,2.1,,Moffat beta parameter scale,r,h,1.,,,"Pixel scale" radius,r,h,5.,,,"Measurement radius (pixels)" sbuffer,r,h,5,,,"Sky buffer (pixels)" swidth,r,h,5.,,,"Sky width (pixels)" saturation,r,h,INDEF,,,"Saturation level" ignore_sat,b,h,no,,,"Ignore objects with saturated pixels?" iterations,i,h,2,1,,"Number of radius adjustment iterations" xcenter,r,h,INDEF,,,X field center (pixels) ycenter,r,h,INDEF,,,Y field center (pixels) logfile,s,h,"logfile",,,"Logfile " imagecur,*imcur,h,"",,,"Image cursor input" graphcur,*gcur,h,"",,,"Graphics cursor input" �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/psfmeasure.par����������������������������������0000664�0000000�0000000�00000001646�13321663143�0024412�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# PSFMEASURE -- Measure PSF. images,s,a,,,,"List of images" mimpars,pset,h,"",,,Mosaic image parameters coords,s,h,"markall","center|mark1|markall",,"Object coordinates" display,b,h,yes,,,"Display images?" frame,i,h,1,1,,"Display frame to use " level,r,h,0.5,,,"Measurement level (fraction or percent)" size,s,h,"FWHM","Radius|FWHM|GFWHM|MFWHM",,"Size to display" beta,r,h,INDEF,2.1,,Moffat beta parameter scale,r,h,1.,,,"Pixel scale" radius,r,h,5.,,,"Measurement radius (pixels)" sbuffer,r,h,5.,,,"Sky buffer (pixels)" swidth,r,h,5.,,,"Sky width (pixels)" saturation,r,h,INDEF,,,"Saturation level" ignore_sat,b,h,no,,,"Ignore objects with saturated pixels?" iterations,i,h,2,1,,"Number of radius adjustment iterations" xcenter,r,h,INDEF,,,X field center (pixels) ycenter,r,h,INDEF,,,X field center (pixels) logfile,s,h,"logfile",,,"Logfile " imagecur,*imcur,h,"",,,"Image cursor input" graphcur,*gcur,h,"",,,"Graphics cursor input" ������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/rngranges.x�������������������������������������0000664�0000000�0000000�00000017445�13321663143�0023717�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc. include include #task test = rng_test # Definitions for the RANGES structure. define LEN_RNG 2 # Length of main structure define RNG_ALLOC 10 # Allocation size define RNG_NPTS Memi[$1] # Number of points in ranges define RNG_NRNGS Memi[$1+1] # Number of range intervals define RNG_X1 Memr[P2R($1+4*($2)-2)] # Start of range define RNG_X2 Memr[P2R($1+4*($2)-1)] # End of range define RNG_DX Memr[P2R($1+4*($2))] # Interval step define RNG_NX Memi[$1+4*($2)+1] # Number of intervals step procedure rng_test () char ranges[SZ_LINE] real r1, r2, dr, clgetr(), rng_nearest() bool rng_inrange() int i, rng_index() pointer rg, rng_open() begin call clgstr ("ranges", ranges, SZ_LINE) r1 = clgetr ("r1") r2 = clgetr ("r2") dr = clgetr ("dr") rg = rng_open (ranges, r1, r2, dr) for (i = 1; rng_index (rg, i, r1) != EOF; i = i + 1) { call printf ("%g\n") call pargr (r1) } repeat { r1 = clgetr ("x") if (IS_INDEFR(r1)) break dr = rng_nearest (rg, r1, i, r2) call printf ("%g: %d %g %g %b\n") call pargr (r1) call pargi (i) call pargr (r2) call pargr (dr) call pargb (rng_inrange (rg, r1)) } call rng_close (rg) end # RNG_OPEN -- Open a range string. Return a pointer to the ranges. pointer procedure rng_open (rstr, r1, r2, dr) char rstr[ARB] # Range string real r1, r2, dr # Default range and range limits pointer rg # Range pointer int i, fd, strlen(), open(), getline() real a, b, c pointer sp, str, ptr errchk open, rng_add begin call smark (sp) call salloc (str, max (strlen (rstr), SZ_LINE), TY_CHAR) call calloc (rg, LEN_RNG, TY_STRUCT) a = r1 b = r2 c = dr if (IS_INDEF(a)) a = 0 if (IS_INDEF(b)) b = MAX_INT - 1 if (IS_INDEF(c)) c = 1 i = 1 while (rstr[i] != EOS) { # Find beginning and end of a range and copy it to the work string while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') i = i + 1 if (rstr[i] == EOS) break ptr = str while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || rstr[i]==EOS)) { Memc[ptr] = rstr[i] i = i + 1 ptr = ptr + 1 } Memc[ptr] = EOS # Add range(s) if (Memc[str] == '@') { fd = open (Memc[str+1], READ_ONLY, TEXT_FILE) while (getline (fd, Memc[str]) != EOF) call rng_add (rg, Memc[str], a, b, c) call close (fd) } else call rng_add (rg, Memc[str], a, b, c) } if (RNG_NRNGS(rg) == 0) call rng_add (rg, "*", a, b, c) call sfree (sp) return (rg) end # RNG_CLOSE -- Close range structure procedure rng_close (rg) pointer rg #I Range descriptor begin call mfree (rg, TY_STRUCT) end # RNG_INDEX -- Get ith range element. Return EOF if index is out of range. int procedure rng_index (rg, ival, rval) pointer rg #I Range descriptor int ival #I Range index real rval #O Range value int i, j begin if (ival < 1 || ival > RNG_NPTS(rg)) return (EOF) j = 1 + RNG_NPTS(rg) do i = RNG_NRNGS(rg), 1, -1 { j = j - RNG_NX(rg,i) if (ival >= j) { rval = RNG_X1(rg,i) + (ival - j) * RNG_DX(rg,i) return (ival) } } end # RNG_NEAREST -- Get nearest range index and value to input value. # Return the difference. real procedure rng_nearest (rg, x, ival, rval) pointer rg #I Range descriptor real x #I Value to be matched int ival #O Index to range values real rval #O Range value int i, j, k real drmin, dx begin ival = 1 rval = RNG_X1(rg,1) drmin = abs (x - rval) k = 1 do i = 1, RNG_NRNGS(rg) { dx = x - RNG_X1(rg,i) j = max (0, min (RNG_NX(rg,i)-1, nint (dx / RNG_DX(rg,i)))) dx = abs (dx + j * RNG_DX(rg,i)) if (dx < drmin) { drmin = dx ival = j + k rval = RNG_X1(rg,i) + j * RNG_DX(rg,i) } k = k + RNG_NX(rg,i) } return (x - rval) end # RNG_INRANGE -- Check if value is within a range bool procedure rng_inrange (rg, x) pointer rg #I Range descriptor real x #I Value to check int i real x1, x2 begin do i = 1, RNG_NRNGS(rg) { x1 = RNG_X1(rg,i) x2 = RNG_X2(rg,i) if (x >= min (x1, x2) && x <= max (x1, x2)) return (true) } return (false) end # RNG_ADD -- Add a range procedure rng_add (rg, rstr, r1, r2, dr) pointer rg # Range descriptor char rstr[ARB] # Range string real r1, r2, dr # Default range and range limits int i, j, nrgs, strlen(), ctor() real x1, x2, dx, nx pointer sp, str, ptr errchk rng_error begin call smark (sp) call salloc (str, strlen (rstr), TY_CHAR) i = 1 while (rstr[i] != EOS) { # Find beginning and end of a range and copy it to the work string while (IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n') i = i + 1 if (rstr[i] == EOS) break # Convert colon syntax to hyphen/x syntax. j=0 ptr = str while (!(IS_WHITE(rstr[i]) || rstr[i]==',' || rstr[i]=='\n' || rstr[i]==EOS)) { if (rstr[i] == ':') { if (j == 0) Memc[ptr] = '-' else if (j == 1) Memc[ptr] = 'x' else call rng_error (1, rstr, r1, r2, dr, rg) j = j + 1 } else Memc[ptr] = rstr[i] i = i + 1 ptr = ptr + 1 } Memc[ptr] = EOS # Parse range if (Memc[str] == '@') call rng_error (2, rstr, r1, r2, dr, rg) else if (Memc[str] == '*') { x1 = r1 x2 = r2 dx = dr j = MAX_INT / 2 if ((x2 - x1) / dx + 1 > j) x2 = x1 + (j - 1) * dx } else { j = 1 if (ctor (Memc[str], j, x1) == 0) call rng_error (3, rstr, r1, r2, dr, rg) if (Memc[str+j-1] == '-') { j = j + 1 if (ctor (Memc[str], j, x2) == 0) call rng_error (3, rstr, r1, r2, dr, rg) if (Memc[str+j-1] == 'x') { j = j + 1 if (ctor (Memc[str], j, dx) == 0) call rng_error (3, rstr, r1, r2, dr, rg) } else dx = dr } else if (Memc[str+j-1] == 'x') { j = j + 1 if (ctor (Memc[str], j, dx) == 0) call rng_error (3, rstr, r1, r2, dr, rg) if (dx < 0) x2 = min (r1, r2) else x2 = max (r1, r2) j = MAX_INT / 2 if ((x2 - x1) / dx + 1 > j) x2 = x1 + (j - 1) * dx } else { x2 = x1 dx = dr } } if (x1 < min (r1, r2) || x1 > max (r1, r2) || x2 < min (r1, r2) || x2 > max (r1, r2)) call rng_error (4, rstr, r1, r2, dr, rg) nrgs = RNG_NRNGS(rg) if (mod (nrgs, RNG_ALLOC) == 0) call realloc (rg, LEN_RNG+4*(nrgs+RNG_ALLOC), TY_STRUCT) nrgs = nrgs + 1 RNG_NRNGS(rg) = nrgs RNG_X1(rg, nrgs) = x1 RNG_X2(rg, nrgs) = x2 RNG_DX(rg, nrgs) = dx j = MAX_INT / 2 nx = (x2 - x1) / dx + 1 if (nx > j) call rng_error (5, rstr, r1, r2, dr, rg) RNG_NX(rg, nrgs) = nx nx = nx + RNG_NPTS(rg) if (nx > j) call rng_error (5, rstr, r1, r2, dr, rg) RNG_NPTS(rg) = nx } call sfree (sp) end # RNG_ERROR -- Set error flag and free memory. # Note that the pointer is freed at this point. procedure rng_error (errnum, rstr, r1, r2, dr, rg) int errnum # Error number char rstr[ARB] # Range string real r1, r2, dr # Default range and range limits pointer rg # Range pointer to be freed. pointer errstr begin call salloc (errstr, SZ_LINE, TY_CHAR) switch (errnum) { case 1: call sprintf (Memc[errstr], SZ_LINE, "Range syntax error: Too many colons (%s)") call pargstr (rstr) case 2: call sprintf (Memc[errstr], SZ_LINE, "Range syntax error: Cannot nest @files (%s)") call pargstr (rstr) case 3: call sprintf (Memc[errstr], SZ_LINE, "Range syntax error: (%s)") call pargstr (rstr) case 4: call sprintf (Memc[errstr], SZ_LINE, "Range syntax error: Range out of bounds %g to %g (%s)") call pargr (min (r1, r2)) call pargr (max (r1, r2)) call pargstr (rstr) case 5: call sprintf (Memc[errstr], SZ_LINE, "Range syntax error: Too many range elements (%s)") call pargstr (rstr) } call rng_close (rg) call error (errnum, Memc[errstr]) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/starfocus.h�������������������������������������0000664�0000000�0000000�00000013202�13321663143�0023705�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# STARFOCUS # Types of coordinates define SF_TYPES "|center|mark1|markall|" define SF_CENTER 1 # Star at center of image define SF_MARK1 2 # Mark stars in first image define SF_MARKALL 3 # Mark stars in all images # Task type define STARFOCUS 1 define PSFMEASURE 2 # Radius types define SF_WTYPES "|Radius|FWHM|GFWHM|MFWHM|" define SF_RMIN 16 # Minimum centering search radius define MAX_FRAMES 8 # Maximum number of display frames # Data structures for STARFOCUS define NBNDRYPIX 100 # Number of boundary pixels define TYBNDRY BT_REFLECT # Type of boundary extension define SAMPLE .2 # Subpixel sampling size define SF_SZFNAME 79 # Length of file names define SF_SZWTYPE 7 # Length of width type string # Main data structure define SF 40 define SF_TASK Memi[$1] # Task type define SF_WTYPE Memc[P2C($1+1)] # Width type string define SF_WCODE Memi[$1+5] # Width code define SF_BETA Memr[P2R($1+6)] # Moffat beta define SF_SCALE Memr[P2R($1+7)] # Pixel scale define SF_LEVEL Memr[P2R($1+8)] # Profile measurement level define SF_RADIUS Memr[P2R($1+9)] # Profile radius define SF_SBUF Memr[P2R($1+10)]# Sky region buffer define SF_SWIDTH Memr[P2R($1+11)]# Sky region width define SF_SAT Memr[P2R($1+12)]# Saturation define SF_NIT Memi[$1+13] # Number of iterations for radius define SF_OVRPLT Memi[$1+14] # Overplot the best profile? define SF_NCOLS Memi[$1+15] # Number of image columns define SF_NLINES Memi[$1+16] # Number of image lines define SF_XF Memr[P2R($1+17)]# X field center define SF_YF Memr[P2R($1+18)]# Y field center define SF_GP Memi[$1+19] # GIO pointer define SF_F Memr[P2R($1+20)]# Best focus define SF_W Memr[P2R($1+21)]# Width at best focus define SF_M Memr[P2R($1+22)]# Brightest star magnitude define SF_XP1 Memr[P2R($1+23)]# First derivative point to plot define SF_XP2 Memr[P2R($1+24)]# Last derivative point to plot define SF_YP1 Memr[P2R($1+25)]# Minimum of derivative profile define SF_YP2 Memr[P2R($1+26)]# Maximum of derivative profile define SF_N Memi[$1+27] # Number of points not deleted define SF_NSFD Memi[$1+28] # Number of data points define SF_SFDS Memi[$1+29] # Pointer to data structures define SF_NS Memi[$1+30] # Number of stars not deleted define SF_NSTARS Memi[$1+31] # Number of stars define SF_STARS Memi[$1+32] # Pointer to star groups define SF_NF Memi[$1+33] # Number of focuses not deleted define SF_NFOCUS Memi[$1+34] # Number of different focus values define SF_FOCUS Memi[$1+35] # Pointer to focus groups define SF_NI Memi[$1+36] # Number of images not deleted define SF_NIMAGES Memi[$1+37] # Number of images define SF_IMAGES Memi[$1+38] # Pointer to image groups define SF_BEST Memi[$1+39] # Pointer to best focus star define SF_SFD Memi[SF_SFDS($1)+$2-1] define SF_SFS Memi[SF_STARS($1)+$2-1] define SF_SFF Memi[SF_FOCUS($1)+$2-1] define SF_SFI Memi[SF_IMAGES($1)+$2-1] # Basic data structure. define SFD 94 define SFD_IMAGE Memc[P2C($1)] # Image name define SFD_DATA Memi[$1+40] # Pointer to real image raster define SFD_RADIUS Memr[P2R($1+41)]# Profile radius define SFD_NP Memi[$1+42] # Number of profile points define SFD_NPMAX Memi[$1+43] # Maximum number of profile points define SFD_X1 Memi[$1+44] # Image raster limits define SFD_X2 Memi[$1+45] define SFD_Y1 Memi[$1+46] define SFD_Y2 Memi[$1+47] define SFD_ID Memi[$1+48] # Star ID define SFD_X Memr[P2R($1+49)]# Star X position define SFD_Y Memr[P2R($1+50)]# Star Y position define SFD_F Memr[P2R($1+51)]# Focus define SFD_W Memr[P2R($1+52)]# Width to use define SFD_M Memr[P2R($1+53)]# Magnitude define SFD_E Memr[P2R($1+54)]# Ellipticity define SFD_PA Memr[P2R($1+55)]# Position angle define SFD_R Memr[P2R($1+56)]# Radius at given level define SFD_DFWHM Memr[P2R($1+57)]# Direct FWHM define SFD_GFWHM Memr[P2R($1+58)]# Gaussian FWHM define SFD_MFWHM Memr[P2R($1+59)]# Moffat FWHM define SFD_ASI1 Memi[$1+60] # Pointer to enclosed flux profile define SFD_ASI2 Memi[$1+61] # Pointer to derivative profile define SFD_YP1 Memr[P2R($1+62)]# Minimum of derivative profile define SFD_YP2 Memr[P2R($1+63)]# Maximum of derivative profile define SFD_FWHM Memr[P2R($1+$2+63)]# FWHM vs level=0.5*i (i=1-19) define SFD_BKGD Memr[P2R($1+83)]# Background value define SFD_BKGD1 Memr[P2R($1+84)]# Original background value define SFD_MISO Memr[P2R($1+85)]# Moment isophote define SFD_SIGMA Memr[P2R($1+86)]# Moffat alpha define SFD_ALPHA Memr[P2R($1+87)]# Moffat alpha define SFD_BETA Memr[P2R($1+88)]# Moffat beta define SFD_STATUS Memi[$1+89] # Status define SFD_NSAT Memi[$1+90] # Number of saturated pixels define SFD_SFS Memi[$1+91] # Pointer to star group define SFD_SFF Memi[$1+92] # Pointer to focus group define SFD_SFI Memi[$1+93] # Pointer to image group # Structure grouping data by star. define SFS ($1+7) define SFS_ID Memi[$1] # Star ID define SFS_F Memr[P2R($1+1)] # Best focus define SFS_W Memr[P2R($1+2)] # Best width define SFS_M Memr[P2R($1+3)] # Average magnitude define SFS_N Memi[$1+4] # Number of points used define SFS_NF Memi[$1+5] # Number of focuses define SFS_NSFD Memi[$1+6] # Number of data points define SFS_SFD Memi[$1+$2+6] # Array of data structures # Structure grouping stars by focus values. define SFF ($1+5) define SFF_F Memr[P2R($1)] # Focus define SFF_W Memr[P2R($1+1)] # Average width define SFF_N Memi[$1+2] # Number in average define SFF_NI Memi[$1+3] # Number of images define SFF_NSFD Memi[$1+4] # Number of data points define SFF_SFD Memi[$1+$2+4] # Array of data structures # Structure grouping stars by image. define SFI ($1+42) define SFI_IMAGE Memc[P2C($1)] # Image define SFI_N Memi[$1+40] # Number in imagE define SFI_NSFD Memi[$1+41] # Number of data points define SFI_SFD Memi[$1+$2+41] # Array of data structures ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/starfocus.key�����������������������������������0000664�0000000�0000000�00000001124�13321663143�0024246�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ COMMAND OPTIONS ? Page this help information. g Measure object and graph the results. m Measure object. q Quit object marking and go to next image. At the end of all images go to analysis of all measurements. :show Show the current results. When an object is measured the center and enclosed flux profile is determined. When using the "mark1" option typing 'q' will measure all remaining images at the same cursor positions while the "markall" option goes to the next image until the image list is finished. If measuring only one object with the 'g' key then a 'q' will exit the program. ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/stfgraph.x��������������������������������������0000664�0000000�0000000�00000212275�13321663143�0023545�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include "starfocus.h" # Interactive help files. There is one for STARFOCUS and one for PSFMEASUE. define STFHELP "starfocus$stfhelp.key" define PSFHELP "starfocus$psfhelp.key" define PROMPT "Options" # View ports for all plots. define VX1 .15 # Minimum X viewport for left graph define VX2 .47 # Maximum X viewport for left graph define VX3 .63 # Minimum X viewport for right graph define VX4 .95 # Maximum X viewport for right graph define VY1 .10 # Minimum Y viewport for bottom graph define VY2 .44 # Minimum Y viewport for bottom graph define VY3 .54 # Minimum Y viewport for top graph define VY4 .88 # Maximum Y viewport for top graph # Miscellaneous graphics parameters. define NMAX 5 # Maximum number of samples for labeling define HLCOLOR 2 # Highlight color define HLWIDTH 4. # Highlight width define GM_MARK GM_CROSS # Point marker define GM_MAG GM_PLUS+GM_CROSS # Magnitude marker # STF_GRAPH -- Interactive graphing of results. procedure stf_graph (sf) pointer sf #I Starfocus structure real wx, wy, x, y, r2, r2min, fa[8] int i, j, ix, iy, nx, ny, wcs, key, pkey, skey, redraw, clgcur() pointer sp, sysidstr, title, cmd, gp, gopen() pointer sfd, sfs, sff, current, nearest data fa/0.,1.,1.,0.,0.,0.,1.,1./ begin call smark (sp) call salloc (sysidstr, SZ_LINE, TY_CHAR) call salloc (title, SZ_LINE, TY_CHAR) call salloc (cmd, SZ_LINE, TY_CHAR) # Set system id label call sysid (Memc[sysidstr], SZ_LINE) # Open graphics and enter interactive graphics loop SF_GP(sf) = gopen ("stdgraph", NEW_FILE, STDGRAPH) gp = SF_GP(sf) wcs = 0 if (SF_NF(sf) > 1) key = 'f' else if (SF_NS(sf) > 1) key = 'a' else key = 'z' pkey = 0 skey = 1 current = SF_BEST(sf) repeat { switch (key) { case 'q': # Quit break case '?': # Help if (SF_TASK(sf) == PSFMEASURE) call gpagefile (gp, PSFHELP, PROMPT) else call gpagefile (gp, STFHELP, PROMPT) next case ':': # Colon commands iferr (call stf_colon (sf, Memc[cmd], redraw)) redraw = NO if (redraw == NO) next case 'a', 'b', 'e', 'f', 'g', 'm', 'p', 't', 'z': # Plots # When there is not enough data for the requested plot # map the key to another one. This is done mostly to # avoid redrawing the same graph when different keys # map to the same pkey. The 'e', 'g', and 'p' key may # select a different object so the check for the same # plot is deferred. if (SF_NS(sf) > 1 && SF_NF(sf) > 1) { ; } else if (SF_NS(sf) > 1) { if (key == 'b') key = 'a' if (key == 'f') key = 'm' } else if (SF_NF(sf) > 1) { if (key == 'a' || key == 'b' || key == 'm' || key == 't') key = 'f' } else { key = 'z' } switch (key) { case 'e', 'g', 'p': ; default: if (key == pkey) next } case 's': # Toggle plotting of magnitude symbols if (pkey != 'a' && pkey != 'b') next skey = mod (skey+1, 2) case 'u': # Undelete all j = 0 do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) if (SFD_STATUS(sfd) != 0) { SFD_STATUS(sfd) = 0 j = j + 1 } } if (j == 0) next call stf_fitfocus (sf) case 'd', 'n', 'o', 'r', 'x', 'i', ' ': # Misc ; default: # Unknown call printf ("\007") next } # Find the nearest or next object if needed. switch (key) { case 'r', 's', 'u', ':': # Redraw last graph pkey = pkey nearest = current case 'n', 'o': # Renormalize enclosed flux profile if (wcs != 7 || pkey == 'p') next pkey = pkey nearest = current if (key == 'n') call stf_norm (sf, nearest, wx, INDEF) else call stf_norm (sf, nearest, wx, wy) call stf_widths (sf, nearest) call stf_fwhms (sf, nearest) call stf_fitfocus (sf) case ' ': # Select next focus or star switch (pkey) { case 'a', 'm', 't': sff = SFD_SFF(current) for (i=1; SF_SFF(sf,i)!=sff; i=i+1) ; j = SF_NFOCUS(sf) i = mod (i, j) + 1 for (; SFF_N(SF_SFF(sf,i))==0; i=mod(i,j)+1) ; if (SF_SFF(sf,i) == sff) next sff = SF_SFF(sf,i) do i = 1, SFF_NSFD(sff) { nearest = SFF_SFD(sff,i) if (SFD_STATUS(nearest) == 0) break } case 'e', 'g', 'p', 'z': switch (wcs) { case 7, 8, 11: for (i=1; SF_SFD(sf,i)!=current; i=i+1) ; j = SF_NSFD(sf) i = mod (i, j) + 1 for (; SFD_STATUS(SF_SFD(sf,i))!=0; i=mod(i,j)+1) ; nearest = SF_SFD(sf,i) case 9: sfs = SFD_SFS(current) for (i=1; SFS_SFD(sfs,i)!=current; i=i+1) ; j = SFS_NSFD(sfs) i = mod (i, j) + 1 for (; SFD_STATUS(SFS_SFD(sfs,i))!=0; i=mod(i,j)+1) ; nearest = SFS_SFD(sfs,i) if (nearest == current) next case 10: sff = SFD_SFF(current) for (i=1; SFF_SFD(sff,i)!=current; i=i+1) ; j = SFF_NSFD(sff) i = mod (i, j) + 1 for (; SFD_STATUS(SFF_SFD(sff,i))!=0; i=mod(i,j)+1) ; nearest = SFF_SFD(sff,i) if (nearest == current) next } default: next } default: # Select nearest to cursor switch (pkey) { case 'a': r2min = MAX_REAL call gctran (gp, wx, wy, wx, wy, wcs, 0) sff = SFD_SFF(current) do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next switch (wcs) { case 1: x = SFD_X(sfd) y = SFD_Y(sfd) case 2: x = SFD_X(sfd) y = SFD_W(sfd) case 3: x = SFD_W(sfd) y = SFD_Y(sfd) case 4: x = SFD_X(sfd) y = SFD_E(sfd) case 5: x = SFD_E(sfd) y = SFD_Y(sfd) } call gctran (gp, x, y, x, y, wcs, 0) r2 = (x-wx)**2 + (y-wy)**2 if (r2 < r2min) { r2min = r2 nearest = sfd } } case 'b': r2min = MAX_REAL call gctran (gp, wx, wy, wx, wy, wcs, 0) do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next switch (wcs) { case 1: x = SFD_X(SFS_SFD(sfs,1)) y = SFD_Y(SFS_SFD(sfs,1)) case 2: x = SFD_X(SFS_SFD(sfs,1)) y = SFS_W(sfs) case 3: x = SFS_W(sfs) y = SFD_Y(SFS_SFD(sfs,1)) case 4: x = SFD_X(SFS_SFD(sfs,1)) y = SFS_F(sfs) case 5: x = SFS_F(sfs) y = SFD_Y(SFS_SFD(sfs,1)) } call gctran (gp, x, y, x, y, wcs, 0) r2 = (x-wx)**2 + (y-wy)**2 if (r2 < r2min) { r2min = r2 nearest = sfs } } sfs = nearest r2min = MAX_REAL do i = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs,i) if (SFD_STATUS(sfd) != 0) next r2 = SFD_W(sfd) if (r2 < r2min) { r2min = r2 nearest = sfd } } case 'e', 'g', 'p': switch (wcs) { case 9: sfs = SFD_SFS(current) i = SFS_N(sfs) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } ix = max (1, min (nx, nint(wx))) iy = max (1, min (ny, nint(wy))) j = 0 do i = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs, i) if (SFD_STATUS(sfd) != 0) next if (ix == 1 + mod (j, nx) && iy == 1 + j / nx) { nearest = sfd break } j = j + 1 } case 10: sff = SFD_SFF(current) i = SFF_N(sff) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } ix = max (1, min (nx, nint(wx))) iy = max (1, min (ny, nint(wy))) j = 0 do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff, i) if (SFD_STATUS(sfd) != 0) next if (ix == 1 + mod (j, nx) && iy == 1 + j / nx) { nearest = sfd break } j = j + 1 } } if (key == pkey && nearest == current) next default: switch (wcs) { case 1, 2: r2min = MAX_REAL call gctran (gp, wx, wy, wx, wy, wcs, 0) do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) if (SFD_STATUS(sfd) != 0) next switch (wcs) { case 1: x = SFD_F(sfd) y = SFD_W(sfd) case 2: x = SFD_F(sfd) y = SFD_E(sfd) } call gctran (gp, x, y, x, y, wcs, 0) r2 = (x-wx)**2 + (y-wy)**2 if (r2 < r2min) { r2min = r2 nearest = sfd } } case 3, 4, 5, 6: r2min = MAX_REAL call gctran (gp, wx, wy, wx, wy, wcs, 0) sff = SFD_SFF(current) do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next switch (wcs) { case 3: x = -2.5 * log10 (SFS_M(SFD_SFS(sfd))/SF_M(sf)) y = SFD_W(sfd) case 4: x = -2.5 * log10 (SFS_M(SFD_SFS(sfd))/SF_M(sf)) y = SFD_E(sfd) case 5: x = sqrt ((SFD_X(sfd) - SF_XF(sf)) ** 2 + (SFD_Y(sfd) - SF_YF(sf)) ** 2) y = SFD_W(sfd) case 6: x = sqrt ((SFD_X(sfd) - SF_XF(sf)) ** 2 + (SFD_Y(sfd) - SF_YF(sf)) ** 2) y = SFD_E(sfd) } call gctran (gp, x, y, x, y, wcs, 0) r2 = (x-wx)**2 + (y-wy)**2 if (r2 < r2min) { r2min = r2 nearest = sfd } } default: nearest = current } } # Act on selection for delete or info. switch (key) { case 'd': if (SF_NS(sf) > 1) { sfs = SFD_SFS(nearest) do i = 1, SFS_NSFD(sfs) SFD_STATUS(SFS_SFD(sfs,i)) = 1 } else SFD_STATUS(nearest) = 1 call stf_fitfocus (sf) case 'x': repeat { switch (key) { case 'f': sff = SFD_SFF(nearest) do i = 1, SFF_NSFD(sff) SFD_STATUS(SFF_SFD(sff,i)) = 1 case 'i': sfd = SFD_SFI(nearest) do i = 1, SFI_NSFD(sfd) SFD_STATUS(SFI_SFD(sfd,i)) = 1 case 'p': SFD_STATUS(nearest) = 1 case 's': sfs = SFD_SFS(nearest) do i = 1, SFS_NSFD(sfs) SFD_STATUS(SFS_SFD(sfs,i)) = 1 default: call printf ( "Delete image, star, focus, or point? (i|s|f|p)") next } call stf_fitfocus (sf) break } until (clgcur ("graphcur", wx, wy, wcs, key, Memc[cmd], SZ_LINE) == EOF) case 'i': switch (pkey) { case 'b': sfs = SFD_SFS(nearest) call stf_title (sf, NULL, sfs, NULL, Memc[title], SZ_LINE) default: call stf_title (sf, nearest, NULL, NULL, Memc[title], SZ_LINE) } call printf ("%s\n") call pargstr (Memc[title]) next default: pkey = key } } # If current object has been deleted select another. if (SFD_STATUS(nearest) == 0) current = nearest else current = SF_BEST(sf) # Make the graphs. The graph depends on the number of stars # and number of focus values. Note that the pkey has already # been mapped but all the keys are shown for clarity. call gclear (gp) call gseti (gp, G_FACOLOR, 0) if (SF_NS(sf) > 1 && SF_NF(sf) > 1) { switch (pkey) { case 'a': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 1) call gsview (gp, VX1, VX4, VY1, VY4) call stf_g11 (sf, current, skey, Memc[title]) case 'b': call sprintf (Memc[title], SZ_LINE, "Best focus estimates for each star") call gseti (gp, G_WCS, 1) call gsview (gp, VX1, VX4, VY1, VY4) call stf_g12 (sf, current, skey, Memc[title]) case 'e': sfs = SFD_SFS(current) call sprintf (Memc[title], SZ_LINE, "Star: x=%.2f, y=%.2f, m=%.2f") call pargr (SFD_X(current)) call pargr (SFD_Y(current)) call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) call gseti (gp, G_WCS, 9) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g2 (sf, current, Memc[title]) sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 10) call gsview (gp, VX1, VX4, VY1, VY2) call stf_g3 (sf, current, Memc[title]) case 'f': call gseti (gp, G_WCS, 1) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g1 (sf, current, 'f', 'r', "", "", SF_WTYPE(sf)) call gseti (gp, G_WCS, 2) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g1 (sf, current, 'f', 'e', "", "Focus", "Ellipticity") case 'g': sfs = SFD_SFS(current) call sprintf (Memc[title], SZ_LINE, "Star: x=%.2f, y=%.2f, m=%.2f") call pargr (SFD_X(current)) call pargr (SFD_Y(current)) call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) call gseti (gp, G_WCS, 9) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g9 (sf, current, Memc[title]) sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 10) call gsview (gp, VX1, VX4, VY1, VY2) call stf_g10 (sf, current, Memc[title]) case 'm': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 3) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g1 (sf, current, 'm', 'r', Memc[title], "", SF_WTYPE(sf)) call gseti (gp, G_WCS, 4) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g1 (sf, current, 'm', 'e', "", "Magnitude", "Ellipticity") case 'p': sfs = SFD_SFS(current) call sprintf (Memc[title], SZ_LINE, "Star: x=%.2f, y=%.2f, m=%.2f") call pargr (SFD_X(current)) call pargr (SFD_Y(current)) call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) call gseti (gp, G_WCS, 9) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g4 (sf, current, Memc[title]) sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 10) call gsview (gp, VX1, VX4, VY1, VY2) call stf_g5 (sf, current, Memc[title]) case 't': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 5) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g1 (sf, current, 't', 'r', Memc[title], "", SF_WTYPE(sf)) call gseti (gp, G_WCS, 6) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g1 (sf, current, 't', 'e', "", "Field radius", "Ellipticity") case 'z': call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX2, VY3, VY4) call stf_g6 (sf, current, "", "", "Enclosed flux") call gseti (gp, G_WCS, 8) call gsview (gp, VX1, VX2, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g7 (sf, current, "", "Radius", "Profile") call gseti (gp, G_WCS, 11) call gsview (gp, VX3, VX4, VY3, VY4) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g8 (sf, current, "", "Enclosed flux", "FWHM") call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 0) call gsetr (gp, G_PLWIDTH, 2.0) call gline (gp, 0., 0., 0., 0.) call gtext (gp, 0.5, 0.93, Memc[title], "h=c,v=t") } } else if (SF_NS(sf) > 1) { switch (pkey) { case 'a', 'b': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 1) call gsview (gp, VX1, VX4, VY1, VY4) call stf_g11 (sf, current, skey, Memc[title]) case 'e': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 10) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g3 (sf, current, Memc[title]) call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g6 (sf, current, Memc[title], "Radius", "Enclosed flux") case 'f', 'm': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 3) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g1 (sf, current, 'm', 'r', Memc[title], "", SF_WTYPE(sf)) call gseti (gp, G_WCS, 4) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g1 (sf, current, 'm', 'e', "", "Magnitude", "Ellipticity") case 'g': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 10) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g10 (sf, current, Memc[title]) call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 11) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g8 (sf, current, Memc[title], "Enclosed flux", "FWHM") case 'p': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 10) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g5 (sf, current, Memc[title]) call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g7 (sf, current, Memc[title], "Radius", "Profile") case 't': sff = SFD_SFF(current) call stf_title (sf, NULL, NULL, sff, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 5) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g1 (sf, current, 't', 'r', Memc[title], "", SF_WTYPE(sf)) call gseti (gp, G_WCS, 6) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g1 (sf, current, 't', 'e', "", "Field radius", "Ellipticity") case 'z': call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX2, VY3, VY4) call stf_g6 (sf, current, "", "", "Enclosed flux") call gseti (gp, G_WCS, 8) call gsview (gp, VX1, VX2, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g7 (sf, current, "", "Radius", "Profile") call gseti (gp, G_WCS, 11) call gsview (gp, VX3, VX4, VY3, VY4) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g8 (sf, current, "", "Enclosed flux", "FWHM") call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 0) call gsetr (gp, G_PLWIDTH, 2.0) call gline (gp, 0., 0., 0., 0.) call gtext (gp, 0.5, 0.93, Memc[title], "h=c,v=t") } } else if (SF_NF(sf) > 1) { switch (pkey) { case 'a', 'b', 'f', 'm', 't': call gseti (gp, G_WCS, 1) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g1 (sf, current, 'f', 'r', "", "", SF_WTYPE(sf)) call gseti (gp, G_WCS, 2) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g1 (sf, current, 'f', 'e', "", "Focus", "Ellipticity") case 'e': sfs = SFD_SFS(current) call sprintf (Memc[title], SZ_LINE, "Star: x=%.2f, y=%.2f, m=%.2f") call pargr (SFD_X(current)) call pargr (SFD_Y(current)) call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) call gseti (gp, G_WCS, 9) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g2 (sf, current, Memc[title]) call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g6 (sf, current, Memc[title], "Radius", "Enclosed flux") case 'g': sfs = SFD_SFS(current) call sprintf (Memc[title], SZ_LINE, "Star: x=%.2f, y=%.2f, m=%.2f") call pargr (SFD_X(current)) call pargr (SFD_Y(current)) call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) call gseti (gp, G_WCS, 9) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g9 (sf, current, Memc[title]) call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 11) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g8 (sf, current, Memc[title], "Enclosed flux", "FWHM") case 'p': sfs = SFD_SFS(current) call sprintf (Memc[title], SZ_LINE, "Star: x=%.2f, y=%.2f, m=%.2f") call pargr (SFD_X(current)) call pargr (SFD_Y(current)) call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) call gseti (gp, G_WCS, 9) call gsview (gp, VX1, VX4, VY3, VY4) call stf_g4 (sf, current, Memc[title]) call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX4, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g7 (sf, current, Memc[title], "Radius", "profile") case 'z': call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX2, VY3, VY4) call stf_g6 (sf, current, "", "", "Enclosed flux") call gseti (gp, G_WCS, 8) call gsview (gp, VX1, VX2, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g7 (sf, current, "", "Radius", "Profile") call gseti (gp, G_WCS, 11) call gsview (gp, VX3, VX4, VY3, VY4) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g8 (sf, current, "", "Enclosed flux", "FWHM") call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 0) call gsetr (gp, G_PLWIDTH, 2.0) call gline (gp, 0., 0., 0., 0.) call gtext (gp, 0.5, 0.93, Memc[title], "h=c,v=t") } } else { switch (pkey) { case 'a', 'b', 'f', 'm', 'p', 'z', 'e', 't': call gseti (gp, G_WCS, 7) call gsview (gp, VX1, VX2, VY3, VY4) call stf_g6 (sf, current, "", "", "Enclosed flux") call gseti (gp, G_WCS, 8) call gsview (gp, VX1, VX2, VY1, VY2) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g7 (sf, current, "", "Radius", "Profile") call gseti (gp, G_WCS, 11) call gsview (gp, VX3, VX4, VY3, VY4) call gfill (gp, fa, fa[5], 4, GF_SOLID) call stf_g8 (sf, current, "", "Enclosed flux", "FWHM") call stf_title (sf, current, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 0) call gsetr (gp, G_PLWIDTH, 2.0) call gline (gp, 0., 0., 0., 0.) call gtext (gp, 0.5, 0.93, Memc[title], "h=c,v=t") } } # Add banner title. call stf_title (sf, NULL, NULL, NULL, Memc[title], SZ_LINE) call gseti (gp, G_WCS, 0) call gsetr (gp, G_PLWIDTH, 2.0) call gline (gp, 0., 0., 0., 0.) call gtext (gp, 0.5, 0.99, Memc[sysidstr], "h=c,v=t") call gtext (gp, 0.5, 0.96, Memc[title], "h=c,v=t") if (SF_NSFD(sf) == 1) break } until (clgcur ("graphcur", wx, wy, wcs, key, Memc[cmd], SZ_LINE)==EOF) call gclose (gp) call sfree (sp) end # List of colon commands. define CMDS "|show|level|size|scale|radius|xcenter|ycenter\ |overplot|beta|" define SHOW 1 # Show current results define LEVEL 2 # Measurement level define SIZE 3 # Size type define SCALE 4 # Pixel scale define RADIUS 5 # Maximum radius define XCENTER 6 # X field center define YCENTER 7 # Y field center define OVERPLOT 8 # Overplot best profile define BETA 9 # Beta value for Moffat function # STF_COLON -- Respond to colon command. procedure stf_colon (sf, cmd, redraw) pointer sf #I Starfocus pointer char cmd[ARB] #I Colon command int redraw #O Redraw? bool bval real rval, stf_r2i() int i, j, ncmd, nscan(), strdic(), open(), btoi() pointer sp, str, sfd errchk open, delete, stf_log, stf_norm, stf_radius, stf_fitfocus begin call smark (sp) call salloc (str, SZ_FNAME, TY_CHAR) # Scan the command string and get the first word. call sscan (cmd) call gargwrd (Memc[str], SZ_FNAME) ncmd = strdic (Memc[str], Memc[str], SZ_FNAME, CMDS) switch (ncmd) { case SHOW: call gargwrd (Memc[str], SZ_FNAME) iferr { if (nscan() == 1) { call mktemp ("tmp$iraf", Memc[str], SZ_FNAME) i = open (Memc[str], APPEND, TEXT_FILE) call stf_log (sf, i) call close (i) call gpagefile (SF_GP(sf), Memc[str], "starfocus") call delete (Memc[str]) } else { i = open (Memc[str], APPEND, TEXT_FILE) call stf_log (sf, i) call close (i) } } then call erract (EA_WARN) redraw = NO case LEVEL: call gargr (rval) if (nscan() == 2) { if (rval > 1.) rval = rval / 100. SF_LEVEL(sf) = max (0.05, min (0.95, rval)) do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) call stf_radius (sf, sfd, SF_LEVEL(sf), SFD_R(sfd)) } if (SF_WCODE(sf) == 1) call stf_fitfocus (sf) redraw = YES } else { call printf ("level %g\n") call pargr (SF_LEVEL(sf)) redraw = NO } case SIZE: call gargwrd (Memc[str], SZ_FNAME) if (nscan() == 2) { ncmd = strdic (Memc[str], Memc[str], SZ_FNAME, SF_WTYPES) if (ncmd == 0) { call eprintf ("Invalid size type\n") redraw = NO } else { call strcpy (Memc[str], SF_WTYPE(sf), SF_SZWTYPE) SF_WCODE(sf) = ncmd do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) switch (SF_WCODE(sf)) { case 1: SFD_W(sfd) = SFD_R(sfd) case 2: SFD_W(sfd) = SFD_DFWHM(sfd) case 3: SFD_W(sfd) = SFD_GFWHM(sfd) case 4: SFD_W(sfd) = SFD_MFWHM(sfd) } call stf_fwhms (sf, sfd) } call stf_fitfocus (sf) redraw = YES } } else { call printf ("size %s\n") call pargstr (SF_WTYPE(sf)) redraw = NO } case SCALE: call gargr (rval) if (nscan() == 2) { rval = rval / SF_SCALE(sf) SF_SCALE(sf) = SF_SCALE(sf) * rval do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) switch (SF_WCODE(sf)) { case 1: SFD_R(sfd) = SFD_R(sfd) * rval SFD_W(sfd) = SFD_R(sfd) case 2: SFD_DFWHM(sfd) = SFD_DFWHM(sfd) * rval SFD_W(sfd) = SFD_DFWHM(sfd) case 3: SFD_SIGMA(sfd) = SFD_SIGMA(sfd) * rval SFD_GFWHM(sfd) = SFD_GFWHM(sfd) * rval SFD_W(sfd) = SFD_GFWHM(sfd) case 4: SFD_ALPHA(sfd) = SFD_ALPHA(sfd) * rval SFD_MFWHM(sfd) = SFD_MFWHM(sfd) * rval SFD_W(sfd) = SFD_MFWHM(sfd) } do j = 1, 19 SFD_FWHM(sfd,j) = SFD_FWHM(sfd,j) * rval } do i = 1, SF_NSTARS(sf) { sfd = SF_SFS(sf,i) SFS_W(sfd) = SFS_W(sfd) * rval } do i = 1, SF_NFOCUS(sf) { sfd = SF_SFF(sf,i) SFF_W(sfd) = SFF_W(sfd) * rval } SF_W(sf) = SF_W(sf) * rval redraw = YES } else { call printf ("scale %g\n") call pargr (SF_SCALE(sf)) redraw = NO } case RADIUS: call gargr (rval) if (nscan() == 2) { j = stf_r2i (rval) + 1 SF_RADIUS(sf) = rval do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) if (j > SFD_NPMAX(sfd)) next SFD_NP(sfd) = j SFD_RADIUS(sf) = SF_RADIUS(sf) call stf_norm (sf, sfd, INDEF, INDEF) call stf_widths (sf, sfd) call stf_fwhms (sf, sfd) } call stf_fitfocus (sf) redraw = YES } else { call printf ("radius %g\n") call pargr (SF_RADIUS(sf)) redraw = NO } case XCENTER: call gargr (rval) if (nscan() == 2) { if (IS_INDEF(rval)) SF_XF(sf) = (SF_NCOLS(sf) + 1) / 2. else SF_XF(sf) = rval redraw = NO } else { call printf ("xcenter %g\n") call pargr (SF_XF(sf)) redraw = NO } case YCENTER: call gargr (rval) if (nscan() == 2) { if (IS_INDEF(rval)) SF_YF(sf) = (SF_NLINES(sf) + 1) / 2. else SF_YF(sf) = rval redraw = NO } else { call printf ("ycenter %g\n") call pargr (SF_YF(sf)) redraw = NO } case OVERPLOT: call gargb (bval) if (nscan() == 2) { SF_OVRPLT(sf) = btoi (bval) redraw = YES } else { call printf ("overplot %b\n") call pargi (SF_OVRPLT(sf)) redraw = NO } case BETA: call gargr (rval) if (nscan() == 2) { SF_BETA(sf) = rval do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) call stf_widths (sf, sfd) switch (SF_WCODE(sf)) { case 1: SFD_W(sfd) = SFD_R(sfd) case 2: SFD_W(sfd) = SFD_DFWHM(sfd) case 3: SFD_W(sfd) = SFD_GFWHM(sfd) case 4: SFD_W(sfd) = SFD_MFWHM(sfd) } call stf_fwhms (sf, sfd) } call stf_fitfocus (sf) redraw = YES } else { call printf ("beta %g\n") call pargr (SF_BETA(sf)) redraw = NO } default: call printf ("Unrecognized or ambiguous command\007") redraw = NO } call sfree (sp) end # STF_G1 -- Plot of size/ellip vs. focus/mag/radius. procedure stf_g1 (sf, current, xkey, ykey, title, xlabel, ylabel) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer int xkey #I X axis key int ykey #I Y axis key char title[ARB] #I Title char xlabel[ARB] #I X label char ylabel[ARB] #I Y label int i, j bool hl real x, x1, x2, dx, y, y1, y2, dy pointer gp, sff, sfd begin # Determine data range x1 = MAX_REAL x2 = -MAX_REAL switch (ykey) { case 'r': y1 = SF_W(sf) y2 = 1.5 * SF_W(sf) case 'e': y1 = 0 y2 = 1 } do j = 1, SF_NFOCUS(sf) { sff = SF_SFF(sf,j) if (xkey != 'f' && sff != SFD_SFF(current)) next do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) == 0) { switch (xkey) { case 'f': x = SFD_F(sfd) case 'm': x = -2.5 * log10 (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) case 't': x = sqrt ((SFD_X(sfd) - SF_XF(sf)) ** 2 + (SFD_Y(sfd) - SF_YF(sf)) ** 2) } switch (ykey) { case 'r': y = SFD_W(sfd) case 'e': y = SFD_E(sfd) } x1 = min (x1, x) x2 = max (x2, x) y1 = min (y1, y) y2 = max (y2, y) } } } dx = (x2 - x1) dy = (y2 - y1) x1 = x1 - dx * 0.05 x2 = x2 + dx * 0.05 y1 = y1 - dy * 0.05 y2 = y2 + dy * 0.05 gp = SF_GP (sf) call gswind (gp, x1, x2, y1, y2) call glabax (gp, title, xlabel, ylabel) do j = 1, SF_NFOCUS(sf) { sff = SF_SFF(sf,j) if (xkey != 'f' && sff != SFD_SFF(current)) next do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) == 0) { hl = false switch (xkey) { case 'f': x = SFD_F(sfd) #hl = (SFD_SFS(sfd) == SFD_SFS(current)) case 'm': x = -2.5 * log10 (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) #hl = (SFD_SFF(sfd) != SFD_SFF(current)) case 't': x = sqrt ((SFD_X(sfd) - SF_XF(sf)) ** 2 + (SFD_Y(sfd) - SF_YF(sf)) ** 2) #hl = (SFD_SFF(sfd) != SFD_SFF(current)) } switch (ykey) { case 'r': y = SFD_W(sfd) case 'e': y = SFD_E(sfd) } if (hl) { call gseti (gp, G_PLCOLOR, HLCOLOR) if (sfd == current) call gmark (gp, x, y, GM_BOX, 3., 3.) call gmark (gp, x, y, GM_PLUS, 3., 3.) call gseti (gp, G_PLCOLOR, 1) } else call gmark (gp, x, y, GM_MARK, 2., 2.) } } } call gseti (gp, G_PLTYPE, 2) if (xkey == 'f') call gline (gp, SF_F(sf), y1, SF_F(sf), y2) if (ykey == 'r') call gline (gp, x1, SF_W(sf), x2, SF_W(sf)) call gseti (gp, G_PLTYPE, 1) end # STF_G2 -- Enclosed flux profiles for a given star. procedure stf_g2 (sf, current, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer char title[ARB] #I Title int i, j, np, np1, nx, ny, ix, iy real vx, dvx, vy, dvy, x1, x2, y1, y2, z, z1, r, r1, r2, dr, fa[10] pointer sp, str, gp, sfs, sfd, asi real stf_i2r(), stf_r2i(), asieval() begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) gp = SF_GP(sf) sfs = SFD_SFS(current) np = SFD_NP(current) # Set grid layout i = SFS_N(sfs) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } # Set subview port parameters call ggview (gp, vx, dvx, vy, dvy) dvx = (dvx - vx) / nx dvy = (dvy - vy) / ny # Set data window parameters x1 = -0.05 x2 = 1.05 y1 = -0.15 y2 = 1.05 call gswind (gp, x1, x2, y1, y2) # Set fill area fa[1] = x1; fa[6] = y1 fa[2] = x2; fa[7] = y1 fa[3] = x2; fa[8] = y2 fa[4] = x1; fa[9] = y2 fa[5] = x1; fa[10] = y1 # Draw profiles. j = 0 do i = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs, i) if (SFD_STATUS(sfd) != 0) next np1 = SFD_NP(sfd) ix = 1 + mod (j, nx) iy = 1 + j / nx j = j + 1 call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) call gfill (gp, fa, fa[6], 4, GF_SOLID) call gseti (gp, G_DRAWTICKS, NO) call glabax (gp, "", "", "") if (sfd == current) { call gsview (gp, vx+dvx*(ix-1)+.005, vx+dvx*ix-.005, vy+dvy*(ny-iy)+.005, vy+(ny-iy+1)*dvy-.005) call gsetr (gp, G_PLWIDTH, HLWIDTH) call gseti (gp, G_PLCOLOR, HLCOLOR) call gpline (gp, fa, fa[6], 5) call gsetr (gp, G_PLWIDTH, 1.) call gseti (gp, G_PLCOLOR, 1) call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) } asi = SFD_ASI1(sfd) r2 = stf_i2r (real(np)) call gamove (gp, 0., 0.) for (z = 1.; z <= np1; z = z + 0.1) call gadraw (gp, stf_i2r(z)/r2, asieval(asi,z)) if (SF_OVRPLT(sf) == YES && sfd != SF_BEST(sf)) { call gseti (gp, G_PLCOLOR, HLCOLOR) np1 = SFD_NP(SF_BEST(sf)) asi = SFD_ASI1(SF_BEST(sf)) r1 = stf_i2r (1.) r2 = stf_i2r (real(np)) dr = 0.05 * (r2 - r1) for (r = r1; r <= r2; r = r + dr) { z = stf_r2i (r) z1 = stf_r2i (r+0.7*dr) if (z > 1. && z1 <= np1) call gline (gp, r/r2, asieval(asi,z), (r+0.7*dr)/r2, asieval(asi,z1)) } call gseti (gp, G_PLCOLOR, 1) } call sprintf (Memc[str], SZ_LINE, "%.3g") call pargr (SFD_W(sfd)) call gtext (gp, 0.95, -0.1, Memc[str], "h=r;v=b") if (nx < NMAX && ny < NMAX) { call sprintf (Memc[str], SZ_LINE, "%.4g") call pargr (SFD_F(sfd)) call gtext (gp, 0.05, -0.1, Memc[str], "h=l;v=b") } } call gsview (gp, vx, vx+nx*dvx, vy, vy+ny*dvy) call gswind (gp, 0.5, 0.5+nx, 0.5+ny, 0.5) call gamove (gp, 1., 1.) # Draw label call gseti (gp, G_DRAWAXES, 0) call glabax (gp, title, "", "") call gseti (gp, G_DRAWAXES, 3) call sfree (sp) end # STF_G3 -- Enclosed flux profiles for a given focus. procedure stf_g3 (sf, current, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer char title[ARB] #I Title int i, j, np, np1, nx, ny, ix, iy real vx, dvx, vy, dvy, x1, x2, y1, y2, z, z1, r, r1, r2, dr, fa[10] pointer sp, str, gp, sff, sfd, asi real stf_i2r(), stf_r2i(), asieval() begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) gp = SF_GP(sf) sff = SFD_SFF(current) np = SFD_NP(current) # Set grid layout i = SFF_N(sff) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } # Set subview port parameters call ggview (gp, vx, dvx, vy, dvy) dvx = (dvx - vx) / nx dvy = (dvy - vy) / ny # Set data window parameters x1 = -0.05 x2 = 1.05 y1 = -0.2 y2 = 1.05 call gswind (gp, x1, x2, y1, y2) # Set fill area fa[1] = x1; fa[6] = y1 fa[2] = x2; fa[7] = y1 fa[3] = x2; fa[8] = y2 fa[4] = x1; fa[9] = y2 fa[5] = x1; fa[10] = y1 # Draw profiles. j = 0 do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff, i) if (SFD_STATUS(sfd) != 0) next np1 = SFD_NP(sfd) ix = 1 + mod (j, nx) iy = 1 + j / nx j = j + 1 call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) call gfill (gp, fa, fa[6], 4, GF_SOLID) call gseti (gp, G_DRAWTICKS, NO) call glabax (gp, "", "", "") if (sfd == current) { call gsview (gp, vx+dvx*(ix-1)+.005, vx+dvx*ix-.005, vy+dvy*(ny-iy)+.005, vy+(ny-iy+1)*dvy-.005) call gsetr (gp, G_PLWIDTH, HLWIDTH) call gseti (gp, G_PLCOLOR, HLCOLOR) call gpline (gp, fa, fa[6], 5) call gsetr (gp, G_PLWIDTH, 1.) call gseti (gp, G_PLCOLOR, 1) call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) } asi = SFD_ASI1(sfd) r2 = stf_i2r (real(np)) call gamove (gp, 0., 0.) for (z = 1.; z <= np1; z = z + 0.1) call gadraw (gp, stf_i2r(z)/r2, asieval(asi,z)) if (SF_OVRPLT(sf) == YES && sfd != SF_BEST(sf)) { call gseti (gp, G_PLCOLOR, HLCOLOR) np1 = SFD_NP(SF_BEST(sf)) asi = SFD_ASI1(SF_BEST(sf)) r1 = stf_i2r (1.) r2 = stf_i2r (real(np)) dr = 0.05 * (r2 - r1) for (r = r1; r <= r2; r = r + dr) { z = stf_r2i (r) z1 = stf_r2i (r+0.7*dr) if (z > 1. && z1 <= np1) call gline (gp, r/r2, asieval(asi,z), (r+0.7*dr)/r2, asieval(asi,z1)) } call gseti (gp, G_PLCOLOR, 1) } call sprintf (Memc[str], SZ_LINE, "%.3g") call pargr (SFD_W(sfd)) call gtext (gp, 0.95, -.1, Memc[str], "h=r;v=b") if (nx < NMAX && ny < NMAX) { call sprintf (Memc[str], SZ_LINE, "%d %d") call pargr (SFD_X(sfd)) call pargr (SFD_Y(sfd)) call gtext (gp, 0.05, -.1, Memc[str], "h=l;v=b") } } call gsview (gp, vx, vx+nx*dvx, vy, vy+ny*dvy) call gswind (gp, 0.5, 0.5+nx, 0.5+ny, 0.5) call gamove (gp, 1., 1.) # Draw label call gseti (gp, G_DRAWAXES, 0) call glabax (gp, title, "", "") call gseti (gp, G_DRAWAXES, 3) call sfree (sp) end # STF_G4 -- Radial profiles (derivative of enclosed flux) for a given star. procedure stf_g4 (sf, current, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer char title[ARB] #I Title int i, j, np, np1, nx, ny, ix, iy real vx, dvx, vy, dvy, x1, x2, y1, y2, z, z1, r, r1, r2, dr, rmax, fa[10] pointer sp, str, gp, sfs, sfd, asi real stf_i2r(), stf_r2i(), asieval() begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) gp = SF_GP(sf) sfs = SFD_SFS(current) np = SFD_NP(current) # Set grid layout i = SFS_N(sfs) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } # Set subview port parameters call ggview (gp, vx, dvx, vy, dvy) dvx = (dvx - vx) / nx dvy = (dvy - vy) / ny # Set data window parameters x1 = -0.05 x2 = 1.05 z = SF_YP2(sf) - SF_YP1(sf) y1 = SF_YP1(sf) - 0.05 * z y2 = SF_YP2(sf) + 0.15 * z # Set fill area fa[1] = x1; fa[6] = y1 fa[2] = x2; fa[7] = y1 fa[3] = x2; fa[8] = y2 fa[4] = x1; fa[9] = y2 fa[5] = x1; fa[10] = y1 # Draw profiles. j = 0 do i = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs, i) if (SFD_STATUS(sfd) != 0) next np1 = SFD_NP(sfd) ix = 1 + mod (j, nx) iy = 1 + j / nx j = j + 1 call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) call gswind (gp, x1, x2, y1, y2) call gfill (gp, fa, fa[6], 4, GF_SOLID) call gseti (gp, G_DRAWTICKS, NO) call glabax (gp, "", "", "") if (sfd == current) { call gsview (gp, vx+dvx*(ix-1)+.005, vx+dvx*ix-.005, vy+dvy*(ny-iy)+.005, vy+(ny-iy+1)*dvy-.005) call gsetr (gp, G_PLWIDTH, HLWIDTH) call gseti (gp, G_PLCOLOR, HLCOLOR) call gpline (gp, fa, fa[6], 5) call gsetr (gp, G_PLWIDTH, 1.) call gseti (gp, G_PLCOLOR, 1) call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) } asi = SFD_ASI2(sfd) rmax = stf_i2r (real(np)) z = SF_XP1(sf) call gamove (gp, stf_i2r(z)/rmax, asieval(asi,z)) for (; z <= SF_XP2(sf); z = z + 0.1) call gadraw (gp, stf_i2r(z)/rmax, asieval(asi,z)) if (SF_OVRPLT(sf) == YES && sfd != SF_BEST(sf)) { call gseti (gp, G_PLCOLOR, HLCOLOR) np1 = SFD_NP(SF_BEST(sf)) asi = SFD_ASI2(SF_BEST(sf)) rmax = stf_i2r (real(np)) r1 = stf_i2r (SF_XP1(sf)) r2 = stf_i2r (SF_XP2(sf)) dr = 0.05 * (rmax - stf_i2r(1.)) for (r = r1; r <= r2; r = r + dr) { z = stf_r2i (r) z1 = stf_r2i (r+0.7*dr) if (z > 1. && z1 <= np1) call gline (gp, r/rmax, asieval(asi,z), (r+0.7*dr)/rmax, asieval(asi,z1)) } call gseti (gp, G_PLCOLOR, 1) } call gswind (gp, 0., 1., 0., 1.) call sprintf (Memc[str], SZ_LINE, "%.3g") call pargr (SFD_W(sfd)) call gtext (gp, 0.95, 0.98, Memc[str], "h=r;v=t") if (nx < NMAX && ny < NMAX) { call sprintf (Memc[str], SZ_LINE, "%.4g") call pargr (SFD_F(sfd)) call gtext (gp, 0.05, 0.98, Memc[str], "h=l;v=t") } } call gsview (gp, vx, vx+nx*dvx, vy, vy+ny*dvy) call gswind (gp, 0.5, 0.5+nx, 0.5+ny, 0.5) call gamove (gp, 1., 1.) # Draw label call gseti (gp, G_DRAWAXES, 0) call glabax (gp, title, "", "") call gseti (gp, G_DRAWAXES, 3) call sfree (sp) end # STF_G5 -- Radial profiles (derivative of enclosed flux) for a given focus. procedure stf_g5 (sf, current, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer char title[ARB] #I Title int i, j, np, np1, nx, ny, ix, iy real vx, dvx, vy, dvy, x1, x2, y1, y2, z, z1, r, r1, r2, dr, rmax, fa[10] pointer sp, str, gp, sff, sfd, asi real stf_i2r(), stf_r2i(), asieval() begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) gp = SF_GP(sf) sff = SFD_SFF(current) np = SFD_NP(current) # Set grid layout i = SFF_N(sff) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } # Set subview port parameters call ggview (gp, vx, dvx, vy, dvy) dvx = (dvx - vx) / nx dvy = (dvy - vy) / ny # Set data window parameters x1 = -0.05 x2 = 1.05 z = SF_YP2(sf) - SF_YP1(sf) y1 = SF_YP1(sf) - 0.05 * z y2 = SF_YP2(sf) + 0.15 * z # Set fill area fa[1] = x1; fa[6] = y1 fa[2] = x2; fa[7] = y1 fa[3] = x2; fa[8] = y2 fa[4] = x1; fa[9] = y2 fa[5] = x1; fa[10] = y1 # Draw profiles. j = 0 do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff, i) if (SFD_STATUS(sfd) != 0) next np1 = SFD_NP(sfd) ix = 1 + mod (j, nx) iy = 1 + j / nx j = j + 1 call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) call gswind (gp, x1, x2, y1, y2) call gfill (gp, fa, fa[6], 4, GF_SOLID) call gseti (gp, G_DRAWTICKS, NO) call glabax (gp, "", "", "") if (sfd == current) { call gsview (gp, vx+dvx*(ix-1)+.005, vx+dvx*ix-.005, vy+dvy*(ny-iy)+.005, vy+(ny-iy+1)*dvy-.005) call gsetr (gp, G_PLWIDTH, HLWIDTH) call gseti (gp, G_PLCOLOR, HLCOLOR) call gpline (gp, fa, fa[6], 5) call gsetr (gp, G_PLWIDTH, 1.) call gseti (gp, G_PLCOLOR, 1) call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) } asi = SFD_ASI2(sfd) rmax = stf_i2r (real(np)) z = SF_XP1(sf) call gamove (gp, stf_i2r(z)/rmax, asieval(asi,z)) for (; z <= SF_XP2(sf); z = z + 0.1) call gadraw (gp, stf_i2r(z)/rmax, asieval(asi,z)) if (SF_OVRPLT(sf) == YES && sfd != SF_BEST(sf)) { call gseti (gp, G_PLCOLOR, HLCOLOR) np1 = SFD_NP(SF_BEST(sf)) asi = SFD_ASI2(SF_BEST(sf)) rmax = stf_i2r (real(np)) r1 = stf_i2r (SF_XP1(sf)) r2 = stf_i2r (SF_XP2(sf)) dr = 0.05 * (rmax - stf_i2r (1.)) for (r = r1; r <= r2; r = r + dr) { z = stf_r2i (r) z1 = stf_r2i (r+0.7*dr) if (z > 1. && z1 <= np1) call gline (gp, r/rmax, asieval(asi,z), (r+0.7*dr)/rmax, asieval(asi,z1)) } call gseti (gp, G_PLCOLOR, 1) } call gswind (gp, 0., 1., 0., 1.) call sprintf (Memc[str], SZ_LINE, "%.3g") call pargr (SFD_W(sfd)) call gtext (gp, 0.95, 0.98, Memc[str], "h=r;v=t") if (nx < NMAX && ny < NMAX) { call sprintf (Memc[str], SZ_LINE, "%d %d") call pargr (SFD_X(sfd)) call pargr (SFD_Y(sfd)) call gtext (gp, 0.05, 0.98, Memc[str], "h=l;v=t") } } call gsview (gp, vx, vx+nx*dvx, vy, vy+ny*dvy) call gswind (gp, 0.5, 0.5+nx, 0.5+ny, 0.5) call gamove (gp, 1., 1.) # Draw label call gseti (gp, G_DRAWAXES, 0) call glabax (gp, title, "", "") call gseti (gp, G_DRAWAXES, 3) call sfree (sp) end # STF_G6 -- Enclosed flux profile of a star. procedure stf_g6 (sf, current, title, xlabel, ylabel) pointer sf #I Starfocus pointer pointer current #I Star pointer char title[ARB] #I Title char xlabel[ARB] #I X label char ylabel[ARB] #I Y label int np, np1 real scale, level, radius, flux, profile pointer gp, asi real x1, x2, y1, y2, z, z1, r, r1, r2, dr real stf_i2r(), stf_r2i(), asieval() begin gp = SF_GP(sf) level = SF_LEVEL(sf) scale = SF_SCALE(sf) np = SFD_NP(current) asi = SFD_ASI1(current) x1 = -0.5 * scale x2 = (stf_i2r (real(np)) + 0.5) * scale y1 = -0.05 y2 = 1.05 call gswind (gp, x1, x2, y1, y2) call gseti (gp, G_DRAWTICKS, YES) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call glabax (gp, title, xlabel, ylabel) # Draw profiles. if (SFD_STATUS(current) == 0) { call gseti (gp, G_PLCOLOR, 1) for (z = 1.; z <= np; z = z + 1) call gmark (gp, stf_i2r(z)*scale, asieval(asi,z), GM_PLUS, 2., 2.) call gamove (gp, 0., 0.) for (z = 1.; z <= np; z = z + 0.1) call gadraw (gp, stf_i2r(z)*scale, asieval(asi,z)) switch (SF_WCODE(sf)) { case 1: radius = SFD_W(current) call gseti (gp, G_PLTYPE, 2) call gline (gp, x1, level, radius, level) call gline (gp, radius, level, radius, y1) call gseti (gp, G_PLTYPE, 1) default: radius = SFD_W(current) / 2. call gseti (gp, G_PLTYPE, 2) call gline (gp, radius, y1, radius, y2) call gseti (gp, G_PLTYPE, 1) } call gseti (gp, G_PLCOLOR, HLCOLOR) call stf_model (sf, current, 0., profile, flux) call gamove (gp, 0., flux) for (z = 1.; z <= np; z = z + 0.1) { r = stf_i2r(z) * scale call stf_model (sf, current, r, profile, flux) call gadraw (gp, r, flux) } call gseti (gp, G_PLCOLOR, 1) if (SF_OVRPLT(sf) == YES && current != SF_BEST(sf)) { call gseti (gp, G_PLCOLOR, HLCOLOR) np1 = SFD_NP(SF_BEST(sf)) asi = SFD_ASI1(SF_BEST(sf)) r1 = stf_i2r(1.) r2 = stf_i2r (real(np)) dr = 0.05 * (r2 - r1) for (r = r1; r <= r2; r = r + dr) { z = stf_r2i (r) z1 = stf_r2i (r+0.7*dr) if (z > 1. && z1 <= np1) call gline (gp, r*scale, asieval(asi,z), (r+0.7*dr)*scale, asieval(asi,z1)) } call gseti (gp, G_PLCOLOR, 1) } } end # STF_G7 -- Radial profile (derivative of enclosed flux) for a star. procedure stf_g7 (sf, current, title, xlabel, ylabel) pointer sf #I Starfocus pointer pointer current #I Star pointer char title[ARB] #I Title char xlabel[ARB] #I X label char ylabel[ARB] #I Y label int np, np1 real scale, level, radius, profile, flux pointer gp, asi real x1, x2, y1, y2, z, z1, r, r1, r2, dr real stf_i2r(), stf_r2i(), asieval() begin gp = SF_GP(sf) level = SF_LEVEL(sf) scale = SF_SCALE(sf) np = SFD_NP(current) asi = SFD_ASI2(current) x1 = -0.5 * scale x2 = (stf_i2r (real(np)) + 0.5) * scale z = SFD_YP2(current) - SFD_YP1(current) y1 = SFD_YP1(current) - 0.05 * z y2 = SFD_YP2(current) + 0.05 * z call gswind (gp, x1, x2, y1, y2) call gseti (gp, G_XDRAWTICKS, YES) call gseti (gp, G_YDRAWTICKS, NO) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call glabax (gp, title, xlabel, ylabel) # Draw profile call gseti (gp, G_PLCOLOR, 1) for (z = SF_XP1(sf); z <= SF_XP2(sf); z = z + 1) call gmark (gp, stf_i2r(z)*scale, asieval(asi,z), GM_PLUS, 2., 2.) z = SF_XP1(sf) call gamove (gp, stf_i2r(z)*scale, asieval(asi,z)) for (; z <= SF_XP2(sf); z = z + 0.1) call gadraw (gp, stf_i2r (z)*scale, asieval(asi,z)) switch (SF_WCODE(sf)) { case 1: radius = SFD_W(current) default: radius = SFD_W(current) / 2. } call gseti (gp, G_PLTYPE, 2) call gline (gp, radius, y1, radius, y2) call gseti (gp, G_PLTYPE, 1) call gseti (gp, G_PLCOLOR, HLCOLOR) z = SF_XP1(sf) r = stf_i2r(z) * scale call stf_model (sf, current, r, profile, flux) call gamove (gp, r, profile) for (; z <= np; z = z + 0.1) { r = stf_i2r(z) * scale call stf_model (sf, current, r, profile, flux) call gadraw (gp, r, profile) } call gseti (gp, G_PLCOLOR, 1) if (SF_OVRPLT(sf) == YES && current != SF_BEST(sf)) { call gseti (gp, G_PLCOLOR, HLCOLOR) np1 = SFD_NP(SF_BEST(sf)) asi = SFD_ASI2(SF_BEST(sf)) r1 = stf_i2r (SF_XP1(sf)) r2 = stf_i2r (SF_XP2(sf)) dr = 0.05 * (r2 - r1) for (r = r1; r <= r2; r = r + dr) { z = stf_r2i (r) z1 = stf_r2i (r+0.7*dr) if (z > 1. && z1 <= np1) call gline (gp, r*scale, asieval(asi,z), (r+0.7*dr)*scale, asieval(asi,z1)) } call gseti (gp, G_PLCOLOR, 1) } end # STF_G8 -- FWHM vs level. procedure stf_g8 (sf, current, title, xlabel, ylabel) pointer sf #I Starfocus pointer pointer current #I Star pointer char title[ARB] #I Title char xlabel[ARB] #I X label char ylabel[ARB] #I Y label real y1, y2, level, fwhm pointer gp begin level = SF_LEVEL(sf) if (SF_WCODE(sf) == 1) fwhm = SFD_MFWHM(current) else fwhm = SFD_W(current) call alimr (SFD_FWHM(current,2), 17, y1, y2) y2 = y2 - y1 y1 = y1 - 0.05 * y2 y2 = y1 + 1.10 * y2 y1 = min (y1, 0.9 * fwhm) y2 = max (y2, 1.1 * fwhm) gp = SF_GP(sf) call gseti (gp, G_DRAWTICKS, YES) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gswind (gp, 0., 1., y1, y2) call glabax (gp, title, xlabel, ylabel) call gvline (gp, SFD_FWHM(current,2), 17, 0.1, 0.9) call gvmark (gp, SFD_FWHM(current,2), 17, 0.1, 0.9, GM_PLUS, 2., 2.) switch (SF_WCODE(sf)) { case 1: call gseti (gp, G_PLTYPE, 2) call gline (gp, 0., fwhm, level, fwhm) call gline (gp, level, y1, level, fwhm) call gseti (gp, G_PLTYPE, 1) default: call gseti (gp, G_PLTYPE, 2) call gline (gp, 0., fwhm, 1., fwhm) call gseti (gp, G_PLTYPE, 1) } end # STF_G9 -- FWHM vs level for a given star. procedure stf_g9 (sf, current, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer char title[ARB] #I Title int i, j, nx, ny, ix, iy real level, fwhm, vx, dvx, vy, dvy, x1, x2, y1, y2, fa[10] pointer sp, str, gp, sfs, sfd begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) gp = SF_GP(sf) sfs = SFD_SFS(current) level = SF_LEVEL(sf) if (SF_WCODE(sf) == 1) fwhm = SFD_MFWHM(current) else fwhm = SFD_W(current) # Set grid layout i = SFS_N(sfs) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } # Set subview port parameters call ggview (gp, vx, dvx, vy, dvy) dvx = (dvx - vx) / nx dvy = (dvy - vy) / ny # Set data window parameters y1 = 0.9 * fwhm y2 = 1.1 * fwhm do i = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs,i) if (SFD_STATUS(sfd) != 0) next call alimr (SFD_FWHM(sfd,2), 17, x1, x2) x2 = x2 - x1 x1 = x1 - 0.05 * x2 x2 = x1 + 1.10 * x2 y1 = min (x1, y1) y2 = max (x2, y2) } x2 = y2 - y1 y1 = min (y1, fwhm - 0.2 * x2) y2 = max (y2, fwhm + 0.2 * x2) x1 = 0. x2 = 1. call gswind (gp, x1, x2, y1, y2) # Set fill area fa[1] = x1; fa[6] = y1 fa[2] = x2; fa[7] = y1 fa[3] = x2; fa[8] = y2 fa[4] = x1; fa[9] = y2 fa[5] = x1; fa[10] = y1 # Draw profiles. j = 0 do i = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs, i) if (SFD_STATUS(sfd) != 0) next ix = 1 + mod (j, nx) iy = 1 + j / nx j = j + 1 call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) call gfill (gp, fa, fa[6], 4, GF_SOLID) call gseti (gp, G_DRAWTICKS, NO) call glabax (gp, "", "", "") if (sfd == current) { call gsview (gp, vx+dvx*(ix-1)+.005, vx+dvx*ix-.005, vy+dvy*(ny-iy)+.005, vy+(ny-iy+1)*dvy-.005) call gsetr (gp, G_PLWIDTH, HLWIDTH) call gseti (gp, G_PLCOLOR, HLCOLOR) call gpline (gp, fa, fa[6], 5) call gsetr (gp, G_PLWIDTH, 1.) call gseti (gp, G_PLCOLOR, 1) call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) } call gvline (gp, SFD_FWHM(sfd,2), 17, 0.1, 0.9) #call gseti (gp, G_PLTYPE, 2) #call gline (gp, x1, fwhm, x2, fwhm) #call gseti (gp, G_PLTYPE, 1) call sprintf (Memc[str], SZ_LINE, "%.3g") call pargr (SFD_W(sfd)) call gtext (gp, 0.95, 0.95*y2+0.05*y1, Memc[str], "h=r;v=t") if (nx < NMAX && ny < NMAX) { call sprintf (Memc[str], SZ_LINE, "%.4g") call pargr (SFD_F(sfd)) call gtext (gp, 0.05, 0.95*y2+0.05*y1, Memc[str], "h=l;v=t") } } call gsview (gp, vx, vx+nx*dvx, vy, vy+ny*dvy) call gswind (gp, 0.5, 0.5+nx, 0.5+ny, 0.5) call gamove (gp, 1., 1.) # Draw label call gseti (gp, G_DRAWAXES, 0) call glabax (gp, title, "", "") call gseti (gp, G_DRAWAXES, 3) call sfree (sp) end # STF_G10 -- FWHM vs level for a given focus. procedure stf_g10 (sf, current, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer char title[ARB] #I Title int i, j, nx, ny, ix, iy real level, fwhm, vx, dvx, vy, dvy, x1, x2, y1, y2, fa[10] pointer sp, str, gp, sff, sfd begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) gp = SF_GP(sf) sff = SFD_SFF(current) level = SF_LEVEL(sf) if (SF_WCODE(sf) == 1) fwhm = SFD_MFWHM(current) else fwhm = SFD_W(current) # Set grid layout i = SFF_N(sff) if (i < 4) { nx = i ny = 1 } else { nx = nint (sqrt (real (i))) if (mod (i-1, nx+1) >= mod (i-1, nx)) nx = nx + 1 ny = (i - 1) / nx + 1 } # Set subview port parameters call ggview (gp, vx, dvx, vy, dvy) dvx = (dvx - vx) / nx dvy = (dvy - vy) / ny # Set data window parameters y1 = 0.9 * fwhm y2 = 1.1 * fwhm do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next call alimr (SFD_FWHM(sfd,2), 17, x1, x2) x2 = x2 - x1 x1 = x1 - 0.05 * x2 x2 = x1 + 1.10 * x2 y1 = min (x1, y1) y2 = max (x2, y2) } x2 = y2 - y1 y1 = min (y1, fwhm - 0.2 * x2) y2 = max (y2, fwhm + 0.2 * x2) x1 = 0. x2 = 1. call gswind (gp, x1, x2, y1, y2) # Set fill area fa[1] = x1; fa[6] = y1 fa[2] = x2; fa[7] = y1 fa[3] = x2; fa[8] = y2 fa[4] = x1; fa[9] = y2 fa[5] = x1; fa[10] = y1 # Draw plots. j = 0 do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff, i) if (SFD_STATUS(sfd) != 0) next ix = 1 + mod (j, nx) iy = 1 + j / nx j = j + 1 call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) call gfill (gp, fa, fa[6], 4, GF_SOLID) call gseti (gp, G_DRAWTICKS, NO) call glabax (gp, "", "", "") if (sfd == current) { call gsview (gp, vx+dvx*(ix-1)+.005, vx+dvx*ix-.005, vy+dvy*(ny-iy)+.005, vy+(ny-iy+1)*dvy-.005) call gsetr (gp, G_PLWIDTH, HLWIDTH) call gseti (gp, G_PLCOLOR, HLCOLOR) call gpline (gp, fa, fa[6], 5) call gsetr (gp, G_PLWIDTH, 1.) call gseti (gp, G_PLCOLOR, 1) call gsview (gp, vx+dvx*(ix-1), vx+dvx*ix, vy+dvy*(ny-iy), vy+(ny-iy+1)*dvy) } call gvline (gp, SFD_FWHM(sfd,2), 17, 0.1, 0.9) #call gseti (gp, G_PLTYPE, 2) #call gline (gp, x1, fwhm, x2, fwhm) #call gseti (gp, G_PLTYPE, 1) call sprintf (Memc[str], SZ_LINE, "%.3g") call pargr (SFD_W(sfd)) call gtext (gp, 0.95, 0.95*y2+0.05*y1, Memc[str], "h=r;v=t") if (nx < NMAX && ny < NMAX) { call sprintf (Memc[str], SZ_LINE, "%d %d") call pargr (SFD_X(sfd)) call pargr (SFD_Y(sfd)) call gtext (gp, 0.05, 0.95*y2+0.05*y1, Memc[str], "h=l;v=t") } } call gsview (gp, vx, vx+nx*dvx, vy, vy+ny*dvy) call gswind (gp, 0.5, 0.5+nx, 0.5+ny, 0.5) call gamove (gp, 1., 1.) # Draw label call gseti (gp, G_DRAWAXES, 0) call glabax (gp, title, "", "") call gseti (gp, G_DRAWAXES, 3) call sfree (sp) end # STF_G11 -- Spatial plot at one focus. procedure stf_g11 (sf, current, key, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer int key #I Plot magnitude symbol? char title[ARB] #I Title int i real x, y, z, x1, x2, y1, y2, rbest, rmin, rmax, emin, emax real vx[3,2], vy[3,2], dvx, dvy, fa[8] pointer gp, sfd, sff data fa/0.,1.,1.,0.,0.,0.,1.,1./ begin gp = SF_GP(sf) sff = SFD_SFF(current) # Range of X, Y, R, E. x1 = 1. y1 = 1. x2 = SF_NCOLS(sf) y2 = SF_NLINES(sf) rbest = SFD_W(SF_BEST(sf)) rmin = SF_W(sf) rmax = 1.5 * SF_W(sf) emin = 0 emax = 1 do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next rmin = min (rmin, SFD_W(sfd)) rmax = max (rmax, SFD_W(sfd)) emin = min (emin, SFD_E(sfd)) emax = max (emax, SFD_E(sfd)) } z = rmax - rmin rmin = rmin - 0.1 * z rmax = rmax + 0.1 * z # Set view ports call ggview (gp, vx[1,1], vx[3,2], vy[1,1], vy[3,2]) dvx = vx[3,2] - vx[1,1] dvy = vy[3,2] - vy[1,1] vx[1,1] = vx[1,1] + 0.00 * dvx vx[1,2] = vx[1,1] + 0.20 * dvx vx[2,1] = vx[1,1] + 0.25 * dvx vx[2,2] = vx[1,1] + 0.75 * dvx vx[3,1] = vx[1,1] + 0.80 * dvx vx[3,2] = vx[1,1] + 1.00 * dvx vy[1,1] = vy[1,1] + 0.00 * dvy vy[1,2] = vy[1,1] + 0.20 * dvy vy[2,1] = vy[1,1] + 0.25 * dvy vy[2,2] = vy[1,1] + 0.75 * dvy vy[3,1] = vy[1,1] + 0.80 * dvy vy[3,2] = vy[1,1] + 1.00 * dvy # (X,R) call gseti (gp, G_WCS, 2) call gseti (gp, G_DRAWAXES, 3) call gseti (gp, G_XLABELTICKS, YES) call gseti (gp, G_YLABELTICKS, YES) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 4) call gseti (gp, G_YNMINOR, 0) call gsview (gp, vx[2,1], vx[2,2], vy[1,1], vy[1,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, x1, x2, rmin, rmax) call glabax (gp, "", "Column", "") do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next x = SFD_X(sfd) y = SFD_W(sfd) if (key == 1) { z = sqrt (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFD_W(sfd) < SF_W(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFD_W(sfd) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } call gseti (gp, G_PLTYPE, 2) call gline (gp, x1, SF_W(sf), x2, SF_W(sf)) call gseti (gp, G_PLTYPE, 1) # (R,Y) call gseti (gp, G_WCS, 3) call gseti (gp, G_XLABELTICKS, YES) call gseti (gp, G_YLABELTICKS, YES) call gseti (gp, G_XNMAJOR, 4) call gseti (gp, G_XNMINOR, 0) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gsview (gp, vx[1,1], vx[1,2], vy[2,1], vy[2,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, rmin, rmax, y1, y2) call glabax (gp, "", SF_WTYPE(sf), "Line") do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next x = SFD_W(sfd) y = SFD_Y(sfd) if (key == 1) { z = sqrt (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFD_W(sfd) < SF_W(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFD_W(sfd) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } call gseti (gp, G_PLTYPE, 2) call gline (gp, SF_W(sf), y1, SF_W(sf), y2) call gseti (gp, G_PLTYPE, 1) # (E,R) call gseti (gp, G_WCS, 4) call gseti (gp, G_DRAWAXES, 3) call gseti (gp, G_XLABELTICKS, NO) call gseti (gp, G_YLABELTICKS, YES) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 4) call gseti (gp, G_YNMINOR, 0) call gsview (gp, vx[2,1], vx[2,2], vy[3,1], vy[3,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, x1, x2, emin, emax) call glabax (gp, "", "", "Ellip") do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next x = SFD_X(sfd) y = SFD_E(sfd) if (key == 1) { z = sqrt (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFD_W(sfd) < SF_W(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFD_W(sfd) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } # (E,Y) call gseti (gp, G_WCS, 5) call gseti (gp, G_XLABELTICKS, YES) call gseti (gp, G_YLABELTICKS, NO) call gseti (gp, G_XNMAJOR, 4) call gseti (gp, G_XNMINOR, 0) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gsview (gp, vx[3,1], vx[3,2], vy[2,1], vy[2,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, emin, emax, y1, y2) call glabax (gp, "", "Ellip", "") do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next x = SFD_E(sfd) y = SFD_Y(sfd) if (key == 1) { z = sqrt (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFD_W(sfd) < SF_W(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFD_W(sfd) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } # Label window. call gseti (gp, G_WCS, 1) call gseti (gp, G_DRAWAXES, 0) call gsview (gp, vx[1,1], vx[3,2], vy[1,1], vy[3,2]) call glabax (gp, title, "", "") # (X,Y) call gseti (gp, G_DRAWAXES, 3) call gseti (gp, G_LABELTICKS, NO) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gsview (gp, vx[2,1], vx[2,2], vy[2,1], vy[2,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, x1, x2, y1, y2) call glabax (gp, "", "", "") do i = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,i) if (SFD_STATUS(sfd) != 0) next x = SFD_X(sfd) y = SFD_Y(sfd) if (key == 1) { z = sqrt (SFS_M(SFD_SFS(sfd)) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFD_W(sfd) < SF_W(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFD_W(sfd) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } end # STF_G9 -- Spatial plots at best focus. procedure stf_g12 (sf, current, key, title) pointer sf #I Starfocus pointer pointer current #I Current sfd pointer int key #I Plot magnitude symbol? char title[ARB] #I Title int i real x, y, z, x1, x2, y1, y2, fmin, fmax, rbest, rmin, rmax real vx[3,2], vy[3,2], dvx, dvy, fa[8] pointer gp, sfs, sfd data fa/0.,1.,1.,0.,0.,0.,1.,1./ begin gp = SF_GP(sf) # Range of X, Y, R, F. x1 = 1. y1 = 1. x2 = SF_NCOLS(sf) y2 = SF_NLINES(sf) rbest = SFD_W(SF_BEST(sf)) fmin = MAX_REAL fmax = -MAX_REAL rmin = SF_W(sf) rmax = 1.5 * SF_W(sf) do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next fmin = min (fmin, SFS_F(sfs)) fmax = max (fmax, SFS_F(sfs)) rmin = min (rmin, SFS_W(sfs)) rmax = max (rmax, SFS_W(sfs)) } z = fmax - fmin fmin = fmin - 0.1 * z fmax = fmax + 0.1 * z z = rmax - rmin rmin = rmin - 0.1 * z rmax = rmax + 0.1 * z # Set view ports call ggview (gp, vx[1,1], vx[3,2], vy[1,1], vy[3,2]) dvx = vx[3,2] - vx[1,1] dvy = vy[3,2] - vy[1,1] vx[1,1] = vx[1,1] + 0.00 * dvx vx[1,2] = vx[1,1] + 0.20 * dvx vx[2,1] = vx[1,1] + 0.25 * dvx if (SF_NF(sf) > 1) { vx[2,2] = vx[1,1] + 0.75 * dvx vx[3,1] = vx[1,1] + 0.80 * dvx vx[3,2] = vx[1,1] + 1.00 * dvx } else { vx[2,2] = vx[1,1] + 1.00 * dvx vx[3,1] = vx[1,1] + 1.00 * dvx vx[3,2] = vx[1,1] + 1.00 * dvx } vy[1,1] = vy[1,1] + 0.00 * dvy vy[1,2] = vy[1,1] + 0.20 * dvy vy[2,1] = vy[1,1] + 0.25 * dvy if (SF_NF(sf) > 1) { vy[2,2] = vy[1,1] + 0.75 * dvy vy[3,1] = vy[1,1] + 0.80 * dvy vy[3,2] = vy[1,1] + 1.00 * dvy } else { vy[2,2] = vy[1,1] + 1.00 * dvy vy[3,1] = vy[1,1] + 1.00 * dvy vy[3,2] = vy[1,1] + 1.00 * dvy } dvx = vx[2,1] - vx[2,2] dvy = vy[1,1] - vy[1,2] if (abs (dvx) > 0.01 && abs (dvy) > 0.01) { # (X,R) call gseti (gp, G_WCS, 2) call gseti (gp, G_DRAWAXES, 3) call gseti (gp, G_XLABELTICKS, YES) call gseti (gp, G_YLABELTICKS, YES) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 4) call gseti (gp, G_YNMINOR, 0) call gsview (gp, vx[2,1], vx[2,2], vy[1,1], vy[1,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, x1, x2, rmin, rmax) call glabax (gp, "", "Column", "") do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next x = SFD_X(SFS_SFD(sfs,1)) y = SFS_W(sfs) if (key == 1) { z = sqrt (SFS_M(sfs) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFS_F(sfs) < SF_F(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFS_W(sfs) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } call gseti (gp, G_PLTYPE, 2) call gline (gp, x1, SF_W(sf), x2, SF_W(sf)) call gseti (gp, G_PLTYPE, 1) } dvx = vx[1,1] - vx[1,2] dvy = vy[2,1] - vy[2,2] if (abs (dvx) > 0.01 && abs (dvy) > 0.01) { # (R,Y) call gseti (gp, G_WCS, 3) call gseti (gp, G_XLABELTICKS, YES) call gseti (gp, G_YLABELTICKS, YES) call gseti (gp, G_XNMAJOR, 4) call gseti (gp, G_XNMINOR, 0) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gsview (gp, vx[1,1], vx[1,2], vy[2,1], vy[2,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, rmin, rmax, y1, y2) call glabax (gp, "", SF_WTYPE(sf), "Line") do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next x = SFS_W(sfs) y = SFD_Y(SFS_SFD(sfs,1)) if (key == 1) { z = sqrt (SFS_M(sfs) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFS_F(sfs) < SF_F(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFS_W(sfs) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } call gseti (gp, G_PLTYPE, 2) call gline (gp, SF_W(sf), y1, SF_W(sf), y2) call gseti (gp, G_PLTYPE, 1) } dvx = vx[2,1] - vx[2,2] dvy = vy[3,1] - vy[3,2] if (abs (dvx) > 0.01 && abs (dvy) > 0.01) { # (X,F) call gseti (gp, G_WCS, 4) call gseti (gp, G_XLABELTICKS, NO) call gseti (gp, G_YLABELTICKS, YES) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 4) call gseti (gp, G_YNMINOR, 0) call gsview (gp, vx[2,1], vx[2,2], vy[3,1], vy[3,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, x1, x2, fmin, fmax) call glabax (gp, "", "", "Focus") do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next x = SFD_X(SFS_SFD(sfs,1)) y = SFS_F(sfs) if (key == 1) { z = sqrt (SFS_M(sfs) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFS_F(sfs) < SF_F(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFS_W(sfs) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } call gseti (gp, G_PLTYPE, 2) call gline (gp, x1, SF_F(sf), x2, SF_F(sf)) call gseti (gp, G_PLTYPE, 1) } dvx = vx[3,1] - vx[3,2] dvy = vy[2,1] - vy[2,2] if (abs (dvx) > 0.01 && abs (dvy) > 0.01) { # (F,Y) call gseti (gp, G_WCS, 5) call gseti (gp, G_XLABELTICKS, YES) call gseti (gp, G_YLABELTICKS, NO) call gseti (gp, G_XNMAJOR, 4) call gseti (gp, G_XNMINOR, 0) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gsview (gp, vx[3,1], vx[3,2], vy[2,1], vy[2,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, fmin, fmax, y1, y2) call glabax (gp, "", "Focus", "") do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next x = SFS_F(sfs) y = SFD_Y(SFS_SFD(sfs,1)) if (key == 1) { z = sqrt (SFS_M(sfs) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFS_F(sfs) < SF_F(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFS_W(sfs) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } call gseti (gp, G_PLTYPE, 2) call gline (gp, SF_F(sf), y1, SF_F(sf), y2) call gseti (gp, G_PLTYPE, 1) } # Label window. call gseti (gp, G_WCS, 1) call gseti (gp, G_DRAWAXES, 0) call gsview (gp, vx[1,1], vx[3,2], vy[1,1], vy[3,2]) call glabax (gp, title, "", "") dvx = vx[2,1] - vx[2,2] dvy = vy[2,1] - vy[2,2] if (abs (dvx) > 0.01 && abs (dvy) > 0.01) { # (X,Y) call gseti (gp, G_DRAWAXES, 3) call gseti (gp, G_LABELTICKS, NO) call gseti (gp, G_XNMAJOR, 6) call gseti (gp, G_XNMINOR, 4) call gseti (gp, G_YNMAJOR, 6) call gseti (gp, G_YNMINOR, 4) call gsview (gp, vx[2,1], vx[2,2], vy[2,1], vy[2,2]) call gswind (gp, 0., 1., 0., 1.) call gfill (gp, fa, fa[5], 4, GF_SOLID) call gswind (gp, x1, x2, y1, y2) call glabax (gp, "", "", "") do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_N(sfs) == 0) next sfd = SFS_SFD(sfs,1) x = SFD_X(sfd) y = SFD_Y(sfd) if (key == 1) { z = sqrt (SFS_M(sfs) / SF_M(sf)) z = max (0.005, 0.03 * z) call gmark (gp, x, y, GM_MAG, z, z) } if (SFS_F(sfs) < SF_F(sf)) call gseti (gp, G_PLCOLOR, 2) else call gseti (gp, G_PLCOLOR, 3) z = min (2., SFS_W(sfs) / rbest) z = 0.010 * (1 + (z - 1) * 5) call gmark (gp, x, y, GM_CIRCLE, z, z) call gseti (gp, G_PLCOLOR, 1) } } end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/stfhelp.key�������������������������������������0000664�0000000�0000000�00000005116�13321663143�0023707�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ STARFOCUS COMMAND OPTIONS SUMMARY ? Help f Focus p Radial profile u Undelete a Spatial i Info q Quit x Delete b Best m Magnitude r Redraw z Zoom d Delete n Normalize s Mag symbols Next e Enclosed flux o Offset t Field radius :level :radius :show :xcenter :overplot :scale :size :ycenter CURSOR COMMANDS All plots may not be available depending on the number of focus values and the number of stars. ? Page this help information a Spatial plot at a single focus b Spatial plot of best focus values d Delete star nearest to cursor e Enclosed flux for all stars at one focus and all focus for one star f Size and ellipticity vs focus for all data i Information about point nearest the cursor m Size and ellipticity vs relative magnitude at one focus n Normalize enclosed flux at x cursor position o Offset enclosed flux to x,y cursor position by adjusting background p Radial profiles for all stars at one focus and all focus for one star The profiles are determined from the derivatives of the enclosed flux q Quit r Redraw s Toggle magnitude symbols in spatial plots t Size and ellipticity vs radius from field center at one focus u Undelete all deleted points x Delete nearest point, star, or focus (selected by query) z Zoom to a single measurement showing enclosed flux and radial profile Step through different focus or stars in current plot type COLON COMMANDS A command without a value generally shows the current value of the parameter while with a value it sets the value of the parameter. :level Level at which the size parameter is evaluated :overplot Overplot the profiles from the narrowest profile? :radius Change profile radius(*) :show Page all information for the current set of objects :size Size type (Radius|FWHM|GFWHM|MFWHM) (**) :scale Pixel scale for size values :xcenter X field center for radius from field center plots :ycenter Y field center for radius from field center plots (*) The profile radius may not exceed the initial value set by the task parameter. (**) Radius = radius enclosing the fraction of the flux specified by "level" FWHM = Full-width at half-maximum based on the radially smoothed profile GFWHM = Full-width at half-maximum of Gaussian function fit to enclosed flux MFWHM = Full-width at half-maximum of Moffat function fit to enclosed flux ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/stfprofile.x������������������������������������0000664�0000000�0000000�00000063531�13321663143�0024103�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include include "starfocus.h" # STF_FIND -- Find the object and return the data raster and object center. # STF_BKGD -- Compute the background. # STF_PROFILE -- Compute enclosed flux profile, derivative, and moments. # STF_NORM -- Renormalized enclosed flux profile # STF_WIDTHS -- Set widths. # STF_I2R -- Radius from sample index. # STF_R2I -- Sample index from radius. # STF_R2N -- Number of subsamples from radius. # STF_MODEL -- Return model values. # STF_DFWHM -- Direct FWHM from profile. # STF_FWHMS -- Measure FWHM vs level. # STF_RADIUS -- Measure the radius at the specified level. # STF_FIT -- Fit model. # STF_GAUSS1 -- Gaussian function used in NLFIT. # STF_GAUSS2 -- Gaussian function and derivatives used in NLFIT. # STF_MOFFAT1 -- Moffat function used in NLFIT. # STF_MOFFAT2 -- Moffat function and derivatives used in NLFIT. # STF_FIND -- Find the object and return the data raster and object center. # Centering uses centroid of marginal distributions of data above the mean. procedure stf_find (sf, sfd, mi) pointer sf #I Starfocus pointer pointer sfd #I Object pointer pointer mi #I Image pointer long lseed int i, j, k, x1, x2, y1, y2, nx, ny, npts real radius, buffer, width, xc, yc, xlast, ylast, r1, r2 real mean, sum, sum1, sum2, sum3, asumr(), urand() pointer im, data, ptr, imgs2r() errchk mg_c2im, mg_im2c, imgs2r begin radius = max (3., SFD_RADIUS(sfd)) buffer = SF_SBUF(sf) width = SF_SWIDTH(sf) call mg_c2im (mi, SFD_X(sfd), SFD_Y(sfd), im, xc, yc) r1 = radius + buffer + width r2 = radius # Iterate on the center finding. do k = 1, 3 { # Extract region around current center. xlast = xc ylast = yc x1 = max (1-NBNDRYPIX, nint (xc - r2)) x2 = min (IM_LEN(im,1)+NBNDRYPIX, nint (xc + r2)) nx = x2 - x1 + 1 y1 = max (1-NBNDRYPIX, nint (yc - r2)) y2 = min (IM_LEN(im,2)+NBNDRYPIX, nint (yc + r2)) ny = y2 - y1 + 1 npts = nx * ny data = imgs2r (im, x1, x2, y1, y2) # Find center of gravity of marginal distributions above mean. npts = nx * ny sum = asumr (Memr[data], npts) mean = sum / nx sum1 = 0. sum2 = 0. do i = x1, x2 { ptr = data + i - x1 sum3 = 0. do j = y1, y2 { sum3 = sum3 + Memr[ptr] ptr = ptr + nx } sum3 = sum3 - mean if (sum3 > 0.) { sum1 = sum1 + i * sum3 sum2 = sum2 + sum3 } } if (sum2 <= 0) call error (1, "Centering failed to converge") xc = sum1 / sum2 if (xlast - xc > 0.2 * nx) xc = xlast - 0.2 * nx if (xc - xlast > 0.2 * nx) xc = xlast + 0.2 * nx ptr = data mean = sum / ny sum1 = 0. sum2 = 0. do j = y1, y2 { sum3 = 0. do i = x1, x2 { sum3 = sum3 + Memr[ptr] ptr = ptr + 1 } sum3 = sum3 - mean if (sum3 > 0.) { sum1 = sum1 + j * sum3 sum2 = sum2 + sum3 } } if (sum2 <= 0) call error (1, "Centering failed to converge") yc = sum1 / sum2 if (ylast - yc > 0.2 * ny) yc = ylast - 0.2 * ny if (yc - ylast > 0.2 * ny) yc = ylast + 0.2 * ny if (nint(xc) == nint(xlast) && nint(yc) == nint(ylast)) break } # Get a new centered raster if necessary. if (nint(xc) != nint(xlast) || nint(yc) != nint(ylast) || r2 < r1) { x1 = max (1-NBNDRYPIX, nint (xc - r1)) x2 = min (IM_LEN(im,1)+NBNDRYPIX, nint (xc + r1)) nx = x2 - x1 + 1 y1 = max (1-NBNDRYPIX, nint (yc - r1)) y2 = min (IM_LEN(im,2)+NBNDRYPIX, nint (yc + r1)) ny = y2 - y1 + 1 npts = nx * ny data = imgs2r (im, x1, x2, y1, y2) } # Add a dither for integer data. The random numbers are always # the same to provide reproducibility. i = IM_PIXTYPE(im) if (i == TY_SHORT || i == TY_INT || i == TY_LONG) { lseed = 1 do i = 0, npts-1 Memr[data+i] = Memr[data+i] + urand(lseed) - 0.5 } SFD_DATA(sfd) = data SFD_X1(sfd) = x1 SFD_X2(sfd) = x2 SFD_Y1(sfd) = y1 SFD_Y2(sfd) = y2 SFD_X(sfd) = xc SFD_Y(sfd) = yc end # STF_BKGD -- Compute the background. # A mode is estimated from the minimum slope in the sorted background pixels # with a bin width of 5%. procedure stf_bkgd (sf, sfd) pointer sf #I Parameter structure pointer sfd #I Star structure int i, j, x1, x2, y1, y2, xc, yc, nx, ny, npts, ns, nsat real sat, bkgd, miso real r, r1, r2, r3, dx, dy, dz pointer sp, data, bdata, ptr begin data = SFD_DATA(sfd) x1 = SFD_X1(sfd) x2 = SFD_X2(sfd) y1 = SFD_Y1(sfd) y2 = SFD_Y2(sfd) xc = SFD_X(sfd) yc = SFD_Y(sfd) nx = x2 - x1 + 1 ny = y2 - y1 + 1 npts = nx * ny ns = 0 nsat = 0 r1 = SFD_RADIUS(sfd) ** 2 r2 = (SFD_RADIUS(sfd) + SF_SBUF(sf)) ** 2 r3 = (SFD_RADIUS(sfd) + SF_SBUF(sf) + SF_SWIDTH(sf)) ** 2 sat = SF_SAT(sf) if (IS_INDEF(sat)) sat = MAX_REAL call smark (sp) call salloc (bdata, npts, TY_REAL) ptr = data do j = y1, y2 { dy = (yc - j) ** 2 do i = x1, x2 { dx = (xc - i) ** 2 r = dx + dy if (r <= r1) { if (Memr[ptr] >= sat) nsat = nsat + 1 } else if (r >= r2 && r <= r3) { Memr[bdata+ns] = Memr[ptr] ns = ns + 1 } ptr = ptr + 1 } } if (ns > 9) { call asrtr (Memr[bdata], Memr[bdata], ns) r = Memr[bdata+ns-1] - Memr[bdata] bkgd = Memr[bdata] + r / 2 miso = r / 2 j = 1 + 0.50 * ns do i = 0, ns - j { dz = Memr[bdata+i+j-1] - Memr[bdata+i] if (dz < r) { r = dz bkgd = Memr[bdata+i] + dz / 2 miso = dz / 2 } } } else { bkgd = 0. miso = 0. } SFD_BKGD1(sfd) = bkgd SFD_BKGD(sfd) = bkgd SFD_MISO(sfd) = miso SFD_NSAT(sfd) = nsat call sfree (sp) end # STF_PROFILE -- Compute enclosed flux profile, derivative, direct FWHM, and # profile moments.. # 1. The flux profile is normalized at the maximum value. # 2. The radial profile is computed from the numerical derivative of the # enclose flux profile. procedure stf_profile (sf, sfd) pointer sf #I Parameter structure pointer sfd #I Star structure int np real radius, xc, yc int i, j, k, l, m, ns, nx, ny, x1, x2, y1, y2 real bkgd, miso, sigma, peak real r, r1, r2, r3, dx, dy, dx1, dx2, dy1, dy2, dz, xx, yy, xy, ds, da pointer sp, data, profile, ptr, asi, msi, gs int stf_r2n() real asieval(), msieval(), gseval(), stf_i2r(), stf_r2i() errchk asiinit, asifit, msiinit, msifit, gsrestore real gsdata[24] data gsdata/ 1., 4., 4., 1., 0., 0.6726812, 1., 2., 1.630641, 0.088787, 0.00389378, -0.001457133, 0.3932125, -0.1267456, -0.004864541, 0.00249941, 0.03078612, 0.02731274, -4.875850E-4, 2.307464E-4, -0.002134843, 0.007603908, -0.002552385, -8.010564E-4/ begin data = SFD_DATA(sfd) x1 = SFD_X1(sfd) x2 = SFD_X2(sfd) y1 = SFD_Y1(sfd) y2 = SFD_Y2(sfd) xc = SFD_X(sfd) yc = SFD_Y(sfd) bkgd = SFD_BKGD(sfd) miso = SFD_MISO(sfd) radius = SFD_RADIUS(sfd) np = SFD_NP(sfd) nx = x2 - x1 + 1 ny = y2 - y1 + 1 # Use an image interpolator fit to the data. call msiinit (msi, II_BISPLINE3) call msifit (msi, Memr[data], nx, ny, nx) # To avoid trying to interpolate outside the center of the # edge pixels, a requirement of the interpolator functions, # we reset the data limits. x1 = x1 + 1 x2 = x2 - 1 y1 = y1 + 1 y2 = y2 - 1 # Compute the enclosed flux profile, its derivative, and moments. call smark (sp) call salloc (profile, np, TY_REAL) call aclrr (Memr[profile], np) xx = 0. yy = 0. xy = 0. do j = y1, y2 { ptr = data + (j-y1+1)*nx + 1 dy = j - yc do i = x1, x2 { dx = i - xc # Set the subpixel sampling which may be a function of radius. r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds # Sum the interpolator values over the subpixels and compute # an offset to give the correct total for the pixel. r2 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) r2 = r2 + r1 } } r1 = Memr[ptr] - bkgd ptr = ptr + 1 r2 = r1 - r2 * da # Accumulate the enclosed flux over the sub pixels. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r = max (0., sqrt (dx2 + dy2) - ds / 2) if (r < radius) { r1 = da * (msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) + r2) # Use approximation for fractions of a subpixel. for (m=stf_r2i(r)+1; m<=np; m=m+1) { r3 = (stf_i2r (real(m)) - r) / ds if (r3 >= 1.) break Memr[profile+m-1] = Memr[profile+m-1] + r3 * r1 } # The subpixel is completely within these radii. for (; m<=np; m=m+1) Memr[profile+m-1] = Memr[profile+m-1] + r1 # Accumulate the moments above an isophote. if (r1 > miso) { xx = xx + dx2 * r1 yy = yy + dy2 * r1 xy = xy + dx1 * dy1 * r1 } } } } } } call msifree (msi) # Compute the ellipticity and position angle from the moments. r = (xx + yy) if (r > 0.) { r1 = (xx - yy) / r r2 = 2 * xy / r SFD_E(sfd) = sqrt (r1**2 + r2**2) SFD_PA(sfd) = RADTODEG (atan2 (r2, r1) / 2.) } else { SFD_E(sfd) = 0. SFD_PA(sfd) = 0. } # The magnitude and profile normalization is from the max enclosed flux. call alimr (Memr[profile], np, r, SFD_M(sfd)) if (SFD_M(sfd) <= 0.) call error (1, "Invalid flux profile") call adivkr (Memr[profile], SFD_M(sfd), Memr[profile], np) # Fit interpolator to the enclosed flux profile. call asiinit (asi, II_SPLINE3) call asifit (asi, Memr[profile], np) SFD_ASI1(sfd) = asi # Estimate a gaussian sigma (actually sqrt(2)*sigma) and if it is # it is small subtract the gaussian so that the image interpolator # can more accurately estimate subpixel values. #call stf_radius (sf, sfd, SF_LEVEL(sf), r) #sigma = r / sqrt (log (1/(1-SF_LEVEL(sf)))) call stf_radius (sf, sfd, 0.8, r) r = r / SF_SCALE(sf) sigma = 2 * r * sqrt (log(2.) / log (1/(1-0.8))) if (sigma < 5.) { if (sigma <= 2.) { call gsrestore (gs, gsdata) dx = xc - nint (xc) dy = yc - nint (yc) r = sqrt (dx * dx + dy * dy) dx = 1. ds = abs (sigma - gseval (gs, r, dx)) for (da = 1.; da <= 2.; da = da + .01) { dz = abs (sigma - gseval (gs, r, da)) if (dz < ds) { ds = dz dx = da } } sigma = dx call gsfree (gs) } sigma = sigma / (2 * sqrt (log(2.))) sigma = sigma * sigma # Compute the peak that gives the correct central pixel value. i = nint (xc) j = nint (yc) dx = i - xc dy = j - yc r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds r1 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r2 = (dx2 + dy2) / sigma if (r2 < 25.) r1 = r1 + exp (-r2) } } ptr = data + (j - y1 + 1) * nx + (i - x1 + 1) peak = (Memr[ptr] - bkgd) / (r1 * da) # Subtract the gaussian from the data. do j = y1, y2 { ptr = data + (j - y1 + 1) * nx + 1 dy = j - yc do i = x1, x2 { dx = i - xc r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds r1 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r2 = (dx2 + dy2) / sigma if (r2 < 25.) r1 = r1 + peak * exp (-r2) } } Memr[ptr] = Memr[ptr] - r1 * da ptr = ptr + 1 } } # Fit the image interpolator to the residual data. call msiinit (msi, II_BISPLINE3) call msifit (msi, Memr[data], nx, ny, nx) # Recompute the enclosed flux profile and moments # using the gaussian plus image interpolator fit to the residuals. call aclrr (Memr[profile], np) xx = 0. yy = 0. xy = 0. do j = y1, y2 { ptr = data + (j - y1 + 1) * nx + 1 dy = j - yc do i = x1, x2 { dx = i - xc r = sqrt (dx * dx + dy * dy) ns = stf_r2n (r) ds = 1. / ns da = ds * ds dz = 0.5 + 0.5 * ds # Compute interpolator correction. r2 = 0. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) r2 = r2 + r1 } } r1 = Memr[ptr] - bkgd ptr = ptr + 1 r2 = r1 - r2 * da # Accumulate the enclosed flux and moments. dy1 = dy - dz do l = 1, ns { dy1 = dy1 + ds dy2 = dy1 * dy1 dx1 = dx - dz do k = 1, ns { dx1 = dx1 + ds dx2 = dx1 * dx1 r3 = (dx2 + dy2) / sigma if (r3 < 25.) r3 = peak * exp (-r3) else r3 = 0. r = max (0., sqrt (dx2 + dy2) - ds / 2) if (r < radius) { r1 = msieval (msi, dx1+xc-x1+2, dy1+yc-y1+2) r1 = da * (r1 + r2 + r3) for (m=stf_r2i(r)+1; m<=np; m=m+1) { r3 = (stf_i2r (real(m)) - r) / ds if (r3 >= 1.) break Memr[profile+m-1] = Memr[profile+m-1] + r3 * r1 } for (; m<=np; m=m+1) Memr[profile+m-1] = Memr[profile+m-1] + r1 if (r1 > miso) { xx = xx + dx2 * r1 yy = yy + dy2 * r1 xy = xy + dx1 * dy1 * r1 } } } } } } call msifree (msi) # Recompute the moments, magnitude, normalized flux, and interp. r = (xx + yy) if (r > 0.) { r1 = (xx - yy) / r r2 = 2 * xy / r SFD_E(sfd) = sqrt (r1**2 + r2**2) SFD_PA(sfd) = RADTODEG (atan2 (r2, r1) / 2.) } else { SFD_E(sfd) = 0. SFD_PA(sfd) = 0. } call alimr (Memr[profile], np, r, SFD_M(sfd)) if (SFD_M(sfd) <= 0.) call error (1, "Invalid flux profile") call adivkr (Memr[profile], SFD_M(sfd), Memr[profile], np) call asifit (asi, Memr[profile], np) SFD_ASI1(sfd) = asi } # Compute derivative of enclosed flux profile and fit an image # interpolator. dx = 0.25 Memr[profile] = 0. ns = 0 do i = 1, np { r = stf_i2r (real(i)) r2 = stf_r2i (r + dx) if (r2 > np) { k = i break } r1 = stf_r2i (r - dx) if (r1 < 1) { if (i > 1) { dy = asieval (asi, real(i)) / r**2 Memr[profile] = (ns * Memr[profile] + dy) / (ns + 1) ns = ns + 1 } j = i } else { dy = (asieval (asi, r2) - asieval (asi, r1)) / (4 * r * dx) Memr[profile+i-1] = dy } } do i = 2, j Memr[profile+i-1] = (Memr[profile+j] - Memr[profile]) / j * (i - 1) + Memr[profile] do i = k, np Memr[profile+i-1] = Memr[profile+k-2] call adivkr (Memr[profile], SF_SCALE(sf)**2, Memr[profile], np) call alimr (Memr[profile], np, SFD_YP1(sfd), SFD_YP2(sfd)) call asiinit (asi, II_SPLINE3) call asifit (asi, Memr[profile], np) SFD_ASI2(sfd) = asi #SF_XP1(sf) = j+1 SF_XP1(sf) = 1 SF_XP2(sf) = k-1 call sfree (sp) end # STF_NORM -- Renormalize the enclosed flux profile. procedure stf_norm (sf, sfd, x, y) pointer sf #I Parameter structure pointer sfd #I Star structure real x #I Radius real y #I Flux int npmax, np pointer asi int i, j, k real r, r1, r2, dx, dy pointer sp, profile real asieval(), stf_i2r(), stf_r2i() errchk asifit begin npmax = SFD_NPMAX(sfd) np = SFD_NP(sfd) asi = SFD_ASI1(sfd) call smark (sp) call salloc (profile, npmax, TY_REAL) # Renormalize the enclosed flux profile. if (IS_INDEF(x) || x <= 0.) { dy = SFD_BKGD(sfd) - SFD_BKGD1(sfd) SFD_BKGD(sfd) = SFD_BKGD(sfd) - dy do i = 1, npmax Memr[profile+i-1] = asieval (asi, real(i)) + dy * stf_i2r(real(i)) ** 2 call alimr (Memr[profile], np, r1, r2) call adivkr (Memr[profile], r2, Memr[profile], npmax) } else if (IS_INDEF(y)) { r = max (1., min (real(np), stf_r2i (x))) r2 = asieval (asi, r) if (r2 <= 0.) return do i = 1, npmax Memr[profile+i-1] = asieval (asi, real(i)) call adivkr (Memr[profile], r2, Memr[profile], npmax) } else { r = max (1., min (real(np), stf_r2i (x))) r1 = asieval (asi, r) dy = (y - r1) / x ** 2 SFD_BKGD(sfd) = SFD_BKGD(sfd) - dy do i = 1, npmax Memr[profile+i-1] = asieval (asi, real(i)) + dy * stf_i2r(real(i)) ** 2 } call asifit (asi, Memr[profile], npmax) SFD_ASI1(sfd) = asi # Compute derivative of enclosed flux profile and fit an image # interpolator. dx = 0.25 do i = 1, npmax { r = stf_i2r (real(i)) r2 = stf_r2i (r + dx) if (r2 > np) { k = i break } r1 = stf_r2i (r - dx) if (r1 < 1) { if (i > 1) { dy = asieval (asi, real(i)) / r**2 Memr[profile] = dy } j = i } else { dy = (asieval (asi, r2) - asieval (asi, r1)) / (4 * r * dx) Memr[profile+i-1] = dy } } do i = 2, j Memr[profile+i-1] = (Memr[profile+j] - Memr[profile]) / j * (i - 1) + Memr[profile] do i = k, npmax Memr[profile+i-1] = Memr[profile+k-2] call adivkr (Memr[profile], SF_SCALE(sf)**2, Memr[profile], np) call alimr (Memr[profile], np, SFD_YP1(sfd), SFD_YP2(sfd)) asi = SFD_ASI2(sfd) call asifit (asi, Memr[profile], np) SFD_ASI2(sfd) = asi #SF_XP1(sf) = min (j+1, np) SF_XP1(sf) = 1 SF_XP2(sf) = min (k-1, np) call sfree (sp) end # STF_WIDTHS -- Set the widhts. procedure stf_widths (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure errchk stf_radius, stf_dfwhm, stf_fit begin call stf_radius (sf, sfd, SF_LEVEL(sf), SFD_R(sfd)) call stf_dfwhm (sf, sfd) call stf_fit (sf, sfd) switch (SF_WCODE(sf)) { case 1: SFD_W(sfd) = SFD_R(sfd) case 2: SFD_W(sfd) = SFD_DFWHM(sfd) case 3: SFD_W(sfd) = SFD_GFWHM(sfd) case 4: SFD_W(sfd) = SFD_MFWHM(sfd) } end # STF_I2R -- Compute radius from sample index. real procedure stf_i2r (i) real i #I Index real r #O Radius begin if (i < 20) r = 0.05 * i else if (i < 30) r = 0.1 * i - 1 else if (i < 40) r = 0.2 * i - 4 else if (i < 50) r = 0.5 * i - 16 else r = i - 41 return (r) end # STF_R2I -- Compute sample index from radius. real procedure stf_r2i (r) real r #I Radius real i #O Index begin if (r < 1) i = 20 * r else if (r < 2) i = 10 * (r + 1) else if (r < 4) i = 5 * (r + 4) else if (r < 9) i = 2 * (r + 16) else i = r + 41 return (i) end # STF_R2N -- Compute number of subsamples from radius. int procedure stf_r2n (r) real r #I Radius int n #O Number of subsamples begin if (r < 1) n = 20 else if (r < 2) n = 10 else if (r < 4) n = 5 else if (r < 9) n = 2 else n = 1 return (n) end # STF_MODEL -- Return model value. procedure stf_model (sf, sfd, r, profile, flux) pointer sf #I Main data structure pointer sfd #I Star data structure real r #I Radius at level real profile #I Profile value real flux #I Enclosed flux value real x, x1, x2, r1, r2, dr begin dr = 0.25 * SF_SCALE(sf) r1 = r - dr r2 = r + dr if (r1 < 0.) { r1 = dr r2 = r1 + dr } switch (SF_WCODE(sf)) { case 3: x = r**2 / (2. * SFD_SIGMA(sfd)**2) if (x < 20.) flux = 1 - exp (-x) else flux = 0. x1 = r1**2 / (2. * SFD_SIGMA(sfd)**2) x2 = r2**2 / (2. * SFD_SIGMA(sfd)**2) if (x2 < 20.) { x1 = 1 - exp (-x1) x2 = 1 - exp (-x2) } else { x1 = 1. x2 = 1. } if (r <= dr) { x1 = x1 / dr ** 2 x2 = x2 / (4 * dr ** 2) profile = (x2 - x1) / dr * r + x1 } else { profile = (x2 - x1) / (4 * r * dr) } default: x = 1 + (r / SFD_ALPHA(sfd)) ** 2 flux = 1 - x ** (1 - SFD_BETA(sfd)) x1 = 1 + (r1 / SFD_ALPHA(sfd)) ** 2 x2 = 1 + (r2 / SFD_ALPHA(sfd)) ** 2 x1 = 1 - x1 ** (1 - SFD_BETA(sfd)) x2 = 1 - x2 ** (1 - SFD_BETA(sfd)) if (r <= dr) { x1 = x1 / dr ** 2 x2 = x2 / (4 * dr ** 2) profile = (x2 - x1) / dr * r + x1 } else { profile = (x2 - x1) / (4 * r * dr) } } end # STF_DFWHM -- Direct FWHM from profile. procedure stf_dfwhm (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure int np real r, rpeak, profile, peak, asieval(), stf_i2r() pointer asi begin asi = SFD_ASI2(sfd) np = SFD_NP(sfd) rpeak = 1. peak = 0. for (r=1.; r <= np; r = r + 0.01) { profile = asieval (asi, r) if (profile > peak) { rpeak = r peak = profile } } peak = peak / 2. for (r=rpeak; r <= np && asieval (asi, r) > peak; r = r + 0.01) ; SFD_DFWHM(sfd) = 2 * stf_i2r (r) * SF_SCALE(sf) end # STF_FWHMS -- Measure FWHM vs level. procedure stf_fwhms (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure int i real level, r begin do i = 1, 19 { level = i * 0.05 call stf_radius (sf, sfd, level, r) switch (SF_WCODE(sf)) { case 3: SFD_FWHM(sfd,i) = 2 * r * sqrt (log (2.) / log (1/(1-level))) default: r = r / sqrt ((1.-level)**(1./(1.-SFD_BETA(sfd))) - 1.) SFD_FWHM(sfd,i) = 2 * r * sqrt (2.**(1./SFD_BETA(sfd))-1.) } } end # STF_RADIUS -- Measure the radius at the specified level. procedure stf_radius (sf, sfd, level, r) pointer sf #I Main data structure pointer sfd #I Star data structure real level #I Level to measure real r #O Radius int np pointer asi real f, fmax, rmax, asieval(), stf_i2r() begin np = SFD_NP(sfd) asi = SFD_ASI1(sfd) for (r=1; r <= np && asieval (asi, r) < level; r = r + 0.01) ; if (r > np) { fmax = 0. rmax = 0. for (r=1; r <= np; r = r + 0.01) { f = asieval (asi, r) if (f > fmax) { fmax = f rmax = r } } r = rmax } r = stf_i2r (r) * SF_SCALE(sf) end # STF_FIT -- Fit models to enclosed flux. procedure stf_fit (sf, sfd) pointer sf #I Main data structure pointer sfd #I Star data structure int i, j, n, np, pfit[2] real beta, z, params[3] pointer asi, nl pointer sp, x, y, w int locpr() real asieval(), stf_i2r() extern stf_gauss1(), stf_gauss2(), stf_moffat1(), stf_moffat2() errchk nlinitr, nlfitr data pfit/2,3/ begin np = SFD_NP(sfd) asi = SFD_ASI1(sfd) call smark (sp) call salloc (x, np, TY_REAL) call salloc (y, np, TY_REAL) call salloc (w, np, TY_REAL) n = 0 j = 0 do i = 1, np { z = 1. - max (0., asieval (asi, real(i))) if (n > np/3 && z < 0.5) break if ((n < np/3 && z > 0.01) || z > 0.5) j = n Memr[x+n] = stf_i2r (real(i)) * SF_SCALE(sf) Memr[y+n] = z Memr[w+n] = 1. n = n + 1 } # Gaussian. np = 1 params[2] = Memr[x+j] / sqrt (2. * log (1./min(0.99,Memr[y+j]))) params[1] = 1 call nlinitr (nl, locpr (stf_gauss1), locpr (stf_gauss2), params, params, 2, pfit, np, .001, 100) call nlfitr (nl, Memr[x], Memr[y], Memr[w], n, 1, WTS_USER, i) if (i != SINGULAR && i != NO_DEG_FREEDOM) { call nlpgetr (nl, params, i) if (params[2] < 0.) params[2] = Memr[x+j] / sqrt (2. * log (1./min(0.99,Memr[y+j]))) } SFD_SIGMA(sfd) = params[2] SFD_GFWHM(sfd) = 2 * SFD_SIGMA(sfd) * sqrt (2. * log (2.)) # Moffat. if (SF_BETA(sf) < 1.1) { call nlfreer (nl) call sfree (sp) call error (1, "Cannot measure FWHM - Moffat beta too small") } beta = SF_BETA(sf) if (IS_INDEFR(beta)) { beta = 2.5 np = 2 } else { np = 1 } params[3] = 1 - beta params[2] = Memr[x+j] / sqrt (min(0.99,Memr[y+j])**(1./params[3]) - 1.) params[1] = 1 call nlinitr (nl, locpr (stf_moffat1), locpr (stf_moffat2), params, params, 3, pfit, np, .001, 100) call nlfitr (nl, Memr[x], Memr[y], Memr[w], n, 1, WTS_USER, i) if (i != SINGULAR && i != NO_DEG_FREEDOM) { call nlpgetr (nl, params, i) if (params[2] < 0.) { params[3] = 1. - beta params[2] = Memr[x+j] / sqrt (min(0.99,Memr[y+j])**(1./params[3]) - 1.) } } SFD_ALPHA(sfd) = params[2] SFD_BETA(sfd) = 1 - params[3] SFD_MFWHM(sfd) = 2 * SFD_ALPHA(sfd) * sqrt (2.**(1./SFD_BETA(sfd))-1.) call nlfreer (nl) call sfree (sp) end # STF_GAUSS1 -- Gaussian function used in NLFIT. The parameters are the # amplitude and sigma and the input variable is the radius. procedure stf_gauss1 (x, nvars, p, np, z) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector int np #I Number of parameters real z #O Function return real r2 begin r2 = x[1]**2 / (2 * p[2]**2) if (abs (r2) > 20.) z = 0. else z = p[1] * exp (-r2) end # STF_GAUSS2 -- Gaussian function and derivatives used in NLFIT. The parameters # are the amplitude and sigma and the input variable is the radius. procedure stf_gauss2 (x, nvars, p, dp, np, z, der) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector real dp[np] #I Dummy array of parameters increments int np #I Number of parameters real z #O Function return real der[np] #O Derivatives real r2 begin r2 = x[1]**2 / (2 * p[2]**2) if (abs (r2) > 20.) { z = 0. der[1] = 0. der[2] = 0. } else { der[1] = exp (-r2) z = p[1] * der[1] der[2] = z * 2 * r2 / p[2] } end # STF_MOFFAT1 -- Moffat function used in NLFIT. The parameters are the # amplitude, alpha squared, and beta and the input variable is the radius. procedure stf_moffat1 (x, nvars, p, np, z) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector int np #I Number of parameters real z #O Function return real y begin y = 1 + (x[1] / p[2]) ** 2 if (abs (y) > 20.) z = 0. else z = p[1] * y ** p[3] end # STF_MOFFAT2 -- Moffat function and derivatives used in NLFIT. The # parameters are the amplitude, alpha squared, and beta and the input # variable is the radius. procedure stf_moffat2 (x, nvars, p, dp, np, z, der) real x[nvars] #I Input variables int nvars #I Number of variables real p[np] #I Parameter vector real dp[np] #I Dummy array of parameters increments int np #I Number of parameters real z #O Function return real der[np] #O Derivatives real y begin y = 1 + (x[1] / p[2]) ** 2 if (abs (y) > 20.) { z = 0. der[1] = 0. der[2] = 0. der[3] = 0. } else { der[1] = y ** p[3] z = p[1] * der[1] der[2] = -2 * z / y * p[3] / p[2] * (x[1] / p[2]) ** 2 der[3] = z * log (y) } end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/starfocus/t_starfocus.x�����������������������������������0000664�0000000�0000000�00000071662�13321663143�0024266�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include "starfocus.h" include "../mosim.h" include "../mosgeom.h" include "../mosproc.h" define HELP "starfocus$starfocus.key" define PROMPT "Options" # T_STARFOCUS -- Stellar focusing task. procedure t_starfocus () begin call starfocus (STARFOCUS) end # T_PSFMEASURE -- PSF measuring task. procedure t_psfmeasure () begin call starfocus (PSFMEASURE) end # STARFOCUS -- Stellar focusing and PSF measuring main routine. procedure starfocus (type) int type #I Task type int list # List of images pointer fvals # Focus values pointer fstep # Focus step pointer nexposures # Number of exposures pointer step # step in pixels int direction # Step direction int gap # Double step gap int coords # Type of image data bool display # Display images? int frame # Display frame int logfd # Log file descriptor bool ignore_sat # Ignore saturation? real wx, wy, xim, yim, f, df, xstep, ystep int i, i1, i2, i3, j, k, l, ip, wcs, key, id, ncols, nlines int nexp, nsfd, nimages, nstars, ngraph, nmark pointer sp, sf, image, cmd, rg, mark, im, mi pointer sfds, sfd bool clgetb() real clgetr(), imgetr(), stf_r2i() int clgeti(), clgwrd(), clgcur(), imtopenp(), imtgetim(), imgeti() int nowhite(), open(), rng_index(), strdic(), ctoi(), ctor() pointer rng_open(), mimap() errchk mimap, open, imgetr, imgeti errchk stf_find, stf_bkgd, stf_profile, stf_widths, stf_fwhms, stf_radius errchk stf_organize, stf_graph, stf_display begin call smark (sp) call salloc (sf, SF, TY_STRUCT) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (fvals, SZ_LINE, TY_CHAR) call salloc (fstep, SZ_LINE, TY_CHAR) call salloc (nexposures, SZ_LINE, TY_CHAR) call salloc (step, SZ_LINE, TY_CHAR) call salloc (cmd, SZ_LINE, TY_CHAR) #call clgstr ("instrument", Memc[image], SZ_LINE) Memc[image] = EOS call hdmopen (Memc[image]) call ampset() call procset() call aclri (Memi[sf], SF) SF_TASK(sf) = type # Set task parameters. switch (type) { case STARFOCUS: call clgstr ("focus", Memc[fvals], SZ_LINE) call clgstr ("fstep", Memc[fstep], SZ_LINE) call clgstr ("nexposures", Memc[nexposures], SZ_LINE) call clgstr ("step", Memc[step], SZ_LINE) direction = clgwrd ("direction", Memc[cmd], SZ_LINE, "|-line|+line+|-column|+column|") gap = clgwrd ("gap", Memc[cmd], SZ_LINE, "|none|beginning|end|") if (nowhite (Memc[fvals], Memc[fvals], SZ_LINE) != 0) { iferr (rg = rng_open (Memc[fvals], -MAX_REAL, MAX_REAL, 1.)) rg = NULL } else rg = NULL case PSFMEASURE: Memc[fvals] = EOS rg = NULL nexp = 1 } list = imtopenp ("images") display = clgetb ("display") frame = clgeti ("frame") coords = clgwrd ("coords", Memc[cmd], SZ_LINE, SF_TYPES) SF_XF(sf) = clgetr ("xcenter") SF_YF(sf) = clgetr ("ycenter") SF_LEVEL(sf) = clgetr ("level") SF_WCODE(sf) = clgwrd ("size", SF_WTYPE(sf), SF_SZWTYPE, SF_WTYPES) SF_BETA(sf) = clgetr ("beta") SF_SCALE(sf) = clgetr ("scale") SF_RADIUS(sf) = max (3., clgetr ("radius")) SF_NIT(sf) = clgeti ("iterations") SF_SBUF(sf) = clgetr ("sbuffer") SF_SWIDTH(sf) = clgetr ("swidth") SF_SAT(sf) = clgetr ("saturation") ignore_sat = clgetb ("ignore_sat") SF_OVRPLT(sf) = NO if (SF_LEVEL(sf) > 1.) SF_LEVEL(sf) = SF_LEVEL(sf) / 100. SF_LEVEL(sf) = max (0.05, min (0.95, SF_LEVEL(sf))) # Accumulate the psf/focus data. mark = NULL nstars = 0 nmark = 0 ngraph = 0 nimages = 0 nsfd = 0 while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) { mi = mimap (Memc[image], READ_ONLY, 0) im = MI_IM(mi,1) call imseti (im, IM_TYBNDRY, TYBNDRY) call imseti (im, IM_NBNDRYPIX, NBNDRYPIX) ncols = CX2(MI_CMG(mi)) - CX1(MI_CMG(mi)) + 1 nlines = CY2(MI_CMG(mi)) - CY1(MI_CMG(mi)) + 1 nimages = nimages + 1 if (nimages == 1) { SF_NCOLS(sf) = ncols SF_NLINES(sf) = nlines if (IS_INDEF(SF_XF(sf))) SF_XF(sf) = (SF_NCOLS(sf) + 1) / 2. if (IS_INDEF(SF_YF(sf))) SF_YF(sf) = (SF_NLINES(sf) + 1) / 2. } else if (ncols!=SF_NCOLS(sf)||nlines!=SF_NLINES(sf)) call eprintf ("WARNING: Images have different sizes\n") # Display the image if needed. if (display) { switch (coords) { case SF_MARK1: if (nimages == 1) call stf_display (Memc[image], frame) case SF_MARKALL: call stf_display (Memc[image], frame) } if (nimages == 1) { call printf ( "** Select stars to measure with 'm' and finish with 'q'.\n") call printf ( "** Additional options are '?', 'g', and :show.\n") call flush (STDOUT) } } # Accumulate objects. repeat { switch (coords) { case SF_CENTER: if (nstars == nimages) break if (rg == NULL && Memc[fvals] == EOS) id = nstars else id = 0 wx = 1 + (ncols - 1) / 2. wy = 1 + (nlines - 1) / 2. key = 0 case SF_MARK1: if (nimages == 1) { if (clgcur ("imagecur", wx, wy, wcs, key, Memc[cmd], SZ_LINE) == EOF) break call moscoords (wcs, wx, wy) switch (key) { case '?': call pagefile (HELP, PROMPT) next case ':': if (strdic (Memc[cmd], Memc[cmd], SZ_LINE, "|show|") == 1) { if (nsfd > 0) { call stf_organize (sf, sfds, nsfd) call mktemp ("tmp$iraf", Memc[cmd], SZ_LINE) logfd = open (Memc[cmd], APPEND, TEXT_FILE) call stf_log (sf, logfd) call close (logfd) call pagefile (Memc[cmd], "starfocus") call delete (Memc[cmd]) } } next case 'q': break } id = nstars if (mark == NULL) call malloc (mark, 3*10, TY_REAL) else if (mod (nmark, 10) == 0) call realloc (mark, 3*(nmark+10), TY_REAL) Memr[mark+3*nmark] = id Memr[mark+3*nmark+1] = wx Memr[mark+3*nmark+2] = wy nmark = nmark+1 } else { if (nmark == 0) break if (nstars / nmark == nimages) break i = mod (nstars, nmark) id = Memr[mark+3*i] wx = Memr[mark+3*i+1] wy = Memr[mark+3*i+2] key = 0 } case SF_MARKALL: if (clgcur ("imagecur", wx, wy, wcs, key, Memc[cmd], SZ_LINE) == EOF) break call moscoords (wcs, wx, wy) switch (key) { case '?': call pagefile (HELP, PROMPT) next case ':': if (strdic(Memc[cmd],Memc[cmd],SZ_LINE,"|show|")==1) { if (nsfd > 0) { call stf_organize (sf, sfds, nsfd) call mktemp ("tmp$iraf", Memc[cmd], SZ_LINE) logfd = open (Memc[cmd], APPEND, TEXT_FILE) call stf_log (sf, logfd) call close (logfd) call pagefile (Memc[cmd], "starfocus") call delete (Memc[cmd]) } } next case 'q': break } id = nstars } if (type == STARFOCUS) { iferr (call mg_c2im (mi, wx, wy, im, xim, yim)) { call erract (EA_WARN) next } ip = 1 if (ctoi (Memc[nexposures], ip, nexp) == 0) nexp = imgeti (im, Memc[nexposures]) ip = 1 if (ctor (Memc[step], ip, f) == 0) f = imgetr (im, Memc[step]) xstep = 0. ystep = 0. switch (direction) { case 1: ystep = -f case 2: ystep = f case 3: xstep = -f case 4: xstep = f } # Set the steps and order evaluation. # This depends on which star in the sequence is marked. # Below we assume the minimum x or maximum y is marked. i1 = 1; i2 = nexp; i3 = 1 if (xstep < 0.) { i1 = nexp; i2 = 1; i3 = -1; xstep = -xstep } if (ystep > 0.) { i1 = nexp; i2 = 1; i3 = -1; ystep = -ystep } } else { i1 = 1; i2 = 1; i3 = 1 } k = nsfd do i = i1, i2, i3 { if (i != i1) { wx = wx + xstep wy = wy + ystep xim = xim + xstep yim = yim + ystep switch (gap) { case 2: if ((i==2 && i3==1) || (i==1 && i3==-1)) { wx = wx + xstep wy = wy + ystep xim = xim + xstep yim = yim + ystep } case 3: if ((i==nexp && i3==1) || (i==nexp-1 && i3==-1)) { wx = wx + xstep wy = wy + ystep xim = xim + xstep yim = yim + ystep } } } if (xim < SF_RADIUS(sf)-NBNDRYPIX || xim > IM_LEN(im,1)-SF_RADIUS(sf)+NBNDRYPIX || yim < SF_RADIUS(sf)-NBNDRYPIX || yim > IM_LEN(im,2)-SF_RADIUS(sf)+NBNDRYPIX) next if (nexp == 1) j = nimages else j = i if (nsfd == 0) call malloc (sfds, 10, TY_POINTER) else if (mod (nsfd, 10) == 0) call realloc (sfds, nsfd+10, TY_POINTER) call malloc (sfd, SFD, TY_STRUCT) call strcpy (Memc[image], SFD_IMAGE(sfd), SF_SZFNAME) SFD_ID(sfd) = id SFD_X(sfd) = wx SFD_Y(sfd) = wy if (Memc[fvals] == EOS) f = INDEF else if (Memc[fstep] != EOS) { ip = 1 if (ctor (Memc[fvals], ip, f) == 0) f = imgetr (im, Memc[fvals]) ip = 1 if (ctor (Memc[fstep], ip, df) == 0) df = imgetr (im, Memc[fstep]) f = f + (i - 1) * df } else if (rg != NULL) { if (rng_index (rg, j, f) == EOF) call error (1, "Focus list ended prematurely") } else f = imgetr (im, Memc[fvals]) SFD_F(sfd) = f SFD_STATUS(sfd) = 0 SFD_SFS(sfd) = NULL SFD_SFF(sfd) = NULL SFD_SFI(sfd) = NULL iferr { do l = 1, SF_NIT(sf) { if (l == 1) SFD_RADIUS(sfd) = max (3., SF_RADIUS(sf)) else { SFD_RADIUS(sfd) = max (3., 3. * SFD_DFWHM(sfd)) xim = SFD_X(sfd) yim = SFD_Y(sfd) call mg_im2c (im, xim, yim, mi, wx, wy) SFD_X(sfd) = wx SFD_Y(sfd) = wy } SFD_NPMAX(sfd) = stf_r2i (SFD_RADIUS(sfd)) + 1 SFD_NP(sfd) = SFD_NPMAX(sfd) call stf_find (sf, sfd, mi) call stf_bkgd (sf, sfd) if (SFD_NSAT(sfd) > 0 && l == 1) { if (ignore_sat) call error (0, "Saturated pixels found - ignoring object") else call eprintf ( "WARNING: Saturated pixels found.\n") } call stf_profile (sf, sfd) call stf_widths (sf, sfd) call stf_fwhms (sf, sfd) } Memi[sfds+nsfd] = sfd nsfd = nsfd + 1 xim = SFD_X(sfd) yim = SFD_Y(sfd) call mg_im2c (im, xim, yim, mi, wx, wy) SFD_X(sfd) = wx SFD_Y(sfd) = wy } then { call erract (EA_WARN) call mfree (sfd, TY_STRUCT) } } if (nsfd > k) { nstars = nstars + 1 if (key == 'g') { if (nsfd - k > 0) { call stf_organize (sf, sfds+k, nsfd-k) call stf_graph (sf) ngraph = ngraph + 1 } } } } call miunmap (mi) } if (nsfd == 0) call error (1, "No input data") # Organize the objects, graph the data, and log the results. if (nstars > 1 || ngraph != nstars) { call stf_organize (sf, sfds, nsfd) call stf_graph (sf) } call stf_log (sf, STDOUT) call clgstr ("logfile", Memc[image], SZ_FNAME) ifnoerr (logfd = open (Memc[image], APPEND, TEXT_FILE)) { call stf_log (sf, logfd) call close (logfd) } # Finish up call rng_close (rg) call imtclose (list) call stf_free (sf) do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) call asifree (SFD_ASI1(sfd)) call asifree (SFD_ASI2(sfd)) call mfree (sfd, TY_STRUCT) } call mfree (SF_SFDS(sf), TY_POINTER) call mfree (mark, TY_REAL) call sfree (sp) end # STF_FREE -- Free the starfocus data structures. procedure stf_free (sf) pointer sf #I Starfocus structure int i begin do i = 1, SF_NSTARS(sf) call mfree (SF_SFS(sf,i), TY_STRUCT) do i = 1, SF_NFOCUS(sf) call mfree (SF_SFF(sf,i), TY_STRUCT) do i = 1, SF_NIMAGES(sf) call mfree (SF_SFI(sf,i), TY_STRUCT) call mfree (SF_STARS(sf), TY_POINTER) call mfree (SF_FOCUS(sf), TY_POINTER) call mfree (SF_IMAGES(sf), TY_POINTER) SF_NSTARS(sf) = 0 SF_NFOCUS(sf) = 0 SF_NIMAGES(sf) = 0 end # STF_ORGANIZE -- Organize the individual object structures by star, focus, # and image. Compute focus, radius, and magnitude by group and over all # data. procedure stf_organize (sf, sfds, nsfd) pointer sf #I Starfocus structure pointer sfds #I Pointer to array of object structures int nsfd #I Number of object structures int i, j, k, nstars, nfocus, nimages, key real f pointer stars, focus, images, sfd, sfs, sff, sfi pointer sp, image bool streq() errchk malloc int stf_focsort(), stf_magsort() extern stf_focsort, stf_magsort begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) # Free previous structures. call stf_free (sf) # Organize sfds by star. nstars = 0 for (i = 0; i < nsfd; i = i + 1) { key = SFD_ID(Memi[sfds+i]) for (j = 0; SFD_ID(Memi[sfds+j]) != key; j = j + 1) ; if (j == i) nstars = nstars + 1 } call malloc (stars, nstars, TY_POINTER) nstars = 0 for (i = 0; i < nsfd; i = i + 1) { key = SFD_ID(Memi[sfds+i]) for (j = 0; j < nstars; j = j + 1) if (SFS_ID(Memi[stars+j]) == key) break if (j == nstars) { k = 0 for (j = i; j < nsfd; j = j + 1) if (SFD_ID(Memi[sfds+j]) == key) k = k + 1 call malloc (sfs, SFS(k), TY_STRUCT) SFS_ID(sfs) = key SFS_NSFD(sfs) = k k = 0 for (j = i; j < nsfd; j = j + 1) { sfd = Memi[sfds+j] if (SFD_ID(sfd) == key) { k = k + 1 SFD_SFS(sfd) = sfs SFS_SFD(sfs,k) = sfd } } Memi[stars+nstars] = sfs nstars = nstars + 1 } } # Organize sfds by focus values. Sort by magnitude. nfocus = 0 for (i = 0; i < nsfd; i = i + 1) { f = SFD_F(Memi[sfds+i]) for (j = 0; SFD_F(Memi[sfds+j]) != f; j = j + 1) ; if (j == i) nfocus = nfocus + 1 } call malloc (focus, nfocus, TY_POINTER) nfocus = 0 for (i = 0; i < nsfd; i = i + 1) { f = SFD_F(Memi[sfds+i]) for (j = 0; j < nfocus; j = j + 1) if (SFF_F(Memi[focus+j]) == f) break if (j == nfocus) { k = 0 for (j = i; j < nsfd; j = j + 1) if (SFD_F(Memi[sfds+j]) == f) k = k + 1 call malloc (sff, SFF(k), TY_STRUCT) SFF_F(sff) = f SFF_NSFD(sff) = k k = 0 for (j = i; j < nsfd; j = j + 1) { sfd = Memi[sfds+j] if (SFD_F(sfd) == f) { k = k + 1 SFD_SFF(sfd) = sff SFF_SFD(sff,k) = sfd } } Memi[focus+nfocus] = sff nfocus = nfocus + 1 } } # Organize sfds by image. nimages = 0 for (i = 0; i < nsfd; i = i + 1) { call strcpy (SFD_IMAGE(Memi[sfds+i]), Memc[image], SZ_FNAME) for (j = 0; !streq (SFD_IMAGE(Memi[sfds+j]), Memc[image]); j = j+1) ; if (j == i) nimages = nimages + 1 } call malloc (images, nimages, TY_POINTER) nimages = 0 for (i = 0; i < nsfd; i = i + 1) { call strcpy (SFD_IMAGE(Memi[sfds+i]), Memc[image], SZ_FNAME) for (j = 0; j < nimages; j = j + 1) if (streq (SFI_IMAGE(Memi[images+j]), Memc[image])) break if (j == nimages) { k = 0 for (j = i; j < nsfd; j = j + 1) if (streq (SFD_IMAGE(Memi[sfds+j]), Memc[image])) k = k + 1 call malloc (sfi, SFI(k), TY_STRUCT) call strcpy (Memc[image], SFI_IMAGE(sfi), SF_SZFNAME) SFI_NSFD(sfi) = k k = 0 for (j = i; j < nsfd; j = j + 1) { sfd = Memi[sfds+j] if (streq (SFD_IMAGE(sfd), Memc[image])) { k = k + 1 SFD_SFI(sfd) = sfi SFI_SFD(sfi,k) = sfd } } Memi[images+nimages] = sfi nimages = nimages + 1 } } SF_NSFD(sf) = nsfd SF_SFDS(sf) = sfds SF_NSTARS(sf) = nstars SF_STARS(sf) = stars SF_NFOCUS(sf) = nfocus SF_FOCUS(sf) = focus SF_NIMAGES(sf) = nimages SF_IMAGES(sf) = images # Find the average and best focus values. Sort the focus groups # by magnitude and the star groups by focus. call stf_fitfocus (sf) do i = 1, SF_NFOCUS(sf) { sff = SF_SFF(sf,i) call qsort (SFF_SFD(sff,1), SFF_NSFD(sff), stf_magsort) } do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) call qsort (SFS_SFD(sfs,1), SFS_NSFD(sfs), stf_focsort) } call sfree (sp) end # STF_LOG -- Print log of results procedure stf_log (sf, fd) pointer sf #I Main data structure int fd #I File descriptor int i, j, n pointer sp, str, sfd, sfs, sff, sfi begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) # Print banner and overall result. call sysid (Memc[str], SZ_LINE) call fprintf (fd, "%s\n\n") call pargstr (Memc[str]) # Print each individual object organized by image. call fprintf (fd, "%15.15s %7s %7s %7s") call pargstr ("Image") call pargstr ("Column") call pargstr ("Line") call pargstr ("Mag") if (IS_INDEF(SF_F(sf))) { call fprintf (fd, " %7s") call pargstr (SF_WTYPE(sf)) } else { call fprintf (fd, " %7s %7s") call pargstr ("Focus") call pargstr (SF_WTYPE(sf)) } if (SF_WCODE(sf) == 4) { call fprintf (fd, " %4s") call pargstr ("Beta") } call fprintf (fd, " %7s %7s %3s\n") call pargstr ("Ellip") call pargstr ("PA") call pargstr ("SAT") do i = 1, SF_NIMAGES(sf) { sfi = SF_SFI(sf,i) n = 0 do j = 1, SFI_NSFD(sfi) { sfd = SFI_SFD(sfi,j) if (SFD_STATUS(sfd) != 0) next if (n == 0) { call fprintf (fd, "%15.15s") call pargstr (SFD_IMAGE(sfd)) } else call fprintf (fd, "%15w") call fprintf (fd, " %7.2f %7.2f %7.2f") call pargr (SFD_X(sfd)) call pargr (SFD_Y(sfd)) call pargr (-2.5*log10 (SFD_M(sfd) / SF_M(sf))) if (IS_INDEF(SFD_F(sfd))) { call fprintf (fd, " %7.3f") call pargr (SFD_W(sfd)) } else { call fprintf (fd, " %7.6g %7.3f") call pargr (SFD_F(sfd)) call pargr (SFD_W(sfd)) } if (SF_WCODE(sf) == 4) { call fprintf (fd, " %4.1f") call pargr (SFD_BETA(sfd)) } call fprintf (fd, " %7.2f %7d") call pargr (SFD_E(sfd)) call pargr (SFD_PA(sfd)) if (SFD_NSAT(sfd) == 0) call fprintf (fd, "\n") else call fprintf (fd, " *\n") n = n + 1 } } if (n > 0) call fprintf (fd, "\n") # Print best values by star. if (SF_NS(sf) > 1) { n = 0 do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) if (SFS_NF(sfs) > 1 || SFS_N(sfs) > 1) { call stf_title (sf, NULL, sfs, NULL, Memc[str], SZ_LINE) call fprintf (fd, " %s\n") call pargstr (Memc[str]) n = n + 1 } } if (n > 0) call fprintf (fd, "\n") } # Print averages at each focus. if (SF_NF(sf) > 1) { n = 0 do i = 1, SF_NFOCUS(sf) { sff = SF_SFF(sf,i) if (SFF_N(sff) > 1) { call stf_title (sf, NULL, NULL, sff, Memc[str], SZ_LINE) call fprintf (fd, " %s\n") call pargstr (Memc[str]) n = n + 1 } } if (n > 0) call fprintf (fd, "\n") } call stf_title (sf, NULL, NULL, NULL, Memc[str], SZ_LINE) call fprintf (fd, "%s\n") call pargstr (Memc[str]) end # STF_TITLE -- Return result title string. # The title is dependent on whether an overall title, a title for a star # group, for a focus group, or for an indivdual object is desired. # The title also is adjusted for the select size type and the number # of objects in a group. procedure stf_title (sf, sfd, sfs, sff, title, sz_title) pointer sf #I Starfocus pointer pointer sfd #I Data pointer pointer sfs #I Star pointer pointer sff #I Focus pointer char title[sz_title] #O Title string int sz_title #I Size of title string pointer ptr int i, fd, stropen() errchk stropen begin fd = stropen (title, sz_title, WRITE_ONLY) if (sfd != NULL) { call fprintf (fd, "%s @ (%.2f, %.2f):") call pargstr (SFD_IMAGE(sfd)) call pargr (SFD_X(sfd)) call pargr (SFD_Y(sfd)) switch (SF_WCODE(sf)) { case 4: call fprintf (fd, " %s=%.2f (%3.1f), e=%.2f, pa=%d") call pargstr (SF_WTYPE(sf)) call pargr (SFD_W(sfd)) call pargr (SFD_BETA(sfd)) call pargr (SFD_E(sfd)) call pargr (SFD_PA(sfd)) default: call fprintf (fd, " %s=%.2f, e=%.2f, pa=%d") call pargstr (SF_WTYPE(sf)) call pargr (SFD_W(sfd)) call pargr (SFD_E(sfd)) call pargr (SFD_PA(sfd)) } if (SFD_SFS(sfd) != NULL) { if (SFS_M(SFD_SFS(sfd)) != SF_M(sf)) { call fprintf (fd, " , m=%.2f") call pargr (-2.5*log10 (SFS_M(SFD_SFS(sfd)) / SF_M(sf))) } } if (!IS_INDEF(SFD_F(sfd))) { call fprintf (fd, ", f=%.4g") call pargr (SFD_F(sfd)) } } else if (sfs != NULL) { ptr = SFS_SFD(sfs,1) call fprintf (fd, "%s") if (SFS_NF(sfs) > 1) call pargstr ("Best focus estimate") else if (SFS_N(sfs) > 1) call pargstr ("Average star") else { for (i=1; SFD_STATUS(SFS_SFD(sfs,i))!=0; i=i+1) ; call pargstr (SFD_IMAGE(SFS_SFD(sfs,i))) } call fprintf (fd, " @ (%.2f, %.2f): %s=%.2f") call pargr (SFD_X(ptr)) call pargr (SFD_Y(ptr)) call pargstr (SF_WTYPE(sf)) call pargr (SFS_W(sfs)) #if (SFS_M(sfs) != SF_M(sf)) { call fprintf (fd, ", m=%.2f") call pargr (-2.5 * log10 (SFS_M(sfs) / SF_M(sf))) #} if (!IS_INDEF(SFS_F(sfs))) { call fprintf (fd, ", f=%.4g") call pargr (SFS_F(sfs)) } } else if (sff != NULL) { if (SFF_NI(sff) == 1) { for (i=1; SFD_STATUS(SFF_SFD(sff,i))!=0; i=i+1) ; call fprintf (fd, "%s") call pargstr (SFD_IMAGE(SFF_SFD(sff,i))) if (!IS_INDEF(SFF_F(sff))) { call fprintf (fd, " at focus %.4g") call pargr (SFF_F(sff)) } call fprintf (fd, " with average") } else { if (IS_INDEF(SFF_F(sff))) call fprintf (fd, "Average") else { call fprintf (fd, "Focus %.4g with average") call pargr (SFF_F(sff)) } } call fprintf (fd, " %s of %.2f") call pargstr (SF_WTYPE(sf)) call pargr (SFF_W(sff)) } else { if (IS_INDEF(SF_F(sf))) { if (SF_WCODE(sf) == 1) { call fprintf (fd, " %s%d%% enclosed flux radius of ") if (SF_N(sf) > 1) call pargstr ("Average ") else call pargstr ("") call pargr (100 * SF_LEVEL(sf)) } else { if (SF_N(sf) > 1) call fprintf (fd, " Average full width at half maximum (%s) of ") else call fprintf (fd, " Full width at half maximum (%s) of ") call pargstr (SF_WTYPE(sf)) } call fprintf (fd, "%.4f") call pargr (SF_W(sf)) } else { call fprintf (fd, " %s of %.6g with ") if (SF_NS(sf) > 1) { if (SF_NF(sf) > 1) call pargstr ("Average best focus") else call pargstr ("Average focus") } else { if (SF_NF(sf) > 1) call pargstr ("Best focus") else call pargstr ("Focus") } call pargr (SF_F(sf)) if (SF_WCODE(sf) == 1) { call fprintf (fd, "%d%% enclosed flux radius of ") call pargr (100 * SF_LEVEL(sf)) } else { call fprintf (fd, "%s of ") call pargstr (SF_WTYPE(sf)) } call fprintf (fd, "%.2f") call pargr (SF_W(sf)) } } call strclose (fd) end # STF_FITFOCUS -- Find the best focus. procedure stf_fitfocus (sf) pointer sf #I Starfocus pointer int i, j, k, n, jmin pointer x, y, sfd, sfs, sff, sfi real f, r, m, wr, wf bool fp_equalr() begin # Set number of valid points, stars, focuses, images. SF_N(sf) = 0 SF_YP1(sf) = 0 SF_YP2(sf) = 0 do i = 1, SF_NSFD(sf) { sfd = SF_SFD(sf,i) if (SFD_STATUS(sfd) == 0) { SF_N(sf) = SF_N(sf) + 1 SF_YP1(sf) = min (SF_YP1(sf), SFD_YP1(sfd)) SF_YP2(sf) = max (SF_YP2(sf), SFD_YP2(sfd)) } } SF_NS(sf) = 0 do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) SFS_N(sfs) = 0 SFS_M(sfs) = 0. SFS_NF(sfs) = 0 do j = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs,j) if (SFD_STATUS(SFS_SFD(sfs,j)) != 0) next SFS_N(sfs) = SFS_N(sfs) + 1 SFS_M(sfs) = SFS_M(sfs) + SFD_M(sfd) sff = SFD_SFF(sfd) for (k = 1; SFD_SFF(SFS_SFD(sfs,k)) != sff; k = k + 1) ; if (k == j) SFS_NF(sfs) = SFS_NF(sfs) + 1 } if (SFS_N(sfs) > 0) { SFS_M(sfs) = SFS_M(sfs) / SFS_N(sfs) SF_NS(sf) = SF_NS(sf) + 1 } } SF_NF(sf) = 0 do i = 1, SF_NFOCUS(sf) { sff = SF_SFF(sf,i) SFF_W(sff) = 0. SFF_N(sff) = 0 SFF_NI(sff) = 0 wr = 0 do j = 1, SFF_NSFD(sff) { sfd = SFF_SFD(sff,j) if (SFD_STATUS(sfd) != 0) next m = SFS_M(SFD_SFS(sfd)) wr = wr + m SFF_W(sff) = SFF_W(sff) + m * SFD_W(sfd) SFF_N(sff) = SFF_N(sff) + 1 sfi = SFD_SFI(sfd) for (k = 1; SFD_SFI(SFF_SFD(sff,k)) != sfi; k = k + 1) ; if (k == j) SFF_NI(sff) = SFF_NI(sff) + 1 } if (SFF_N(sff) > 0) { SFF_W(sff) = SFF_W(sff) / wr SF_NF(sf) = SF_NF(sf) + 1 } } SF_NI(sf) = 0 do i = 1, SF_NIMAGES(sf) { sfi = SF_SFI(sf,i) SFI_N(sfi) = 0 do j = 1, SFI_NSFD(sfi) if (SFD_STATUS(SFI_SFD(sfi,j)) == 0) SFI_N(sfi) = SFI_N(sfi) + 1 if (SFI_N(sfi) > 0) SF_NI(sf) = SF_NI(sf) + 1 } # Find the average magnitude, best focus, and radius for each star. # Find the brightest magnitude and average best focus and radius # over all stars. SF_BEST(sf) = SF_SFD(sf,1) SF_F(sf) = 0. SF_W(sf) = 0. SF_M(sf) = 0. SF_NS(sf) = 0 wr = 0. wf = 0. do i = 1, SF_NSTARS(sf) { sfs = SF_SFS(sf,i) call malloc (x, SFS_NSFD(sfs), TY_REAL) call malloc (y, SFS_NSFD(sfs), TY_REAL) k = 0 n = 0 do j = 1, SFS_NSFD(sfs) { sfd = SFS_SFD(sfs,j) if (SFD_STATUS(sfd) != 0) next r = SFD_W(sfd) f = SFD_F(sfd) if (!IS_INDEF(f)) k = k + 1 Memr[x+n] = f Memr[y+n] = r n = n + 1 if (r < SFD_W(SF_BEST(sf))) SF_BEST(sf) = sfd } # Find the best focus and radius. if (n == 0) { SFS_F(sfs) = INDEF SFS_W(sfs) = INDEF SFS_M(sfs) = INDEF SFS_N(sfs) = 0 } else if (k == 0) { call alimr (Memr[y], n, f, r) f = INDEF m = SFS_M(sfs) wr = wr + m SFS_F(sfs) = f SFS_W(sfs) = r SFS_M(sfs) = m SFS_N(sfs) = n SF_W(sf) = SF_W(sf) + m * r SF_M(sf) = max (SF_M(sf), m) SF_NS(sf) = SF_NS(sf) + 1 } else { SFS_N(sfs) = n if (k < n) { k = 0 do j = 0, n-1 { if (!IS_INDEF(Memr[x+j])) { Memr[x+k] = Memr[x+j] Memr[y+k] = Memr[y+j] k = k + 1 } } } call xt_sort2 (Memr[x], Memr[y], k) n = 0 do j = 1, k-1 { if (fp_equalr (Memr[x+j], Memr[x+n])) { if (Memr[y+j] < Memr[y+n]) Memr[y+n] = Memr[y+j] } else { n = n + 1 Memr[x+n] = Memr[x+j] Memr[y+n] = Memr[y+j] } } n = n + 1 # Find the minimum radius jmin = 0 do j = 0, n-1 if (Memr[y+j] < Memr[y+jmin]) jmin = j # Use parabolic interpolation to find the best focus if (jmin == 0 || jmin == n-1) { f = Memr[x+jmin] r = Memr[y+jmin] } else call stf_parab (Memr[x+jmin-1], Memr[y+jmin-1], f, r) m = SFS_M(sfs) wr = wr + m wf = wf + m SFS_F(sfs) = f SFS_W(sfs) = r SFS_M(sfs) = m SF_F(sf) = SF_F(sf) + m * f SF_W(sf) = SF_W(sf) + m * r SF_M(sf) = max (SF_M(sf), m) SF_NS(sf) = SF_NS(sf) + 1 } call mfree (x, TY_REAL) call mfree (y, TY_REAL) } if (wr > 0.) SF_W(sf) = SF_W(sf) / wr else { SF_W(sf) = INDEF SF_M(sf) = INDEF } if (wf > 0.) SF_F(sf) = SF_F(sf) / wf else SF_F(sf) = INDEF end # STF_PARAB -- Find the minimum of a parabolic fit to three points. procedure stf_parab (x, y, xmin, ymin) real x[3] real y[3] real xmin real ymin double x12, x13, x23, x213, x223, y13, y23, a, b, c begin x12 = x[1] - x[2] x13 = x[1] - x[3] x23 = x[2] - x[3] x213 = x13 * x13 x223 = x23 * x23 y13 = y[1] - y[3] y23 = y[2] - y[3] c = (y13 - y23 * x13 / x23) / (x213 - x223 * x13 / x23) b = (y23 - c * x223) / x23 a = y[3] xmin = -b / (2 * c) ymin = a + b * xmin + c * xmin * xmin xmin = xmin + x[3] end # STF_MAGSORT -- Compare two star structures by average magnitude. int procedure stf_magsort (sfd1, sfd2) pointer sfd1, sfd2 # Structures to compare pointer sfs1, sfs2 # Star structures for magnitudes begin sfs1 = SFD_SFS(sfd1) sfs2 = SFD_SFS(sfd2) if (SFS_M(sfs1) > SFS_M(sfs2)) return (-1) else if (SFS_M(sfs1) < SFS_M(sfs2)) return (1) else return (0) end # STF_FOCSORT -- Compare two star structures by focus. int procedure stf_focsort (sfd1, sfd2) pointer sfd1, sfd2 # Structures to compare begin if (SFD_F(sfd1) < SFD_F(sfd2)) return (-1) else if (SFD_F(sfd1) > SFD_F(sfd2)) return (1) else return (0) end # STF_DISPLAY -- Display image if necessary. # The user is required to display the first image separately. procedure stf_display (image, frame) char image[ARB] #I Image to display int frame #I Display frame to use int i, status pointer sp, dname, ds, iw, imd_mapframe(), iw_open() bool xt_imnameeq() errchk clcmdw begin call smark (sp) call salloc (dname, SZ_LINE, TY_CHAR) ds = imd_mapframe (1, READ_WRITE, NO) do i = 1, MAX_FRAMES { iferr (iw = iw_open (ds, i, Memc[dname], SZ_LINE, status)) next call iw_close (iw) if (xt_imnameeq (image, Memc[dname])) break } call imunmap (ds) if (!xt_imnameeq (image, Memc[dname])) { call sprintf (Memc[dname], SZ_LINE, "mscdisplay %s frame=%d") call pargstr (image) call pargi (frame) call clcmdw (Memc[dname]) } call sfree (sp) end # STFCUR -- Debugging routine. # Replace calls to clgcur with stfcur so that an text file containing the # cursor coordinates may be specified when running standalone (such as # under a debugger). int procedure stfcur (cur, wx, wy, wcs, key, cmd, sz_cmd) char cur[ARB] # Cursor name real wx, wy # Cursor coordinate int wcs # WCS int key # Key char cmd[sz_cmd] # Command int sz_cmd # Size of command int fd, stat, open(), fscan() pointer fname errchk open begin if (fd == NULL) { call malloc (fname, SZ_FNAME, TY_CHAR) call clgstr (cur, Memc[fname], SZ_FNAME) fd = open (Memc[fname], READ_ONLY, TEXT_FILE) call mfree (fname, TY_CHAR) } stat = fscan (fd) if (stat == EOF) { call close (fd) return (stat) } call gargr (wx) call gargr (wy) call gargi (wcs) call gargi (key) return (stat) end ������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/t_mscdisplay.x��������������������������������������������0000664�0000000�0000000�00000113022�13321663143�0022377�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include "mosim.h" include "mosgeom.h" include "mosproc.h" include "display.h" include "gwindow.h" # ZCOMBINE options. define ZC_DICT "|none|auto|minmax|average|median|" define ZC_NONE 1 define ZC_AUTO 2 define ZC_MINMAX 3 define ZC_AVERAGE 4 define ZC_MEDIAN 5 # ADU to/from e- options. define UNCORRECT 0 define CORRECT 1 # T_MSCDISPLAY -- Quick-look mosaic display task. procedure t_mscdisplay () bool zmap int i, j, k, wcsver, frame, ninput, nproc, zcom, select, bufsize int nx[2], ny[2] real xc, yc, xs[2], ys[2], a, b, c, d, tx, ty, zz1, zz2 pointer sp, image, image1, title, procstr, wcs pointer z1, z2, wdes, mi, mg, cmg, ds, im, wipix, wdpix, wnwin, wdwin, dsbuf bool clgetb(), fp_equalr(), streq(), hdmflag() int clgeti(), clgwrd(), btoi(), access(), imd_wcsver(), imtlen(), imtgetim() real clgetr(), ahivr(), alovr(), asumr(), amedr() pointer mimap(), imd_mapframe1(), iw_open(), imps2s(), imtopenp() errchk imps2s, msc_load_display include "mosproc.com" begin call smark (sp) call salloc (image, SZ_LINE, TY_CHAR) call salloc (image1, SZ_LINE, TY_CHAR) call salloc (title, SZ_LINE, TY_CHAR) call salloc (procstr, SZ_LINE, TY_CHAR) call salloc (wcs, SZ_LINE, TY_CHAR) # Set buffer, instrument, amplifier, and process information. #bufsize = max (1024., 1000000. * clgetr ("im_bufsize")) bufsize = 65000. #call clgstr ("instrument", Memc[image1], SZ_LINE) Memc[image1] = EOS call hdmopen (Memc[image1]) call ampset() call procset() # Initialize multiple mappings. wcsver = imd_wcsver() # Get image. im = imtopenp ("image") if (imtlen (im) != 1) call error (1, "Only one image may be displayed") i = imtgetim (im, Memc[image], SZ_LINE) call imtclose (im) frame = clgeti ("frame") if ((wcsver == 0 && frame > 4) || frame > 16) call error (1, "Frame number too large for display server") select = btoi (clgetb ("select_frame")) call sprintf (Memc[wcs], SZ_LINE, "uparm$mscdisp%d") call pargi (frame) # Check if already loaded. if (clgetb ("check")) { if (access (Memc[wcs], 0, 0) == YES) { ds = imd_mapframe1 (frame, READ_ONLY, select, NO) im = iw_open (ds, frame, Memc[image1], SZ_LINE, i) call iw_close (im) call imunmap (ds) if (i != ERR) { if (streq (Memc[image], Memc[image1])) { call miunmap (mi) call hdmclose () call ampfree() call sfree (sp) return } } } } # Map mosaic image. iferr (mi = mimap (Memc[image], READ_ONLY, 0)) { call sfree (sp) call hdmclose() call erract (EA_ERROR) } ninput = MI_NIMS(mi) cmg = MI_CMG(mi) # Allocate memory for each input image. call salloc (z1, ninput, TY_REAL) call salloc (z2, ninput, TY_REAL) call salloc (wdes, ninput+1, TY_POINTER) do i = 0, ninput { call salloc (Memi[wdes+i], LEN_WDES, TY_STRUCT) call aclri (Memi[Memi[wdes+i]], LEN_WDES) } # Convert default z values given in e- to uncorrected (input) ADU. call amovkr (clgetr ("z1"), Memr[z1], ninput) call amovkr (clgetr ("z2"), Memr[z2], ninput) call zproc (Memi[MI_MGS(mi)], Memr[z1], Memr[z2], ninput, proc, UNCORRECT) # Open display without erasing yet. ds = imd_mapframe1 (frame, READ_ONLY, NO, NO) # Determine parameters for the output display. if (clgetb ("fill")) call mos_params (NULL, ds, Memi[wdes], 1, NX(cmg), 1, 1, NY(cmg), 1, 0.5, 0.5, 1.0, 1.0, 0., 0.) else { mg = MI_MG(mi,1) xs[1] = real (NX(cmg)) / abs (DX(mg)) / IM_LEN(ds,1) ys[1] = real (NY(cmg)) / abs (DY(mg)) / IM_LEN(ds,2) i = max (1000 - int (1000. - xs[1]), 1000 - int (1000. - ys[1])) xs[1] = xs[1] / i ys[1] = ys[1] / i call mos_params (NULL, ds, Memi[wdes], 1, NX(cmg), 1, 1, NY(cmg), 1, 0.5, 0.5, xs, ys, 0., 0.) } # Determine parameters for each input image. nproc = 0 do i = 1, ninput { mg = MI_MG(mi,i) im = MI_IM(mi,i) # Set display window for image. call mos_comap (Memi[wdes], mg, cmg, xc, yc, xs, ys) # Set display parameters for image. call mos_params (mg, ds, Memi[wdes+i], DX1(mg), DX2(mg), abs(DX(mg)), DY1(mg), DY2(mg), abs(DY(mg)), xc, yc, xs, ys, Memr[z1+i-1], Memr[z2+i-1]) call imseti (im, IM_CANCEL, 0) if (PROC(mg) == YES) nproc = nproc + 1 } # Combine the z levels if needed. Do things in e-. call zproc (Memi[MI_MGS(mi)], Memr[z1], Memr[z2], ninput, proc, CORRECT) zz1 = asumr (Memr[z1], ninput) / ninput zz2 = asumr (Memr[z2], ninput) / ninput zmap = false do i = 1, ninput if (!fp_equalr(Memr[z1+i-1],zz1) || !fp_equalr(Memr[z2+i-1],zz2)) { zmap = true break } if (zmap) { zcom = clgwrd ("zcombine", Memc[image1], SZ_LINE, ZC_DICT) if (zcom == ZC_AUTO) { zcom = ZC_MINMAX do i = 1, ninput { mg = MI_MG(mi,i) im = MI_IM(mi,i) if (!hdmflag (im, "flatcor")) { if (PROC(mg) == NO || (PROC(mg) == YES && DOFLAT(mg) == NO)) { zcom = ZC_NONE break } } } } if (zcom != ZC_NONE) { switch (zcom) { case ZC_MINMAX: zz1 = alovr (Memr[z1], ninput) zz2 = ahivr (Memr[z2], ninput) case ZC_AVERAGE: zz1 = asumr (Memr[z1], ninput) / ninput zz2 = asumr (Memr[z2], ninput) / ninput case ZC_MEDIAN: zz1 = amedr (Memr[z1], ninput) zz2 = amedr (Memr[z2], ninput) } # Now set the values for display. call zproc (Memi[MI_MGS(mi)], zz1, zz2, 1, proc, UNCORRECT) do i = 1, ninput { wdwin = W_WC(Memi[wdes+i],W_DWIN) W_ZS(wdwin) = zz1 W_ZE(wdwin) = zz2 } call zproc (Memi[MI_MGS(mi)], zz1, zz2, 1, proc, CORRECT) } } # Print out some useful information call mos_info (mi, wdes, zcom, Memr[z1], Memr[z2], STDOUT) # Print tile information. call msctile (mi, Memc[wcs], frame, wcsver) # Now we're ready to write to the display. call imunmap (ds) ds = imd_mapframe1 (frame, WRITE_ONLY, select, btoi (clgetb ("erase"))) # Set WCS. do k = 1, ninput+1 { i = mod (k, ninput+1) j = max (i, 1) wipix = W_WC(Memi[wdes+i],W_IPIX) wdpix = W_WC(Memi[wdes+i],W_DPIX) wnwin = W_WC(Memi[wdes+i],W_NWIN) wdwin = W_WC(Memi[wdes+i],W_DWIN) # Define mapping from image pixels to display pixels. xs[1] = W_XS(wipix) ys[1] = W_YS(wipix) nx[1] = W_XE(wipix) - W_XS(wipix) + 1 ny[1] = W_YE(wipix) - W_YS(wipix) + 1 xs[2] = W_XS(wdpix) ys[2] = W_YS(wdpix) nx[2] = W_XE(wdpix) - W_XS(wdpix) + 1 ny[2] = W_YE(wdpix) - W_YS(wdpix) + 1 if (i > 0) { call imstats (MI_IM(mi,i), IM_IMAGENAME, Memc[image1], SZ_LINE) iferr (call imgstr (MI_IM(mi,i),"EXTNAME",Memc[wcs],SZ_LINE)) { call sprintf (Memc[wcs], SZ_LINE, "%d") call pargi (i) } } else { call strcpy (Memc[MI_RNAME(mi)], Memc[image1], SZ_LINE) call strcpy ("mosaic", Memc[wcs], SZ_LINE) } call fpathname (Memc[image1], Memc[image1], SZ_LINE) call imd_setmapping (Memc[wcs], xs[1], ys[1], nx[1], ny[1], nint(xs[2]), nint(ys[2]), nx[2], ny[2], Memc[image1]) # Define linear pixel WCS. a = (W_XE(wdwin)-W_XS(wdwin))/((W_XE(wnwin)-W_XS(wnwin))* IM_LEN(ds,1)) b = 0.0 c = 0.0 d = (W_YE(wdwin)-W_YS(wdwin))/((W_YE(wnwin)-W_YS(wnwin))* IM_LEN(ds,2)) tx = W_XS(wdwin) - a * (W_XS(wnwin) * IM_LEN(ds,1)) ty = W_YS(wdwin) - d * (W_YS(wnwin) * IM_LEN(ds,2)) # Allow for the Y-flip (origin at upper left in display window). d = -d ty = W_YE(wdwin) - d * ((1.0 - W_YE(wnwin)) * IM_LEN(ds,2)) # Translate the screen corner to the center of the screen pixel. tx = tx + 0.5 * a ty = ty + 0.5 * d # Set origin to mosaic coordinates. tx = tx + CX1(cmg) - 1 ty = ty + CY1(cmg) - 1 # Set the title and WCS. if (nproc > 0) { mg = MI_MG(mi,j) if (DOBIAS(mg)==YES || DOZERO(mg)==YES || DOFLAT(mg)==YES) { Memc[title] = EOS if (DOBIAS(mg) == YES) { call sprintf (Memc[procstr], SZ_LINE, ",bias") call strcat (Memc[procstr], Memc[title], SZ_LINE) } if (DOZERO(mg) == YES) { call sprintf (Memc[procstr], SZ_LINE, ",zero=%s") call pargstr (ZERONAME(mg)) call strcat (Memc[procstr], Memc[title], SZ_LINE) } if (DOFLAT(mg) == YES) { call sprintf (Memc[procstr], SZ_LINE, ",flat=%s") call pargstr (FLATNAME(mg)) call strcat (Memc[procstr], Memc[title], SZ_LINE) } call sprintf (Memc[procstr], SZ_LINE, "] %s") call pargstr (IM_TITLE(MI_IM(mi,j))) call strcat (Memc[procstr], Memc[title], SZ_LINE) Memc[title] = '[' } else { call sprintf (Memc[title], SZ_LINE, "[process] %s") call pargstr (IM_TITLE(MI_IM(mi,j))) } } else call strcpy (IM_TITLE(MI_IM(mi,j)), Memc[title], SZ_LINE) call imd_putwcs (ds, frame, Memc[MI_RNAME(mi)], Memc[title], a, b, c, d, tx, ty, zz1, zz2, W_ZT(W_WC(Memi[wdes+j],W_DWIN))) } # Now display the images. dsbuf = NULL if (clgetb ("onepass")) { iferr { dsbuf = imps2s (ds, 1, IM_LEN(ds,1), 1, IM_LEN(ds,2)) call aclrs (Mems[dsbuf], IM_LEN(ds,1)*IM_LEN(ds,2)) } then dsbuf = NULL } if (dsbuf == NULL) { call imunmap (ds) ds = imd_mapframe1 (frame, READ_WRITE, select, NO) } do i = 1, ninput { mg = MI_MG(mi,i) im = MI_IM(mi,i) #call imseti (im, IM_BUFSIZE, bufsize) call msc_load_display (mg, ds, dsbuf, Memi[wdes+i]) #call imseti (im, IM_CANCEL, 0) } # Tidy up do i = 0, ninput { do j = 0, W_MAXWC if (W_UPTR(W_WC(Memi[wdes+i],j)) != NULL) call ds_ulutfree (W_UPTR(W_WC(Memi[wdes+i],j))) } call miunmap (mi) call imunmap (ds) call hdmclose () call ampfree() call sfree (sp) end # MSCTILE -- Print tile information. procedure msctile (mi, fname, frame, wcsver) pointer mi #I MOSIM structure char fname[ARB] #I File name for output int frame #I Display frame int wcsver #I WCS version int i, fd, nowhite(), access(), open() pointer sp, image, cmg, mg begin call smark (sp) call salloc (image, SZ_LINE, TY_CHAR) if (nowhite (fname, Memc[image], SZ_LINE) == 0) { call sfree (sp) return } if (access (Memc[image], 0, 0) == YES) call delete (Memc[image]) fd = open (Memc[image], NEW_FILE, TEXT_FILE) cmg = MI_CMG(mi) do i = 1, MI_NIMS(mi) { mg = MI_MG(mi,i) call imstats (MI_IM(mi,i), IM_IMAGENAME, Memc[image], SZ_LINE) if (wcsver == 0) { call fprintf (fd, "%s %d %d %d %d\n") call pargstr (Memc[image]) call pargi (CX1(mg)) call pargi (CX2(mg)) call pargi (CY1(mg)) call pargi (CY2(mg)) } else { call fprintf (fd, "%s %d %d %d %d %d%02d\n") call pargstr (Memc[image]) call pargi (CX1(mg)) call pargi (CX2(mg)) call pargi (CY1(mg)) call pargi (CY2(mg)) call pargi (frame) call pargi (i) } } call close (fd) call sfree (sp) end # MOS_COMAP -- Compute NDC parameters for a mosaic tile. procedure mos_comap (wdes, img, omg, xc, yc, xs, ys) pointer wdes #I Output window descriptor pointer img #I Mosgeom structure for input image pointer omg #I Mosgeom structure for tiled image real xc, yc #O Center of tile in x and y in NDC real xs, ys #O Size of tile in x and y in NDC real x1, x2, y1, y2, xscale, yscale pointer wnwin, wdwin begin wnwin = W_WC(wdes,W_NWIN) wdwin = W_WC(wdes,W_DWIN) x1 = CX1(img) - CX1(omg) + 1 x2 = CX2(img) - CX1(omg) + 1 y1 = CY1(img) - CY1(omg) + 1 y2 = CY2(img) - CY1(omg) + 1 xscale = (W_XE(wnwin) - W_XS(wnwin)) / (W_XE(wdwin) - W_XS(wdwin)) yscale = (W_YE(wnwin) - W_YS(wnwin)) / (W_YE(wdwin) - W_YS(wdwin)) xc = W_XS(wnwin) + xscale * (0.5 * (x1 + x2) - W_XS(wdwin)) yc = W_YS(wnwin) + yscale * (0.5 * (y1 + y2) - W_YS(wdwin)) xs = min (xscale * abs (x2 - x1 + 1), 1.0) ys = min (yscale * abs (y2 - y1 + 1), 1.0) end # MOS_INFO -- Print information about Z values. procedure mos_info (mi, wdes, zcom, z1, z2, fd) pointer mi #I Mosim structure pointer. pointer wdes #I Display structure pointer. int zcom #I Zcombine option real z1[ARB] #I Corrected Z1 values. real z2[ARB] #I Corrected Z2 values. int fd #I File descriptor int i pointer mg, wdwin begin call fprintf (fd, " Image:%17tIndividual%34tDisplay (zcombine=%s)\n") switch (zcom) { case ZC_MINMAX: call pargstr ("minmax") case ZC_AVERAGE: call pargstr ("average") case ZC_MEDIAN: call pargstr ("median") default: call pargstr ("none") } do i = 1, MI_NIMS(mi) { mg = MI_MG(mi,i) wdwin = W_WC(Memi[wdes+i],W_DWIN) if (AMPID(mg) == NULL) { call fprintf (fd, " im%d:") call pargi (i) } else { call fprintf (fd, "%6s:") call pargstr (Memc[AMPID(mg)]) } call fprintf (fd, "%5t%8.1f %8.1f%30t%8.1f %8.1f\n") call pargr (z1[i]) call pargr (z2[i]) call pargr (W_ZS(wdwin)) call pargr (W_ZE(wdwin)) } call flush (fd) end # MOS_PARAMS -- Get the parameters controlling how the image is mapped # into the display frame. Set up the transformations and save in the graphics # descriptor file. procedure mos_params (mg, ds, wdes, x1, x2, dx, y1, y2, dy, xc, yc, xs, ys, z1, z2) pointer mg, ds, wdes #I Image, display, and graphics descriptors int x1, x2, y1, y2 #I Image section int dx, dy #I Pixel summing factors real xc, yc #I Center of display window in NDC real xs, ys #I Size of display window in NDC real z1, z2 #U Default and final values bool fill, zscale_flag, zrange_flag, zmap_flag real xcenter, ycenter, xsize, ysize real xmag, ymag, xscale, yscale, pxsize, pysize real contrast int ncols, nlines, nsample pointer im, wnwin, wdwin, wwwin, wipix, wdpix, zpm, bpm pointer sp, str, ztrans, lutfile int clgeti(), clgwrd(),nowhite() real clgetr() pointer xmaskcolor_map(), yt_pmmap(), zsc_pmsection() pointer ds_ulutalloc() bool streq(), clgetb() errchk xmaskcolor_map, yt_pmmap, zsc_pmsection, msc_mzscale begin call smark (sp) call salloc (str, SZ_LINE, TY_CHAR) call salloc (ztrans, SZ_FNAME, TY_CHAR) if (mg != NULL) im = MG_IM(mg) else im = NULL if (im != NULL) { # Get overlay mask and colors. call clgstr ("overlay", W_OVRLY(wdes), W_SZSTRING) call clgstr ("ocolors", Memc[str], SZ_LINE) W_OCOLORS(wdes) = xmaskcolor_map (Memc[str]) # Get bad pixel mask. call clgstr ("bpmask", W_BPM(wdes), W_SZSTRING) W_BPDISP(wdes) = clgwrd ("bpdisplay", Memc[str], SZ_LINE, BPDISPLAY) call clgstr ("bpcolors", Memc[str], SZ_LINE) W_BPCOLORS(wdes) = xmaskcolor_map (Memc[str]) } # Determine the display window into which the image is to be mapped # in normalized device coordinates. #xcenter = max(0.0, min(1.0, clgetr ("xcenter"))) #ycenter = max(0.0, min(1.0, clgetr ("ycenter"))) #xsize = max(0.0, min(1.0, clgetr ("xsize"))) #ysize = max(0.0, min(1.0, clgetr ("ysize"))) xcenter = xc ycenter = yc xsize = xs ysize = ys # Set up a new graphics descriptor structure defining the coordinate # transformation used to map the image into the display frame. wnwin = W_WC(wdes,W_NWIN) wdwin = W_WC(wdes,W_DWIN) wwwin = W_WC(wdes,W_WWIN) wipix = W_WC(wdes,W_IPIX) wdpix = W_WC(wdes,W_DPIX) # Determine X and Y scaling ratios required to map the image into the # normalized display window. If spatial scaling is not desired filling # must be disabled and the XMAG and YMAG are adjusted to the nearest # integer size. #ncols = IM_LEN(im,1) #nlines = IM_LEN(im,2) ncols = x2 - x1 + 1 nlines = y2 - y1 + 1 #fill = clgetb ("fill") fill = true if (fill) { # Compute scale in units of window coords per data pixel required # to scale image to fit window. xmag = (IM_LEN(ds,1) * xsize) / ncols ymag = (IM_LEN(ds,2) * ysize) / nlines if (xmag > ymag) xmag = ymag else ymag = xmag xmag = xmag * dx / min (dx, dy) ymag = ymag * dy / min (dx, dy) } else { # Compute scale required to provide block averaging only. xmag = (IM_LEN(ds,1) * xsize) / ncols ymag = (IM_LEN(ds,2) * ysize) / nlines if (xmag > ymag) xmag = ymag else ymag = xmag xmag = xmag * dx / min (dx, dy) ymag = ymag * dy / min (dx, dy) xmag = 1. / int (1. / xmag + 0.999) ymag = 1. / int (1. / ymag + 0.999) } xscale = 1.0 / (IM_LEN(ds,1) / xmag) yscale = 1.0 / (IM_LEN(ds,2) / ymag) # Set device window limits in normalized device coordinates. # World coord system 0 is used for the device window. W_XS(wnwin) = xcenter - xsize / 2.0 W_XE(wnwin) = xcenter + xsize / 2.0 W_YS(wnwin) = ycenter - ysize / 2.0 W_YE(wnwin) = ycenter + ysize / 2.0 # Set pixel coordinates of window. # If the image is too large to fit in the window given the scaling # factors XSCALE and YSCALE, the following will set starting and ending # pixel coordinates in the interior of the image. If the image is too # small to fill the window then the pixel coords will reference beyond # the bounds of the image. Note that the 0.5 is because NDC has # the screen corner at 0 while screen pixels have the corner at 0.5. pxsize = xsize / xscale pysize = ysize / yscale W_XS(wdwin) = (ncols / 2.0) - (pxsize / 2.0) + 0.5 W_XE(wdwin) = W_XS(wdwin) + pxsize W_YS(wdwin) = (nlines / 2.0) - (pysize / 2.0) + 0.5 W_YE(wdwin) = W_YS(wdwin) + pysize # Compute X and Y magnification ratios required to map image into # the device window in device pixel units. xmag = (W_XE(wnwin)-W_XS(wnwin))*IM_LEN(ds,1)/(W_XE(wdwin)-W_XS(wdwin)) ymag = (W_YE(wnwin)-W_YS(wnwin))*IM_LEN(ds,2)/(W_YE(wdwin)-W_YS(wdwin)) # Compute the coordinates of the image section to be displayed. # Round down if upper pixel is exactly at one-half. W_XS(wipix) = max (1, nint(W_XS(wdwin))) + x1 - 1 #W_XE(wipix) = min (ncols, nint(W_XE(wdwin)-1.01)) + x1 - 1 W_XE(wipix) = min (ncols, nint(W_XE(wdwin)-0.01)) + x1 - 1 W_YS(wipix) = max (1, nint(W_YS(wdwin))) + y1 - 1 #W_YE(wipix) = min (nlines, nint(W_YE(wdwin)-1.01)) + y1 - 1 W_YE(wipix) = min (nlines, nint(W_YE(wdwin)-0.01)) + y1 - 1 # Now compute the image and display pixels to be used. # The image may be truncated to fit in the display window. # These are integer coordinates at the pixel centers. pxsize = W_XE(wipix) - W_XS(wipix) + 1 pysize = W_YE(wipix) - W_YS(wipix) + 1 xcenter = (W_XE(wnwin) + W_XS(wnwin)) / 2.0 * IM_LEN(ds,1) + 0.5 ycenter = (W_YE(wnwin) + W_YS(wnwin)) / 2.0 * IM_LEN(ds,2) + 0.5 W_XS(wdpix) = max (1, nint (xcenter - (pxsize/2.0*xmag) + 0.5)) #W_XE(wdpix) = min (IM_LEN(ds,1), nint (W_XS(wdpix)+pxsize*xmag - 1.01)) W_XE(wdpix) = min (IM_LEN(ds,1), nint (W_XS(wdpix)+pxsize*xmag - 0.01)) W_YS(wdpix) = max (1, nint (ycenter - (pysize/2.0*ymag) + 0.5)) #W_YE(wdpix) = min (IM_LEN(ds,2), nint (W_YS(wdpix)+pysize*ymag - 1.01)) W_YE(wdpix) = min (IM_LEN(ds,2), nint (W_YS(wdpix)+pysize*ymag - 0.01)) # I don't remember why the changes indicated by the commented code # above were done. So the following is a hack for a specific # case. if (nint((W_XE(wdpix)-W_XS(wdpix))-(W_XE(wipix)-W_XS(wipix))) == 1) W_XE(wdpix) = W_XE(wdpix) - 1 if (nint((W_YE(wdpix)-W_YS(wdpix))-(W_YE(wipix)-W_YS(wipix))) == 1) W_YE(wdpix) = W_YE(wdpix) - 1 # Now adjust the display window to be consistent with the image and # display pixels to be used. W_XS(wdwin) = W_XS(wnwin) * IM_LEN(ds,1) + 0.5 W_XE(wdwin) = W_XE(wnwin) * IM_LEN(ds,1) + 0.5 W_YS(wdwin) = W_YS(wnwin) * IM_LEN(ds,2) + 0.5 W_YE(wdwin) = W_YE(wnwin) * IM_LEN(ds,2) + 0.5 W_XS(wdwin) = (W_XS(wipix)-0.5) + (W_XS(wdwin)-(W_XS(wdpix)-0.5))/xmag W_XE(wdwin) = (W_XS(wipix)-0.5) + (W_XE(wdwin)-(W_XS(wdpix)-0.5))/xmag W_YS(wdwin) = (W_YS(wipix)-0.5) + (W_YS(wdwin)-(W_YS(wdpix)-0.5))/ymag W_YE(wdwin) = (W_YS(wipix)-0.5) + (W_YE(wdwin)-(W_YS(wdpix)-0.5))/ymag if (im != NULL) { # Order of interpolator used for spatial transformation. W_XT(wdwin) = max(0, min(1, clgeti ("order"))) W_YT(wdwin) = W_XT(wdwin) # Determine the greyscale transformation. call clgstr ("ztrans", Memc[ztrans], SZ_FNAME) if (streq (Memc[ztrans], "log")) W_ZT(wdwin) = W_LOG else if (streq (Memc[ztrans], "linear")) W_ZT(wdwin) = W_LINEAR else if (streq (Memc[ztrans], "none")) W_ZT(wdwin) = W_UNITARY else if (streq (Memc[ztrans], "user")) { W_ZT(wdwin) = W_USER call salloc (lutfile, SZ_FNAME, TY_CHAR) call clgstr ("lutfile", Memc[lutfile], SZ_FNAME) W_UPTR(wdwin) = ds_ulutalloc (Memc[lutfile], z1, z2) } else { call eprintf ("Bad greylevel transformation '%s'\n") call pargstr (Memc[ztrans]) W_ZT(wdwin) = W_LINEAR } # The zscale, and zrange parameters determine the algorithms for # determining Z1 and Z2, the range of input z values to be mapped # into the fixed range of display greylevels. If sampling and no # sample mask is given then create one as a subsampled image section. # If greyscale mapping is disabled the zscale and zrange options are # disabled. Greyscale mapping can also be disabled by turning off # zscale and zrange and setting Z1 and Z2 to the device greyscale min # and max values, producing a unitary transformation. if (W_ZT(wdwin) == W_UNITARY || W_ZT(wdwin) == W_USER) { zscale_flag = false zrange_flag = false zmap_flag = false } else { zmap_flag = true zscale_flag = clgetb ("zscale") if (!zscale_flag) zrange_flag = clgetb ("zrange") } if (zscale_flag || (zrange_flag && IM_LIMTIME(im) < IM_MTIME(im))) { call clgstr ("zmask", W_ZPM(wdes), W_SZSTRING) nsample = max (100, clgeti ("nsample")) if (nowhite (W_ZPM(wdes), W_ZPM(wdes), W_SZSTRING) > 0) { if (W_ZPM(wdes) == '[') zpm = zsc_pmsection (W_ZPM(wdes), im) else zpm = yt_pmmap (W_ZPM(wdes), im, Memc[str], SZ_LINE) } else zpm = NULL iferr (bpm = yt_pmmap (W_BPM(wdes), im, Memc[str], SZ_LINE)) { call erract (EA_WARN) bpm = NULL } } if (zscale_flag) { # Autoscaling is desired. Compute Z1 and Z2 which straddle the # median computed by sampling a portion of the image. contrast = clgetr ("contrast") call msc_mzscale (mg, zpm, bpm, contrast, nsample, z1, z2) if (zpm != NULL) call imunmap (zpm) if (bpm != NULL) call imunmap (bpm) } else if (zrange_flag) { # Use the limits in the header if current otherwise get the # minimum and maximum of the sample mask. if (IM_LIMTIME(im) >= IM_MTIME(im)) { z1 = IM_MIN(im) z2 = IM_MAX(im) } else { call msc_mzscale (mg, zpm, bpm, 0., nsample, z1, z2) if (zpm != NULL) call imunmap (zpm) if (bpm != NULL) call imunmap (bpm) } } else if (zmap_flag) { #z1 = clgetr ("z1") #z2 = clgetr ("z2") } else { z1 = IM_MIN(ds) z2 = IM_MAX(ds) } W_ZS(wdwin) = z1 W_ZE(wdwin) = z2 #call printf ("z1=%g z2=%g\n") # call pargr (W_ZS(wdwin)) # call pargr (W_ZE(wdwin)) #call flush (STDOUT) } # The user world coordinate system should be set from the CTRAN # structure in the image header, but for now we just make it equal # to the pixel coordinate system. call amovi (Memi[wdwin], Memi[wwwin], LEN_WC) W_UPTR(wwwin) = NULL # should not copy pointers!! call sfree (sp) end # MZSCALE -- Sample an image with pixel masks and compute greyscale limits. # The image is sampled through a pixel mask. If no pixel mask is given # a uniform sample mask is generated. If a bad pixel mask is given # bad pixels in the sample are eliminated. Once the sample is obtained # the greyscale limits are obtained using the ZSC_ZLIMITS algorithm. procedure msc_mzscale (mg, zpm, bpm, contrast, maxpix, z1, z2) pointer mg #I image to be sampled pointer zpm #I pixel mask for sampling pointer bpm #I bad pixel mask real contrast #I contrast parameter int maxpix #I maximum number of pixels in sample real z1, z2 #O output min and max greyscale values int i, ndim, nc, nl, dx1, dx2, dy1, dy2, npix, nbp, imstati() pointer sp, section, v, sample, zmask, bp, zim, pmz, pmb, buf, im pointer zsc_pmsection(), mscnlr() bool pm_linenotempty() errchk zsc_pmsection, zsc_zlimits begin call smark (sp) call salloc (section, SZ_FNAME, TY_CHAR) call salloc (v, IM_MAXDIM, TY_LONG) call salloc (sample, maxpix, TY_REAL) zmask = NULL bp = NULL im = MG_IM(mg) ndim = min (2, IM_NDIM(im)) nc = IM_LEN(im,1) nl = IM_LEN(im,2) dx1 = DX1(mg) dx2 = DX2(mg) dy1 = DY1(mg) dy2 = DY2(mg) # Generate a uniform sample mask if none is given. if (zpm == NULL) { switch (IM_NDIM(im)) { case 1: call sprintf (Memc[section], SZ_FNAME, "[%d:%d]") call pargi (dx1) call pargi (dx2) default: i = max (1., sqrt ((dx2-dx1)*(dy2-dy1) / real (maxpix))) call sprintf (Memc[section], SZ_FNAME, "[%d:%d:%d,%d:%d:%d]") call pargi (dx1+i/2) call pargi (dx2-i/2) call pargi (i) call pargi (dy1+i/2) call pargi (dy2-i/2) call pargi (i) } zim = zsc_pmsection (Memc[section], im) pmz = imstati (zim, IM_PMDES) } else pmz = imstati (zpm, IM_PMDES) # Set bad pixel mask. if (bpm != NULL) pmb = imstati (bpm, IM_PMDES) else pmb = NULL # Get the sample up to maxpix pixels. npix = 0 nbp = 0 call amovkl (long(1), Memi[v], IM_MAXDIM) repeat { if (pm_linenotempty (pmz, Meml[v])) { if (zmask == NULL) call salloc (zmask, nc, TY_INT) call pmglpi (pmz, Meml[v], Memi[zmask], 0, nc, 0) if (pmb != NULL) { if (pm_linenotempty (pmb, Meml[v])) { if (bp == NULL) call salloc (bp, nc, TY_INT) call pmglpi (pmb, Meml[v], Memi[bp], 0, nc, 0) nbp = nc } else nbp = 0 } if (mscnlr (mg, buf, Meml[v]) == EOF) break if (NODATA(mg) == YES) break do i = 0, nc-1 { if (Memi[zmask+i] == 0) next if (nbp > 0) if (Memi[bp+i] != 0) next Memr[sample+npix] = Memr[buf+i] npix = npix + 1 if (npix == maxpix) break } if (npix == maxpix) break } else { do i = 2, ndim { Meml[v+i-1] = Meml[v+i-1] + 1 if (Meml[v+i-1] <= IM_LEN(im,i)) break else if (i < ndim) Meml[v+i-1] = 1 } } } until (Meml[v+ndim-1] > IM_LEN(im,ndim)) if (npix == 0) { Memi[v+1] = IM_LEN(im,2) repeat { if (pm_linenotempty (pmz, Meml[v])) { if (zmask == NULL) call salloc (zmask, nc, TY_INT) call pmglpi (pmz, Meml[v], Memi[zmask], 0, nc, 0) if (pmb != NULL) { if (pm_linenotempty (pmb, Meml[v])) { if (bp == NULL) call salloc (bp, nc, TY_INT) call pmglpi (pmb, Meml[v], Memi[bp], 0, nc, 0) nbp = nc } else nbp = 0 } if (mscnlr (mg, buf, Meml[v]) == EOF) break Meml[v+1] = Meml[v+1] - 2 if (NODATA(mg) == YES) break do i = 0, nc-1 { if (Memi[zmask+i] == 0) next if (nbp > 0) if (Memi[bp+i] != 0) next Memr[sample+npix] = Memr[buf+i] npix = npix + 1 if (npix == maxpix) break } if (npix == maxpix) break } else { Meml[v+1] = Meml[v+1] - 1 } } until (Meml[v+1] == 0) } if (zpm == NULL) call imunmap (zim) # Compute greyscale limits. call zsc_zlimits (Memr[sample], npix, contrast, z1, z2) call sfree (sp) end # MSC_LOAD_DISPLAY -- Map an image into the display window. In general this # involves independent linear transformations in the X, Y, and Z (greyscale) # dimensions. If a spatial dimension is larger than the display window then # the image is block averaged. If a spatial dimension or a block averaged # dimension is smaller than the display window then linear interpolation is # used to expand the image. Both the input image and the output device appear # to us as images, accessed via IMIO. All spatial scaling is # handled by the "scaled input" package, i.e., SIGM2[SR]. Our task is to # get lines from the scaled input image, transform the greyscale if necessary, # and write the lines to the output device. procedure msc_load_display (mg, ds, dsbuf, wdes) pointer mg # input image pointer ds # output image pointer dsbuf # display buffer pointer wdes # graphics window descriptor real z1, z2, dz1, dz2, px1, px2, py1, py2 int i, order, zt, wx1, wx2, wy1, wy2, wy, nx, ny, xblk, yblk, nxds, nyds int color pointer wdwin, wipix, wdpix, ovrly, bpm, pm, uptr pointer im, in, out, si, si_ovrly, si_bpovrly, ocolors, bpcolors, rtemp pointer sp, fname bool unitary_greyscale_transformation short lut1, lut2, dz1_s, dz2_s, z1_s, z2_s real logerrfcn() bool fp_equalr() int imstati(), xmaskcolor() pointer yt_pmmap(), imps2s(), imps2r() pointer yigm2i(), zigm2_setup(), zigm2s(), zigm2r() errchk yt_pmmap, imps2s, imps2r, yigm2i, zigm2_setup, zigm2s, zigm2r errchk xmaskexprn extern logerrfcn begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) im = MG_IM(mg) wdwin = W_WC(wdes,W_DWIN) wipix = W_WC(wdes,W_IPIX) wdpix = W_WC(wdes,W_DPIX) # Set image and display pixels. px1 = nint (W_XS(wipix)) px2 = nint (W_XE(wipix)) py1 = nint (W_YS(wipix)) py2 = nint (W_YE(wipix)) wx1 = nint (W_XS(wdpix)) wx2 = nint (W_XE(wdpix)) wy1 = nint (W_YS(wdpix)) wy2 = nint (W_YE(wdpix)) z1 = W_ZS(wdwin) z2 = W_ZE(wdwin) zt = W_ZT(wdwin) uptr = W_UPTR(wdwin) order = max (W_XT(wdwin), W_YT(wdwin)) # Setup scaled input and masks. si = NULL si_ovrly = NULL si_bpovrly = NULL nx = wx2 - wx1 + 1 ny = wy2 - wy1 + 1 xblk = INDEFI yblk = INDEFI ocolors = W_OCOLORS(wdes) iferr (ovrly = yt_pmmap (W_OVRLY(wdes), im, Memc[fname], SZ_FNAME)) { call erract (EA_WARN) ovrly = NULL } if (ovrly != NULL) { xblk = INDEFI yblk = INDEFI si_ovrly = zigm2_setup (ovrly, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, -1) } bpcolors = W_BPCOLORS(wdes) switch (W_BPDISP(wdes)) { case BPDNONE: si = zigm2_setup (im, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, order) case BPDOVRLY: si = zigm2_setup (im, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, order) iferr (bpm = yt_pmmap (W_BPM(wdes), im, Memc[fname], SZ_FNAME)) bpm = NULL if (bpm != NULL) si_bpovrly = zigm2_setup (bpm, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, -1) case BPDINTERP: iferr (bpm = yt_pmmap (W_BPM(wdes), im, Memc[fname], SZ_FNAME)) bpm = NULL if (bpm != NULL) pm = imstati (bpm, IM_PMDES) else pm = NULL si = zigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) } # The device IM_MIN and IM_MAX parameters define the acceptable range # of greyscale values for the output device (e.g., 0-255 for most 8-bit # display devices). Values Z1 and Z2 are mapped linearly or # logarithmically into IM_MIN and IM_MAX. nxds = IM_LEN(ds,1) nyds = IM_LEN(ds,2) dz1 = IM_MIN(ds) dz2 = IM_MAX(ds) if (fp_equalr (z1, z2)) { z1 = z1 - 1 z2 = z2 + 1 } # If the user specifies the transfer function, verify that the # intensity and greyscale are in range. if (zt == W_USER) { call alims (Mems[uptr], U_MAXPTS, lut1, lut2) dz1_s = short (dz1) dz2_s = short (dz2) if (lut2 < dz1_s || lut1 > dz2_s) call eprintf ("User specified greyscales out of range\n") if (z2 < IM_MIN(im) || z1 > IM_MAX(im)) call eprintf ("User specified intensities out of range\n") } # Type short pixels are treated as a special case to minimize vector # operations for such images (which are common). If the image pixels # are either short or real then only the ALTR (greyscale transformation) # vector operation is required. The ALTR operator linearly maps # greylevels in the range Z1:Z2 to DZ1:DZ2, and does a floor ceiling # of DZ1:DZ2 on all pixels outside the range. If unity mapping is # employed the data is simply copied, i.e., floor ceiling constraints # are not applied. This is very fast and will produce a contoured # image on the display which will be adequate for some applications. if (zt == W_UNITARY) { unitary_greyscale_transformation = true } else if (zt == W_LINEAR) { unitary_greyscale_transformation = (fp_equalr(z1,dz1) && fp_equalr(z2,dz2)) } else unitary_greyscale_transformation = false if (IM_PIXTYPE(im) == TY_SHORT && PROC(mg) == NO && zt != W_LOG) { z1_s = z1; z2_s = z2 if (z1_s == z2_s) { z1_s = z1_s - 1 z2_s = z2_s + 1 } for (wy=wy1; wy <= wy2; wy=wy+1) { in = zigm2s (mg, si, wy - wy1 + 1) if (dsbuf == NULL) out = imps2s (ds, wx1, wx2, wy, wy) else out = dsbuf + (wy - 1) * nxds + wx1 - 1 if (unitary_greyscale_transformation) { call amovs (Mems[in], Mems[out], nx) } else if (zt == W_USER) { dz1_s = U_Z1; dz2_s = U_Z2 call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s, dz2_s) call aluts (Mems[out], Mems[out], nx, Mems[uptr]) } else { dz1_s = dz1; dz2_s = dz2 call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s, dz2_s) } if (si_ovrly != NULL) { in = yigm2i (si_ovrly, wy - wy1 + 1) call xmaskexprn (ocolors, in, nx) do i = 0, nx-1 { if (Memi[in+i] != 0) { color = xmaskcolor (ocolors, Memi[in+i]) if (color >= 0) Mems[out+i] = color } } } if (si_bpovrly != NULL) { in = yigm2i (si_bpovrly, wy - wy1 + 1) call xmaskexprn (ocolors, in, nx) do i = 0, nx-1 { if (Memi[in+i] != 0) { color = xmaskcolor (ocolors, Memi[in+i]) if (color >= 0) Mems[out+i] = color } } } } } else if (zt == W_USER) { call salloc (rtemp, nx, TY_REAL) for (wy=wy1; wy <= wy2; wy=wy+1) { in = zigm2r (mg, si, wy - wy1 + 1) if (dsbuf == NULL) out = imps2s (ds, wx1, wx2, wy, wy) else out = dsbuf + (wy - 1) * nxds + wx1 - 1 call amapr (Memr[in], Memr[rtemp], nx, z1, z2, real(U_Z1), real(U_Z2)) call achtrs (Memr[rtemp], Mems[out], nx) call aluts (Mems[out], Mems[out], nx, Mems[uptr]) if (si_ovrly != NULL) { in = yigm2i (si_ovrly, wy - wy1 + 1) call xmaskexprn (ocolors, in, nx) do i = 0, nx-1 { if (Memi[in+i] != 0) { color = xmaskcolor (ocolors, Memi[in+i]) if (color >= 0) Mems[out+i] = color } } } if (si_bpovrly != NULL) { in = yigm2i (si_bpovrly, wy - wy1 + 1) call xmaskexprn (ocolors, in, nx) do i = 0, nx-1 { if (Memi[in+i] != 0) { color = xmaskcolor (ocolors, Memi[in+i]) if (color >= 0) Mems[out+i] = color } } } } } else { if (dsbuf != NULL) call malloc (out, nx, TY_REAL) for (wy=wy1; wy <= wy2; wy=wy+1) { in = zigm2r (mg, si, wy - wy1 + 1) if (dsbuf == NULL) out = imps2r (ds, wx1, wx2, wy, wy) if (unitary_greyscale_transformation) { call amovr (Memr[in], Memr[out], nx) } else if (zt == W_LOG) { call amapr (Memr[in], Memr[out], nx, z1, z2, 1.0, 10.0 ** MAXLOG) call alogr (Memr[out], Memr[out], nx, logerrfcn) call amapr (Memr[out], Memr[out], nx, 0.0, real(MAXLOG), dz1, dz2) } else call amapr (Memr[in], Memr[out], nx, z1, z2, dz1, dz2) if (si_ovrly != NULL) { in = yigm2i (si_ovrly, wy - wy1 + 1) call xmaskexprn (ocolors, in, nx) do i = 0, nx-1 { if (Memi[in+i] != 0) { color = xmaskcolor (ocolors, Memi[in+i]) if (color >= 0) Memr[out+i] = color } } } if (si_bpovrly != NULL) { in = yigm2i (si_bpovrly, wy - wy1 + 1) call xmaskexprn (ocolors, in, nx) do i = 0, nx-1 { if (Memi[in+i] != 0) { color = xmaskcolor (ocolors, Memi[in+i]) if (color >= 0) Memr[out+i] = color } } } if (dsbuf != NULL) call achtrs (Memr[out], Mems[dsbuf+(wy-1)*nxds+wx1-1], nx) } if (dsbuf != NULL) call mfree (out, TY_REAL) } call sigm2_free (si) if (si_ovrly != NULL) call sigm2_free (si_ovrly) if (si_bpovrly != NULL) call sigm2_free (si_bpovrly) if (ovrly != NULL) call imunmap (ovrly) if (bpm != NULL) call imunmap (bpm) call sfree (sp) end # LOGERRFCN -- Error function value for out of range input. real procedure logerrfcn (x) real x begin return (-MAX_REAL) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/t_mscrtdisp.x���������������������������������������������0000664�0000000�0000000�00000056516�13321663143�0022255�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include include include include include include "mosim.h" include "mosgeom.h" include "mosproc.h" include "display.h" include "gwindow.h" # ZCOMBINE options. define ZC_DICT "|none|auto|minmax|average|median|" define ZC_NONE 1 define ZC_AUTO 2 define ZC_MINMAX 3 define ZC_AVERAGE 4 define ZC_MEDIAN 5 # ADU to/from e- options. define UNCORRECT 0 define CORRECT 1 # T_MSCRTDISPLAY -- Quick-look real-time mosaic display task. # This version checks for lines with no data and iterates waiting # for more data to appear. procedure t_mscrtdisplay () bool zmap, firsttime int i, j, k, wcsver, frame, ninput, nproc, zcom, select int nx[2], ny[2] int nit, sleep, y1last, y2last, ndone, stalled real xc, yc, xs[2], ys[2], a, b, c, d, tx, ty, zz1, zz2 pointer sp, image, image1, title, procstr, imtitle, wcs, y1, y2, done pointer z1, z2, wdes, mi, mg, cmg, ds, im, wipix, wdpix, wnwin, wdwin bool clgetb(), fp_equalr(), streq(), hdmflag() int clgeti(), clgwrd(), btoi(), access(), imstati(), imd_wcsver() int imtlen(), imtgetim() real clgetr(), ahivr(), alovr(), asumr(), amedr() pointer mimap(), immap(), imd_mapframe1(), iw_open(), imtopenp() include "mosproc.com" begin call tsleep (clgeti ("wait")) call smark (sp) call salloc (image, SZ_LINE, TY_CHAR) call salloc (image1, SZ_LINE, TY_CHAR) call salloc (title, SZ_LINE, TY_CHAR) call salloc (procstr, SZ_LINE, TY_CHAR) call salloc (imtitle, SZ_LINE, TY_CHAR) call salloc (wcs, SZ_LINE, TY_CHAR) # Set instrument, amplifier, and process information. #call clgstr ("instrument", Memc[image1], SZ_LINE) Memc[image1] = EOS call hdmopen (Memc[image1]) call ampset() call procset() # Initialize multiple mappings. wcsver = imd_wcsver() # Get image. im = imtopenp ("image") if (imtlen (im) != 1) call error (1, "Only one image may be displayed") i = imtgetim (im, Memc[image], SZ_LINE) call imtclose (im) frame = clgeti ("frame") if ((wcsver == 0 && frame > 4) || frame > 16) call error (1, "Frame number too large for display server") select = btoi (clgetb ("select_frame")) nit = clgeti ("niterate") sleep = clgeti ("sleep") call sprintf (Memc[wcs], SZ_LINE, "uparm$mscdisp%d") call pargi (frame) # Check if already loaded. if (clgetb ("check")) { if (access (Memc[wcs], 0, 0) == YES) { ds = imd_mapframe1 (frame, READ_ONLY, select, NO) im = iw_open (ds, frame, Memc[image1], SZ_LINE, i) call iw_close (im) call imunmap (ds) if (i != ERR) { if (streq (Memc[image], Memc[image1])) { call miunmap (mi) call hdmclose () call ampfree() call sfree (sp) return } } } } # Map mosaic image. iferr (mi = mimap (Memc[image], READ_ONLY, 0)) { call sfree (sp) call hdmclose() call erract (EA_ERROR) } ninput = MI_NIMS(mi) cmg = MI_CMG(mi) # Set real time data checking. do i = 1, ninput CKNODATA(MI_MG(mi,i)) = YES # Allocate memory for each input image. call salloc (done, ninput, TY_INT) call salloc (y1, ninput, TY_INT) call salloc (y2, ninput, TY_INT) call salloc (z1, ninput, TY_REAL) call salloc (z2, ninput, TY_REAL) call salloc (wdes, ninput+1, TY_POINTER) do i = 0, ninput { call salloc (Memi[wdes+i], LEN_WDES, TY_STRUCT) call aclri (Memi[Memi[wdes+i]], LEN_WDES) } # Convert default z values given in e- to uncorrected (input) ADU. call amovkr (clgetr ("z1"), Memr[z1], ninput) call amovkr (clgetr ("z2"), Memr[z2], ninput) call zproc (Memi[MI_MGS(mi)], Memr[z1], Memr[z2], ninput, proc, UNCORRECT) # Open display without erasing yet. ds = imd_mapframe1 (frame, READ_ONLY, NO, NO) # Determine parameters for the output display. if (clgetb ("fill")) call mos_params (NULL, ds, Memi[wdes], 1, NX(cmg), 1, 1, NY(cmg), 1, 0.5, 0.5, 1.0, 1.0, 0., 0.) else { mg = MI_MG(mi,1) xs[1] = real (NX(cmg)) / abs (DX(mg)) / IM_LEN(ds,1) ys[1] = real (NY(cmg)) / abs (DY(mg)) / IM_LEN(ds,2) i = max (1000 - int (1000. - xs[1]), 1000 - int (1000. - ys[1])) xs[1] = xs[1] / i ys[1] = ys[1] / i call mos_params (NULL, ds, Memi[wdes], 1, NX(cmg), 1, 1, NY(cmg), 1, 0.5, 0.5, xs, ys, 0., 0.) } firsttime = true stalled = 0 repeat { # Determine parameters for each input image. nproc = 0 do i = 1, ninput { mg = MI_MG(mi,i) im = MI_IM(mi,i) # Set display window for image. call mos_comap (Memi[wdes], mg, cmg, xc, yc, xs, ys) # Set display parameters for image. call mos_params (mg, ds, Memi[wdes+i], DX1(mg), DX2(mg), abs(DX(mg)), DY1(mg), DY2(mg), abs(DY(mg)), xc, yc, xs, ys, Memr[z1+i-1], Memr[z2+i-1]) if (PROC(mg) == YES) nproc = nproc + 1 # Initialize to display the whole image. Memi[y1+i-1] = INDEFI Memi[y2+i-1] = INDEFI Memi[done+i-1] = NO } # Combine the z levels if needed. Do things in e-. call zproc (Memi[MI_MGS(mi)], Memr[z1], Memr[z2], ninput, proc, CORRECT) zz1 = asumr (Memr[z1], ninput) / ninput zz2 = asumr (Memr[z2], ninput) / ninput zmap = false do i = 1, ninput if (!fp_equalr(Memr[z1+i-1],zz1) || !fp_equalr(Memr[z2+i-1],zz2)) { zmap = true break } if (zmap) { zcom = clgwrd ("zcombine", Memc[image1], SZ_LINE, ZC_DICT) if (zcom == ZC_AUTO) { zcom = ZC_MINMAX do i = 1, ninput { mg = MI_MG(mi,i) im = MI_IM(mi,i) if (!hdmflag (im, "flatcor")) { if (PROC(mg) == NO || (PROC(mg) == YES && DOFLAT(mg) == NO)) { zcom = ZC_NONE break } } } } if (zcom != ZC_NONE) { switch (zcom) { case ZC_MINMAX: zz1 = alovr (Memr[z1], ninput) zz2 = ahivr (Memr[z2], ninput) case ZC_AVERAGE: zz1 = asumr (Memr[z1], ninput) / ninput zz2 = asumr (Memr[z2], ninput) / ninput case ZC_MEDIAN: zz1 = amedr (Memr[z1], ninput) zz2 = amedr (Memr[z2], ninput) } # Now set the values for display. call zproc (Memi[MI_MGS(mi)], zz1, zz2, 1, proc, UNCORRECT) do i = 1, ninput { wdwin = W_WC(Memi[wdes+i],W_DWIN) W_ZS(wdwin) = zz1 W_ZE(wdwin) = zz2 } call zproc (Memi[MI_MGS(mi)], zz1, zz2, 1, proc, CORRECT) } } # Print out some useful information call printf ("\n\n") call mos_info (mi, wdes, zcom, Memr[z1], Memr[z2], STDOUT) if (firsttime) { # Print tile information. call msctile (mi, Memc[wcs], frame, wcsver) # Now we're ready to write to the display. call imunmap (ds) ds = imd_mapframe1 (frame, READ_WRITE, select, btoi (clgetb ("erase"))) # Set WCS. do k = 1, ninput+1 { i = mod (k, ninput+1) j = max (i, 1) wipix = W_WC(Memi[wdes+i],W_IPIX) wdpix = W_WC(Memi[wdes+i],W_DPIX) wnwin = W_WC(Memi[wdes+i],W_NWIN) wdwin = W_WC(Memi[wdes+i],W_DWIN) # Define mapping from image pixels to display pixels. xs[1] = W_XS(wipix) ys[1] = W_YS(wipix) nx[1] = W_XE(wipix) - W_XS(wipix) + 1 ny[1] = W_YE(wipix) - W_YS(wipix) + 1 xs[2] = W_XS(wdpix) ys[2] = W_YS(wdpix) nx[2] = W_XE(wdpix) - W_XS(wdpix) + 1 ny[2] = W_YE(wdpix) - W_YS(wdpix) + 1 if (i > 0) { call imstats (MI_IM(mi,i), IM_IMAGENAME, Memc[image1], SZ_LINE) iferr (call imgstr (MI_IM(mi,i), "EXTNAME", Memc[wcs], SZ_LINE)) { call sprintf (Memc[wcs], SZ_LINE, "%d") call pargi (i) } } else { call strcpy (Memc[MI_RNAME(mi)], Memc[image1], SZ_LINE) call strcpy ("mosaic", Memc[wcs], SZ_LINE) } call fpathname (Memc[image1], Memc[image1], SZ_LINE) call imd_setmapping (Memc[wcs], xs[1], ys[1], nx[1], ny[1], nint(xs[2]), nint(ys[2]), nx[2], ny[2], Memc[image1]) # Define linear pixel WCS. a = (W_XE(wdwin)-W_XS(wdwin))/((W_XE(wnwin)-W_XS(wnwin))* IM_LEN(ds,1)) b = 0.0 c = 0.0 d = (W_YE(wdwin)-W_YS(wdwin))/((W_YE(wnwin)-W_YS(wnwin))* IM_LEN(ds,2)) tx = W_XS(wdwin) - a * (W_XS(wnwin) * IM_LEN(ds,1)) ty = W_YS(wdwin) - d * (W_YS(wnwin) * IM_LEN(ds,2)) # Y-flip (origin at upper left in display window). d = -d ty = W_YE(wdwin) - d * ((1.0 - W_YE(wnwin)) * IM_LEN(ds,2)) # Translate screen corner to the center of the screen pixel. tx = tx + 0.5 * a ty = ty + 0.5 * d # Set origin to mosaic coordinates. tx = tx + CX1(cmg) - 1 ty = ty + CY1(cmg) - 1 # Set the title and WCS. if (nproc > 0) { mg = MI_MG(mi,j) if (DOBIAS(mg)==YES || DOZERO(mg)==YES || DOFLAT(mg)==YES) { Memc[title] = EOS if (DOBIAS(mg) == YES) { call sprintf (Memc[procstr], SZ_LINE, ",bias") call strcat (Memc[procstr], Memc[title], SZ_LINE) } if (DOZERO(mg) == YES) { call sprintf (Memc[procstr], SZ_LINE, ",zero=%s") call pargstr (ZERONAME(mg)) call strcat (Memc[procstr], Memc[title], SZ_LINE) } if (DOFLAT(mg) == YES) { call sprintf (Memc[procstr], SZ_LINE, ",flat=%s") call pargstr (FLATNAME(mg)) call strcat (Memc[procstr], Memc[title], SZ_LINE) } call sprintf (Memc[procstr], SZ_LINE, "] %s") call pargstr (IM_TITLE(MI_IM(mi,j))) call strcat (Memc[procstr], Memc[title], SZ_LINE) Memc[title] = '[' } else { call sprintf (Memc[title], SZ_LINE, "[process] %s") call pargstr (IM_TITLE(MI_IM(mi,j))) } } else call strcpy (IM_TITLE(MI_IM(mi,j)), Memc[title], SZ_LINE) call imd_putwcs (ds, frame, Memc[MI_RNAME(mi)], Memc[title], a, b, c, d, tx, ty, zz1, zz2, W_ZT(W_WC(Memi[wdes+j],W_DWIN))) } firsttime = false } # Now display the images. for (j=1; j<=nit; j=j+1) { ndone = 0 do i = 1, ninput { if (Memi[done+i-1] == NO) { mg = MI_MG(mi,i) im = MI_IM(mi,i) #call imstats (im, IM_IMAGENAME, Memc[image1], SZ_LINE) #call ds_setwcs (im, ds, Memi[wdes+i], Memc[image1], # frame) y1last = Memi[y1+i-1] y2last = Memi[y2+i-1] call msc_rtload_display (mg, ds, Memi[wdes+i], Memi[y1+i-1], Memi[y2+i-1], Memi[done+i-1]) if (Memi[y1+i-1] == y1last && Memi[y2+i-1] == y2last) stalled = stalled + 1 else stalled = 0 } if (Memi[done+i-1] == YES) ndone = ndone + 1 else { call imseti (im, IM_CANCEL, 0) call fseti (imstati (im, IM_PIXFD), F_CANCEL, 0) } } if (ndone == ninput) break if (stalled / ninput > 0) { if (stalled / ninput > 10) break call tsleep (stalled / ninput) } else if (ndone == 0) { if (j < nit) call tsleep (max(1,sleep)) } else { call tsleep (1) j = j - 1 } } if (ndone == ninput || stalled / ninput > 0) break } # Check the title and try several times if there is no title. if (Memc[imtitle] == EOS) { call sprintf (Memc[image1], SZ_LINE, "%s[1]") call pargstr (Memc[image]) do i = 0, 3 { call tsleep (i) call imunmap (MI_IM(mi,1)) MI_IM(mi,1) = immap (Memc[image1], READ_ONLY, 0) call strcpy (IM_TITLE(MI_IM(mi,1)), Memc[imtitle], SZ_LINE) if (Memc[imtitle] != EOS) break } if (nproc > 0) { mg = MI_MG(mi,1) if (DOBIAS(mg) == YES && DOFLAT(mg) == YES) { call sprintf (Memc[title], SZ_LINE, "[bias,flat=%s] %s") call pargstr (FLATNAME(mg)) call pargstr (Memc[imtitle]) } else if (DOBIAS(mg) == YES) { call sprintf (Memc[title], SZ_LINE, "[bias] %s") call pargstr (Memc[imtitle]) } else if (DOFLAT(mg) == YES) { call sprintf (Memc[title], SZ_LINE, "[flat=%s] %s") call pargstr (FLATNAME(mg)) call pargstr (Memc[imtitle]) } else { call sprintf (Memc[title], SZ_LINE, "[process] %s") call pargstr (Memc[imtitle]) } } else call strcpy (Memc[imtitle], Memc[title], SZ_LINE) call imd_putwcs (ds, frame, Memc[MI_RNAME(mi)], Memc[title], a, b, c, d, tx, ty, zz1, zz2, W_ZT(W_WC(Memi[wdes+1],1))) } # Tidy up do i = 0, ninput { do j = 0, W_MAXWC if (W_UPTR(W_WC(Memi[wdes+i],j)) != NULL) call ds_ulutfree (W_UPTR(W_WC(Memi[wdes+i],j))) } call miunmap (mi) call imunmap (ds) call hdmclose () call ampfree() call sfree (sp) end # MSC_LOAD_DISPLAY -- Map an image into the display window. In general this # involves independent linear transformations in the X, Y, and Z (greyscale) # dimensions. If a spatial dimension is larger than the display window then # the image is block averaged. If a spatial dimension or a block averaged # dimension is smaller than the display window then linear interpolation is # used to expand the image. Both the input image and the output device appear # to us as images, accessed via IMIO. All spatial scaling is # handled by the "scaled input" package, i.e., SIGM2[SR]. Our task is to # get lines from the scaled input image, transform the greyscale if necessary, # and write the lines to the output device. procedure msc_rtload_display (mg, ds, wdes, y1, y2, done) pointer mg # input image pointer ds # output image pointer wdes # graphics window descriptor int y1, y2 # last data displayed int done # done? real z1, z2, dz1, dz2, px1, px2, py1, py2 int i, order, zt, wx1, wx2, wy1, wy2, wy, nx, ny, xblk, yblk pointer wdwin, wipix, wdpix, ovrly, bpm, pm, uptr pointer im, in, out, si, si_ovrly, si_bpovrly, ocolors, bpcolors, rtemp pointer sp, fname bool unitary_greyscale_transformation short lut1, lut2, dz1_s, dz2_s, z1_s, z2_s real logerrfcn() bool fp_equalr() int imstati(), maskcolor() pointer yt_pmmap(), imps2s(), imps2r() pointer yigm2s(), zigm2_setup(), zigm2s(), zigm2r() errchk yt_pmmap, imps2s, imps2r, yigm2s, zigm2_setup, zigm2s, zigm2r extern logerrfcn begin call smark (sp) call salloc (fname, SZ_FNAME, TY_CHAR) im = MG_IM(mg) wdwin = W_WC(wdes,W_DWIN) wipix = W_WC(wdes,W_IPIX) wdpix = W_WC(wdes,W_DPIX) # Set image and display pixels. px1 = nint (W_XS(wipix)) px2 = nint (W_XE(wipix)) py1 = nint (W_YS(wipix)) py2 = nint (W_YE(wipix)) wx1 = nint (W_XS(wdpix)) wx2 = nint (W_XE(wdpix)) wy1 = nint (W_YS(wdpix)) wy2 = nint (W_YE(wdpix)) if (IS_INDEFI(y1)) { y2 = wy1 - 1 y1 = wy2 + 1 } z1 = W_ZS(wdwin) z2 = W_ZE(wdwin) zt = W_ZT(wdwin) uptr = W_UPTR(wdwin) order = max (W_XT(wdwin), W_YT(wdwin)) # Setup scaled input and masks. si = NULL si_ovrly = NULL si_bpovrly = NULL nx = wx2 - wx1 + 1 ny = wy2 - wy1 + 1 xblk = INDEFI yblk = INDEFI ocolors = W_OCOLORS(wdes) iferr (ovrly = yt_pmmap (W_OVRLY(wdes), im, Memc[fname], SZ_FNAME)) { call erract (EA_WARN) ovrly = NULL } if (ovrly != NULL) { xblk = INDEFI yblk = INDEFI si_ovrly = zigm2_setup (ovrly, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, -1) } bpcolors = W_BPCOLORS(wdes) switch (W_BPDISP(wdes)) { case BPDNONE: si = zigm2_setup (im, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, order) case BPDOVRLY: si = zigm2_setup (im, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, order) iferr (bpm = yt_pmmap (W_BPM(wdes), im, Memc[fname], SZ_FNAME)) bpm = NULL if (bpm != NULL) si_bpovrly = zigm2_setup (bpm, NULL, px1,px2,nx,xblk, py1,py2,ny,yblk, -1) case BPDINTERP: iferr (bpm = yt_pmmap (W_BPM(wdes), im, Memc[fname], SZ_FNAME)) bpm = NULL if (bpm != NULL) pm = imstati (bpm, IM_PMDES) else pm = NULL si = zigm2_setup (im, pm, px1,px2,nx,xblk, py1,py2,ny,yblk, order) } # The device IM_MIN and IM_MAX parameters define the acceptable range # of greyscale values for the output device (e.g., 0-255 for most 8-bit # display devices). Values Z1 and Z2 are mapped linearly or # logarithmically into IM_MIN and IM_MAX. dz1 = IM_MIN(ds) dz2 = IM_MAX(ds) if (fp_equalr (z1, z2)) { z1 = z1 - 1 z2 = z2 + 1 } # If the user specifies the transfer function, verify that the # intensity and greyscale are in range. if (zt == W_USER) { call alims (Mems[uptr], U_MAXPTS, lut1, lut2) dz1_s = short (dz1) dz2_s = short (dz2) if (lut2 < dz1_s || lut1 > dz2_s) call eprintf ("User specified greyscales out of range\n") if (z2 < IM_MIN(im) || z1 > IM_MAX(im)) call eprintf ("User specified intensities out of range\n") } # Type short pixels are treated as a special case to minimize vector # operations for such images (which are common). If the image pixels # are either short or real then only the ALTR (greyscale transformation) # vector operation is required. The ALTR operator linearly maps # greylevels in the range Z1:Z2 to DZ1:DZ2, and does a floor ceiling # of DZ1:DZ2 on all pixels outside the range. If unity mapping is # employed the data is simply copied, i.e., floor ceiling constraints # are not applied. This is very fast and will produce a contoured # image on the display which will be adequate for some applications. if (zt == W_UNITARY) { unitary_greyscale_transformation = true } else if (zt == W_LINEAR) { unitary_greyscale_transformation = (fp_equalr(z1,dz1) && fp_equalr(z2,dz2)) } else unitary_greyscale_transformation = false if (y2 >= wy1 || y1 > wy2) { # Display from the first line if (IM_PIXTYPE(im) == TY_SHORT && PROC(mg) == NO && zt != W_LOG) { z1_s = z1; z2_s = z2 if (z1_s == z2_s) { z1_s = z1_s - 1 z2_s = z2_s + 1 } for (wy=y2+1; wy <= wy2; wy=wy+1) { in = zigm2s (mg, si, wy - wy1 + 1) if (NODATA(mg) == YES) break out = imps2s (ds, wx1, wx2, wy, wy) if (unitary_greyscale_transformation) { call amovs (Mems[in], Mems[out], nx) } else if (zt == W_USER) { dz1_s = U_Z1; dz2_s = U_Z2 call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s, dz2_s) call aluts (Mems[out], Mems[out], nx, Mems[uptr]) } else { dz1_s = dz1; dz2_s = dz2 call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s, dz2_s) } if (si_ovrly != NULL) { in = yigm2s (si_ovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (ocolors, int(Mems[in+i])) } } if (si_bpovrly != NULL) { in = yigm2s (si_bpovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (bpcolors, int(Mems[in+i])) } } } } else if (zt == W_USER) { call salloc (rtemp, nx, TY_REAL) for (wy=y2+1; wy <= wy2; wy=wy+1) { in = zigm2r (mg, si, wy - wy1 + 1) if (NODATA(mg) == YES) break out = imps2s (ds, wx1, wx2, wy, wy) call amapr (Memr[in], Memr[rtemp], nx, z1, z2, real(U_Z1), real(U_Z2)) call achtrs (Memr[rtemp], Mems[out], nx) call aluts (Mems[out], Mems[out], nx, Mems[uptr]) if (si_ovrly != NULL) { in = yigm2s (si_ovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (ocolors, int(Mems[in+i])) } } if (si_bpovrly != NULL) { in = yigm2s (si_bpovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (bpcolors, int(Mems[in+i])) } } } } else { for (wy=y2+1; wy <= wy2; wy=wy+1) { in = zigm2r (mg, si, wy - wy1 + 1) if (NODATA(mg) == YES) break out = imps2r (ds, wx1, wx2, wy, wy) if (unitary_greyscale_transformation) { call amovr (Memr[in], Memr[out], nx) } else if (zt == W_LOG) { call amapr (Memr[in], Memr[out], nx, z1, z2, 1.0, 10.0 ** MAXLOG) call alogr (Memr[out], Memr[out], nx, logerrfcn) call amapr (Memr[out], Memr[out], nx, 0.0, real(MAXLOG), dz1, dz2) } else call amapr (Memr[in], Memr[out], nx, z1, z2, dz1, dz2) if (si_ovrly != NULL) { in = yigm2s (si_ovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Memr[out+i] = maskcolor (ocolors, int(Mems[in+i])) } } if (si_bpovrly != NULL) { in = yigm2s (si_bpovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Memr[out+i] = maskcolor (bpcolors, int(Mems[in+i])) } } } } } else wy = wy1 # If no data was found at the beginning of the image try the end. if (wy == wy1) { if (IM_PIXTYPE(im) == TY_SHORT && zt != W_LOG) { z1_s = z1; z2_s = z2 if (z1_s == z2_s) { z1_s = z1_s - 1 z2_s = z2_s + 1 } for (wy=y1-1; wy >= wy1; wy=wy-1) { in = zigm2s (mg, si, wy - wy1 + 1) if (NODATA(mg) == YES) break out = imps2s (ds, wx1, wx2, wy, wy) if (unitary_greyscale_transformation) { call amovs (Mems[in], Mems[out], nx) } else if (zt == W_USER) { dz1_s = U_Z1; dz2_s = U_Z2 call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s,dz2_s) call aluts (Mems[out], Mems[out], nx, Mems[uptr]) } else { dz1_s = dz1; dz2_s = dz2 call amaps (Mems[in],Mems[out],nx, z1_s,z2_s, dz1_s,dz2_s) } if (si_ovrly != NULL) { in = yigm2s (si_ovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (ocolors, int(Mems[in+i])) } } if (si_bpovrly != NULL) { in = yigm2s (si_bpovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (bpcolors, int(Mems[in+i])) } } } } else if (zt == W_USER) { for (wy=y1-1; wy >= wy1; wy=wy-1) { in = zigm2r (mg, si, wy - wy1 + 1) if (NODATA(mg) == YES) break out = imps2s (ds, wx1, wx2, wy, wy) call amapr (Memr[in], Memr[rtemp], nx, z1, z2, real(U_Z1), real(U_Z2)) call achtrs (Memr[rtemp], Mems[out], nx) call aluts (Mems[out], Mems[out], nx, Mems[uptr]) if (si_ovrly != NULL) { in = yigm2s (si_ovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (ocolors, int(Mems[in+i])) } } if (si_bpovrly != NULL) { in = yigm2s (si_bpovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Mems[out+i] = maskcolor (bpcolors, int(Mems[in+i])) } } } } else { for (wy=y1-1; wy >= wy1; wy=wy-1) { in = zigm2r (mg, si, wy - wy1 + 1) if (NODATA(mg) == YES) break out = imps2r (ds, wx1, wx2, wy, wy) if (unitary_greyscale_transformation) { call amovr (Memr[in], Memr[out], nx) } else if (zt == W_LOG) { call amapr (Memr[in], Memr[out], nx, z1, z2, 1.0, 10.0 ** MAXLOG) call alogr (Memr[out], Memr[out], nx, logerrfcn) call amapr (Memr[out], Memr[out], nx, 0.0, real(MAXLOG), dz1, dz2) } else call amapr (Memr[in], Memr[out], nx, z1, z2, dz1, dz2) if (si_ovrly != NULL) { in = yigm2s (si_ovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Memr[out+i] = maskcolor (ocolors, int(Mems[in+i])) } } if (si_bpovrly != NULL) { in = yigm2s (si_bpovrly, wy - wy1 + 1) do i = 0, nx-1 { if (Mems[in+i] != 0) Memr[out+i] = maskcolor (bpcolors, int(Mems[in+i])) } } } } y1 = min (wy + 25, wy2) if (wy < wy1) done = YES else done = NO } else { y2 = max (wy - 25, wy1) if (wy > wy2) done = YES else done = NO } call sigm2_free (si) if (si_ovrly != NULL) call sigm2_free (si_ovrly) if (si_bpovrly != NULL) call sigm2_free (si_bpovrly) if (ovrly != NULL) call imunmap (ovrly) if (bpm != NULL) call imunmap (bpm) call sfree (sp) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/src/xtfixpix.h������������������������������������������������0000664�0000000�0000000�00000001777�13321663143�0021564�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# XT_FIXPIX data structure. define FP_LEN 13 # Length of FP structure define FP_PM Memi[$1] # Pixel mask pointer define FP_LVAL Memi[$1+1] # Mask value for line interpolation define FP_CVAL Memi[$1+2] # Mask value for column interpolation define FP_NCOLS Memi[$1+3] # Number of columns to interpolate define FP_PCOL Memi[$1+4] # Pointer to columns define FP_PL1 Memi[$1+5] # Pointer to start lines define FP_PL2 Memi[$1+6] # Pointer to end lines define FP_PV1 Memi[$1+7] # Pointer to start values define FP_PV2 Memi[$1+8] # Pointer to end values define FP_LMIN Memi[$1+9] # Minimum line define FP_LMAX Memi[$1+10] # Maximum line define FP_PIXTYPE Memi[$1+11] # Pixel type for values define FP_DATA Memi[$1+12] # Data values define FP_COL Memi[FP_PCOL($1)+$2-1] define FP_L1 Memi[FP_PL1($1)+$2-1] define FP_L2 Memi[FP_PL2($1)+$2-1] define FP_V1 (FP_PV1($1)+$2-1) define FP_V2 (FP_PV2($1)+$2-1) define FP_LDEF 1 # Default line interpolation code define FP_CDEF 2 # Default column interpolation code �mscred-5.05-2018.07.09/src/mscdisplay/tile.par������������������������������������������������������0000664�0000000�0000000�00000000307�13321663143�0020366�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,"",,,Root name for input images output,s,a,"",,,Name for output tiled image trim,b,h,no,,,include only trim sections in tiled image blank,r,h,0.0,,,Fill value for empty protions of mosaic �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/x_mscdisplay.x������������������������������������������������0000664�0000000�0000000�00000000172�13321663143�0021615�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������task acedisplay = t_mscdisplay, mscdisplay = t_mscdisplay, mscrtdisplay = t_mscrtdisplay, mscstarfocus = t_starfocus ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdisplay/x_mscexam.x���������������������������������������������������0000664�0000000�0000000�00000000037�13321663143�0021102�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������task mscexamine = t_imexamine �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdither.cl�������������������������������������������������������������0000664�0000000�0000000�00000002522�13321663143�0017060�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure mscdither begin int i, j string in, out, outlist, temp in = input out = output temp = mktemp ("tmp$iraf") outlist = mktemp ("tmp$iraf") i = stridx (".", out) j = strlen (out) if (i > 0 && j > 3) { if (substr (out, i, j) == ".fits") out = substr (out, 1, i-1) else if (substr (out, i, j) == ".fit") out = substr (out, 1, i-1) } sections (in, option="fullname", > temp) i = 0 fd = temp while (fscan (fd) != EOF) { i = i + 1 printf ("%s_%02d\n", out, i, >> outlist) } fd = ""; delete (temp, verify-) msccoordfit (in, coords, database="mscwcs.dat", nfit=nfit, rms=rms, maxshift=maxshift, fitgeometry=fittype, update=yes, interactive=no, verbose=yes) mscimage (in, "@"//outlist, reference="", pixmask=pixmask, wcssol=wcssol, interactive=no, nx=nx, ny=ny, fitgeometry=fitgeometry, function=function, xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, yyorder=yyorder, yxterms=yxterms, verbose=verbose, interpolant="linear",nxblock=nxblock,nyblock=nyblock, fluxconserve=fluxconserve, ntrim=ntrim) mscstack ("@"//outlist, out, plfile="", combine=combine, reject="none", masktype="goodvalue", maskvalue=0, scale=scale, zero=zero, weight="none", statsec=statsec, lthreshold=lthreshold, hthreshold=hthreshold) delete (outlist, verify-) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdither.par������������������������������������������������������������0000664�0000000�0000000�00000003364�13321663143�0017251�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,Dithered input mosaic exposures output,f,a,,,,Output combined image coords,f,a,"",,,Coordinate file (ra/dec) nfit,i,h,0,,,Min coordinates (>0) or max not found (<=0) for fit rms,r,h,2.,0.,,Maximum fit RMS to accept (arcsec) maxshift,r,h,5,,,Maximum centering shift (arcsec) fittype,s,h,"rxyscale","shift|xyscale|rotate|rscale|rxyscale",,Coordinate fit type interactive,b,h,no,,,Interactive? fit,b,h,yes,,,Interactive fitting? accept,b,q,yes,,,Accept coordinate solution? # Mosaicking parameters" pixmask,b,h,no,,,"Create pixel mask?" wcssol,b,h,yes,,,"Use WCS plate solution?" nx,i,h,10,,,"Number of x grid points" ny,i,h,20,,,"Number of y grid points" fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general,,"Fitting geometry" function,s,h,"chebyshev",|chebyshev|legendre|polynomial,,"Surface type" xxorder,i,h,4,2,,"Order of x fit in x" xyorder,i,h,4,2,,"Order of x fit in y" xxterms,s,h,"half",,,"X fit cross terms type" yxorder,i,h,4,2,,"Order of y fit in x" yyorder,i,h,4,2,,"Order of y fit in y" yxterms,s,h,"half",,,"Y fit cross terms type" interpolant,s,h,"linear",|nearest|linear|poly3|poly5|spline3|,,"Interpolant (nearest,linear,poly3,poly5,spline3)" nxblock,i,h,2048,,,"X dimension of working block size in pixels" nyblock,i,h,1024,,,"Y dimension of working block size in pixels" fluxconserve,b,h,no,,,"Preserve flux per unit area?" ntrim,i,h,7,0,,"Number of edge pixels to trim in each output piece # Combining parameters" combine,s,h,"median",average|median,,"Type of combine operation (median|average)" scale,s,h,"none",,,"Image scaling" zero,s,h,"none",,,"Image zero point offset" statsec,s,h,"",,,"Image section for computing statistics" lthreshold,r,h,1.,,,"Lower threshold" hthreshold,r,h,INDEF,,,"Upper threshold" fd,*struct,h ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscdpars.par�������������������������������������������������������������0000664�0000000�0000000�00000001654�13321663143�0017103�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCDPARS scale,r,h,0.25,0.0,,Image scale in units per pixel fwhmpsf,r,h,2.5,0.0,,FWHM of the PSF in scale units emission,b,h,yes,,,Features are positive ? sigma,r,h,INDEF,,,Standard deviation of background in counts datamin,r,h,INDEF,,,Minimum good data value datamax,r,h,INDEF,,,Maximum good data value noise,s,h,"poisson","|constant|poisson|",,Noise model ccdread,s,h,"rdnoise",,,CCD readout noise image header keyword gain,s,h,"gain",,,CCD gain image header keyword readnoise,r,h,0.0,,,CCD readout noise in electrons epadu,r,h,1.0,,,Gain in electrons per count exposure,s,h,"exptime",,,Exposure time image header keyword airmass,s,h,"airmass",,,Airmass image header keyword filter,s,h,"filter",,,Filter image header keyword obstime,s,h,"mjd-obs",,,Time of observation image header keyword itime,r,h,1.0,,,Exposure time xairmass,r,h,INDEF,,,Airmass ifilter,s,h,"INDEF",,,Filter otime,s,h,"INDEF",,,Time of observation mode,s,h,'ql' ������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscextensions.par��������������������������������������������������������0000664�0000000�0000000�00000001027�13321663143�0020163�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,List of input files output,s,h,"file","none|list|file",,Output type index,s,h,"",,,Extension index range list extname,s,h,"",,,Extension name pattern extver,s,h,"",,,Extension version range list lindex,b,h,"yes",,,List with index? lname,b,h,"no",,,List with extension name? lver,b,h,"no",,,List with extension version? dataless,b,h,"no",,,Include dataless image headers? ikparams,s,h,"",,,"Image kernel parameters # Output parameters" nimages,i,h,,,,Number of images in list imext,b,h,,,,List contains image extensions ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/���������������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0016527�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/_qpars.par�����������������������������������������������������0000664�0000000�0000000�00000000350�13321663143�0020516�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������replace,b,q,yes,,,"replace the file?" reopen,b,q,yes,,,"reopen the file?" recenter,b,q,yes,,,"Automatically recenter the catalog sources?" rewrite,s,q,"append","append|replace|cancel",,"," go_ahead,b,q,no,,,"(yes/no)" mode,s,h,"ql" ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/catpars.par����������������������������������������������������0000664�0000000�0000000�00000001647�13321663143�0020700�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������cat_epoch,r,h,"2000.",,,"Epoch of the catalog\n" ra_col,s,h,"RA_DEG",,,"Column for the Right Ascension (in degrees)" dec_col,s,h,"DEC_DEG",,,"Column for the Declination (in degrees)\n" region_col,s,h,"REGION",,,"Column for the GSC region number\n" xpred_col,s,h,"X_PRED",,,"Column for the predicted X coordinates" ypred_col,s,h,"Y_PRED",,,"Column for the predicted Y coordinates\n" xcen_col,s,h,"X_CENTER",,,"Column for the centered X coordinates" ycen_col,s,h,"Y_CENTER",,,"Column for the centered Y coordinates" cerr_col,s,h,"CEN_ERR",,,"Column for the centering error\n" datatype,s,h,"real","real|double|int",,"Data type for X,Y columns" format,s,h,"%8.2f",,,"Print format for X and Y" units,s,h,"pixels",,,"Units for X and Y\n" sub_col,s,h,"SUB_FLAG",,,"Subset selection flag" cen_col,s,h,"CEN_FLAG",,,"Good centering flag" obj_col,s,h,"OBJ_FLAG",,,"Program object flag\n" id_col,s,h,"GSC_ID",,,"Column for the ID number\n" �����������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/ccmap.par������������������������������������������������������0000664�0000000�0000000�00000004176�13321663143�0020326�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parameters for the CCMAP task # Input and output files and images input,f,a,,,,The input coordinate files database,f,a,,,,The output database file images,f,h,"",,,The input images results,f,h,"",,,The optional results summary files # The input coordinate file format xcolumn,i,h,1,,,Column containing the x coordinate ycolumn,i,h,2,,,Column containing the y coordinate lngcolumn,i,h,3,,,Column containing the ra / longitude latcolumn,i,h,4,,,Column containing the dec / latitude xmin,r,h,INDEF,,,Minimum logical x pixel value xmax,r,h,INDEF,,,Maximum logical x pixel value ymin,r,h,INDEF,,,Minimum logical y pixel value ymax,r,h,INDEF,,,Maximum logical y pixel value lngunits,s,h,"",,,Input ra / longitude units latunits,s,h,"",,,Input dec / latitude units insystem,s,h,"j2000",,,Input celestial coordinate system # The celestial coordinate system reference point parameters refpoint,s,h,"coords","|coords|user|",,Source of the reference point definition lngref,s,h,"INDEF",,,Reference point ra / longitude telescope coordinate latref,s,h,"INDEF",,,Reference point dec / latitude telescope coordinate refsystem,s,h,"INDEF",,,Reference point telescope coordinate system lngrefunits,s,h,"",,,Reference point ra / longitude units latrefunits,s,h,"",,,Reference point dec / latitude units # Coordinate map fitting parameters projection,s,h,"tan","|lin|tan|sin|arc|",,Sky projection geometry fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general|,,Fitting geometry function,s,h,"polynomial",|chebyshev|legendre|polynomial|,,Surface type xxorder,i,h,2,2,,Order of xi fit in x xyorder,i,h,2,2,,Order of xi fit in y xxterms,b,h,no,,,Include cross-terms in xi fit? yxorder,i,h,2,2,,Order of eta fit in x yyorder,i,h,2,2,,Order of eta fit in y yxterms,b,h,no,,,Include cross-terms in eta fit? reject,r,h,INDEF,,,Rejection limit in sigma units # Output and graphics mode parameters update,b,h,no,,,Update the image world coordinate system ? verbose,b,h,yes,,,Print messages about progress of task ? interactive,b,h,yes,,,Fit the transformation interactively ? graphics,s,h,"stdgraph",,,Default graphics device cursor,*gcur,h,,,,Graphics cursor mode,s,h,'ql' ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits.par����������������������������������������������������0000664�0000000�0000000�00000000753�13321663143�0020676�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# FITS parameters fits_file,f,a,mta,,,FITS data source file_list,s,a,,,,File list iraf_file,f,a,,,,IRAF filename template,f,h,,,,template filename long_header,b,h,no,,,Print FITS header cards? short_header,b,h,yes,,,Print short header? datatype,s,h,"",,,IRAF data type blank,r,h,0.0,,,Blank value scale,b,h,yes,,,Scale the data? xdimtogf,b,h,no,,,Transform xdim FITS to multigroup? oldirafname,b,h,no,,,Use old IRAF name in place of iraf_file? offset,i,h,0,,,Tape file offset mode,s,h,ql,,, ���������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/�������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0020165�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/esc_dash.x���������������������������������������������0000664�0000000�0000000�00000002263�13321663143�0022132�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas procedure pesc_dash (name) char name[SZ_FNAME] pointer sp, pp int i,j, np, stridx() char dash , plus begin dash = '-' np = stridx(dash, name) plus = '+' if (np == 0) np = stridx(plus, name) if (np != 0) { call smark(sp) call salloc(pp,SZ_FNAME,TY_CHAR) j = 0 for (i=1; i<= SZ_FNAME ||name[i] == EOS; i=i+1) { if (name[i] != '-' && name[i] != '+') Memc[pp+j] = name[i] else { Memc[pp+j] = '\\' j=j+1 Memc[pp+j] = name[i] } j = j+ 1 } call strcpy (Memc[pp], name, SZ_FNAME) call sfree(sp) } end procedure cesc_dash (name) char name[SZ_FNAME] pointer sp, pp, np int i,j, stridx() char esc begin esc= '\\' np = stridx(esc, name) if (np != 0) { call smark(sp) call salloc(pp,SZ_FNAME,TY_CHAR) j = 0 for (i=1; i<= SZ_FNAME ||name[i] == EOS; i=i+1) { if (name[i] != '\\') Memc[pp+j] = name[i] else { if (name[i+1] == '-' || name[i+1] == '+') { Memc[pp+j] = name[i+1] i = i + 1 } } j = j+ 1 } call strcpy (Memc[pp], name, SZ_FNAME) call sfree(sp) } end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/find_simple.x������������������������������������������0000664�0000000�0000000�00000001615�13321663143�0022652�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# FIND_SIMPLE -- fix the blocksize mismatch between the apple cdrom # reader and the GSC cd's. Scan the file to find the SIMPLE keyword. # Assumes the SIMPLE offset is either 512, 1024, 1536, or 2048 bytes. define CDBUFSIZ 512 # size of the junk blocks IN BYTES define CDBUFLIM 4 # maximum number of junk blocks procedure find_simple (fd) int fd #I file descriptor pointer sp, buf int i int read(), strmatch() begin call smark (sp) call salloc (buf, CDBUFSIZ, TY_CHAR) do i = 1, CDBUFLIM { # the test includes status == EOF if (read (fd, Memc[buf], CDBUFSIZ / 2) != CDBUFSIZ / 2) break call chrupk (Memc[buf], 1, Memc[buf], 1, CDBUFSIZ) if (strmatch (Memc[buf], "^SIMPLE ") != 0) { call seek (fd, 1 + (i-1) * CDBUFSIZ / 2) call sfree (sp) return } } # didn't find SIMPLE - let the original code clean up call seek (fd, BOFL) call sfree (sp) end �������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/fits_read.x��������������������������������������������0000664�0000000�0000000�00000035106�13321663143�0022323�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include include include "rfits.h" # RFT_READ_FITZ -- Convert a FITS file. An EOT is signalled by returning EOF. int procedure rft_read_fitz (fitsfile, template, iraffile) char fitsfile[SZ_FNAME] # FITS file name char iraffile[SZ_FNAME] # IRAF file name char template[SZ_FNAME] # Template filename char root[SZ_FNAME], cluster[SZ_FNAME] char nroot[SZ_FNAME] char extn[SZ_EXTN], rb, lb char tabfile[SZ_FNAME], seqfile[SZ_FNAME] int fits_fd, istat, stat, pos1, pos2, ntab, nch, fnroot() int rft_read_header(), mtopen(), strlen() int tbtopn(), rtb_read_header(), gstrmatch() int open(), gi_gstfval() int stridx(), id1, id2, tbpsta() int nread, fd_usr, ncols pointer im, imt, sp, fits, tp, fn errchk smark, sfree, salloc, rft_read_header, rft_read_image, mtopen errchk close, imunmap, imrename, frename, rft_opnim include "rfits.com" define frmxtn_ 99 begin stat = 0 # Open input FITS data fits_fd = mtopen (fitsfile, READ_ONLY, 0) # Allocate memory for program data structure call smark (sp) call salloc (fits, LEN_FITS, TY_STRUCT) frmxtn_ call salloc (fn, SZ_FNAME, TY_CHAR) if (long_header == YES) { call printf ("\n**** FILE: %s\n ") call pargstr (iraffile) } if (short_header == YES) { if (tape == YES) { lb = '[' rb = ']' id1 = stridx (lb, fitsfile) + 1 id2 = stridx (rb, fitsfile) - 1 call strcpy (fitsfile[id1], Memc[fn], id2-id1+1) call printf ("%-5.5s") call pargstr (Memc[fn]) } else { call printf("%-16.16s ") call pargstr (fitsfile) } } call imgcluster (iraffile, cluster, SZ_FNAME) call iki_parse (cluster, root, extn) # 'gkey' can have the following values # DEF_GPB: Will create a default gp descriptor # NONDEF_GPB: Will read the gp descriptor from a user supplied # template with the non_default gp keywords. # NON_GPB: Will not create a gp descriptor in the output SDAS # file. This value gets setup with the fits keyword # SDASMGNU, which indicates that the input fits file # contains a file with an extra dimension for the groups # and an attached table with the gp values. # TO_MG: Will create a multigroup Geis file from the input # FITS file and its attached table. The FITS header # should have the keyword SDASMGNU and OPSIZE to # accomplish this. # -1: If the output file is 'imh' type. if (strlen(template) != 0) gkey = NONDEF_GPB # Open spool file to contain the fits header fd_usr = open ("fits_hdr", READ_WRITE, SPOOL_FILE) iferr { # locate the SIMPLE keyword if junk is prepended from the CDrom call find_simple (fits_fd) nread = rft_read_header (fits_fd, fd_usr, fits) } then { call erract (EA_WARN) return } if (gkey == TO_MG && GCOUNT(fits) == -1) gkey = DEF_GPB # If the user has chosen xdimtogf but PSIZE and GCOUNT are # zero then reset to gkey=NON_GPB if (gkey == TO_MG && GCOUNT(fits) == 0 && OPSIZE(fits) == 0) gkey = NON_GPB if (nread != EOF) { iferr { call rft_opnim (template, iraffile, fd_usr, fits, nread, im, imt) call rft_read_image (fits_fd, fits, im) } then { call sfree (sp) call erract (EA_WARN) return } } else { call printf ("End of data\n") call close (fd_usr) call close (fits_fd) call sfree (sp) return (EOF) } call close (fd_usr) if (NAXIS(fits) != 0) { if (IM_KERNEL(im) == 2) { # Update the wcs values since the STF_WCS routines did not # have the CRPIX nor the CRVAL's keywords in the user header. if (gkey == DEF_GPB) call update_gpb (im,fits) # Because of some bug in stf the value below does # not get change to true. if (gkey == NON_GPB && gi_gstfval(im, "PCOUNT") == 0) call gi_pstfval (im, "GROUPS", YES) } if (gkey == NON_GPB || gkey == NONDEF_GPB) call imunmap (imt) call imunmap (im) call print_header (fits, fitsfile, iraffile) } else # if nxis==0 if (short_header == YES ) { if (strlen(IRAFNAME(fits)) == 0) call strcpy ("0_len image", IRAFNAME(fits), SZ_FNAME) call printf ("%-20.20s") call pargstr (IRAFNAME(fits)) call printf("0\n") } # If the above main header contains an extension flag, then # lets see if we find a table. if (EXTEND(fits) == YES) { # No ieee for tables in FITS format ieee = NO call tbtext (root, tabfile, SZ_FNAME) call strcpy (tabfile, seqfile, SZ_FNAME) nch = gstrmatch (seqfile, ".tab", pos1, pos2) ntab = 1 call sprintf (seqfile[pos1], SZ_FNAME, "%02d") call pargi(ntab) call strcat (".tab", seqfile, SZ_FNAME) # look for more than one table in the current file repeat { tp = tbtopn (seqfile, NEW_FILE, 0) # read FITS table header an user parameters if any, # also create the table 'tbtcre'. istat = rtb_read_header (fits_fd, im, fits, tp) # istat will will have the value below only after the # first reading of the header. If the value is not # encounter then it will read the whole table header # before coming here. if (istat == IMAGE_IUE) { call strcpy (seqfile, root, pos1+1) call iki_mkfname (root, extn, iraffile, SZ_FNAME) goto frmxtn_ } else if (istat != EOF) { # Now read the fits table data call rtb_read_tfits (fits_fd, fits, tp) ncols = tbpsta(tp, TBL_NCOLS) call tbtclo (tp) # print table information to STDOUT. call prtab_info (fits, seqfile, ncols) # Save previous name in case there is no next table call strcpy (seqfile, Memc[fn], SZ_FNAME) # increase sequence number for table name ntab = ntab + 1 call sprintf (seqfile[pos1], SZ_FNAME, "%02d") call pargi(ntab) call strcat (".tab", seqfile, SZ_FNAME) } } until (istat == EOF) # Get rid of the sequential number if only # one table is present. if (ntab == 2 && old_name == NO) { call frename (Memc[fn], tabfile) if (short_header == YES ) { nch = fnroot (tabfile, nroot, SZ_FNAME) call printf("%17t renamed to %s.tab\n") call pargstr(nroot) } } } call close (fits_fd) call sfree (sp) return (stat) end # The following definition is necessary to open the template # file 'non_gpb.hhh' which has the keywrod "GROUPS = F" # plus PCOUNT and GCOUNT to zero also. define NONGPB_HDR "fitsio$non_gpb.hhh" define LEN_CARDP1 81 procedure rft_opnim (template, iraffile, fd_usr, fits, nread, im, imt) char template[SZ_FNAME] # template file name char iraffile[SZ_FNAME] # output image name int fd_usr # fits header spool file des. pointer fits # fits descriptor int nread # number of header lines in the fits header pointer im # output image descriptor pointer imt # o: template image pointer pointer ua int i, fd, maxlines, max_lenuser, stropen() int immap() errchk immap include "rfits.com" begin if (NAXIS(fits) == 0) return # If template is specified, the user has chosen to create a # non_default gpb descriptor. This will reset any previous # value, e.g. gkey = NON_GPB if the keyword SDASMGCV was # present in the fits header. # Create IRAF image header. if (gkey == NONDEF_GPB) { imt = immap (template, READ_ONLY, 0) im = immap (iraffile, NEW_COPY, imt) } else if (gkey == NON_GPB) { imt = immap (NONGPB_HDR, READ_ONLY, 0) im = immap (iraffile, NEW_COPY, imt) } else { im = immap (iraffile, NEW_IMAGE, 0) } # reset the naxis things IM_NDIM(im) = NAXIS(fits) do i = 1, IM_NDIM(im) IM_LEN(im,i) = NAXISN(fits,i) # Now copy the fits header lines onto the IM_USERAREA maxlines = (ARB - 3700)/LEN_CARD if (nread > maxlines) { call printf ("=== %d fits header lines discarded\n") call pargi (nread - maxlines) call printf ("Maximun number of lines is: %d\n") call pargi (maxlines) nread = maxlines } IM_LENHDRMEM(im) = nread*LEN_CARD + LEN_IMHDR call realloc (im, IM_LENHDRMEM(im) + LEN_IMDES, TY_STRUCT) max_lenuser = (IM_LENHDRMEM(im) + LEN_IMDES - IMU)*SZ_STRUCT ua = IM_USERAREA(im) fd = stropen (Memc[ua], max_lenuser, NEW_FILE) call seek (fd_usr, BOFL) if (gkey == DEF_GPB && IM_KERNEL(im) == 2) call rft_create_gpb (im, fd) call fcopyo (fd_usr, fd) call close (fd) iferr ( call imgstr (im, "OBJECT", IM_TITLE(im), SZ_OBJECT)) IM_TITLE(im) = EOS end # PRINT_HEADER -- Routine to rename the output file if necessary # and to print header information. procedure print_header (fits, fitsfile, iraffile) pointer fits char fitsfile[SZ_FNAME] char iraffile[SZ_FNAME] char root[SZ_FNAME] char nroot[SZ_FNAME], nextn[SZ_EXTN] char extn[SZ_EXTN] int status, k, strlen(), itab, fnldir(), fnroot(), fnextn() int strmatch() errchk imrename, stf_rname pointer sp, bf include "rfits.com" begin call smark (sp) call salloc (bf, SZ_FNAME, TY_CHAR) call imgcluster (iraffile, Memc[bf], SZ_FNAME) call iki_parse (Memc[bf], root, extn) # set itab for tape or disk file itab = 16 if (tape == YES) itab = 5 if (old_name == YES && strlen (IRAFNAME(fits)) != 0) { ##### At this time we cannot rename old.hhh to new.c0h k = fnldir (iraffile, Memc[bf], SZ_FNAME) call pesc_dash (IRAFNAME(fits)) k = fnroot (IRAFNAME(fits), nroot, SZ_FNAME) k = fnextn (IRAFNAME(fits), nextn, SZ_EXTN) if (gkey == TO_MG) if (strmatch (nroot, "_cvt") != 0) nroot[strlen(nroot)-3] = EOS call strcat (nroot, Memc[bf], SZ_FNAME) call iki_mkfname (Memc[bf], nextn, IRAFNAME(fits), SZ_FNAME) call cesc_dash (IRAFNAME(fits)) # iferr (call imrename (iraffile, Memc[bf])) { iferr { if (gkey < 0) call imrename (iraffile, IRAFNAME(fits)) else { call stf_rname (root, extn, Memc[bf], nextn, status) # copy in buffer to be use below, in case is > 19 chars call strcpy (IRAFNAME(fits), Memc[bf], SZ_FNAME) } } then { call printf ("Cannot rename %s to %s\n") call pargstr (iraffile) call pargstr (IRAFNAME(fits)) call printf ("%*t") call pargi (itab) } else if (short_header == YES) { call printf ("%-19.19s ") call pargstr (IRAFNAME(fits)) } } else if (short_header == YES) { call printf ("%-19.19s ") call pargstr(iraffile) } if (short_header == YES) { do k = 1, NAXIS(fits) { call printf("%-5.5d") call pargi(NAXISN(fits,k)) } if (NAXIS(fits) == 1) call printf("%11t") if (NAXIS(fits) == 2) call printf("%6t") call printf("%-2.2d %-8.8s ") call pargi(BITPIX(fits)) call pargstr(DATE(fits)) if (tape == YES) call printf ("%-26.26s") else call printf ("%-15.15s") call pargstr (OBJECT(fits)) call printf("\n") # See if fitsfile and/or iraffile are too long and put # in the following line do k = 1, 3 { if (strlen(fitsfile) > 16*k) { call printf ("%-16.16s ") call pargstr (fitsfile[16*k+1]) if (strlen(Memc[bf]) > 19*k) { call printf ("%-19.19s ") call pargstr (Memc[bf+19*k]) } call printf ("\n") } else if (strlen(Memc[bf]) > 19*k) { call printf ("%*t %-19.19s \n") call pargi (itab) call pargstr (Memc[bf+19*k]) } } } call sfree(sp) end # PRTAB_INFO -- Procedure to print table information to STDOUT define REGION_KEY "REGION" define LEN_REGION 5 define SZ_EXTN 3 procedure prtab_info (fits, seqfile, ncols) pointer fits #fits descriptor char seqfile[SZ_FNAME] #sequential table filename int ncols #NUmber of columns in table. pointer sp, bf, rr, sf, tp int len, k, itab, key char extn[SZ_EXTN] int strlen(), fnldir(), fnroot(), fnextn(), strcmp(), strmatch() pointer tbtopn() include "rfits.com" begin call smark(sp) call salloc (bf, SZ_FNAME, TY_CHAR) call salloc (sf, SZ_FNAME, TY_CHAR) # set tab value for tape or disk file itab = 17 if (tape == YES) itab = 5 # save 'seqfile' call strcpy (seqfile, Memc[sf], SZ_FNAME) if (old_name == YES && strlen (IRAFNAME(fits)) != 0) { call salloc (rr, SZ_FNAME, TY_CHAR) k = fnldir (Memc[sf], Memc[bf], SZ_FNAME) # Escape dash '-' in name if any call pesc_dash(IRAFNAME(fits)) k = fnroot (IRAFNAME(fits), Memc[rr], SZ_FNAME) call cesc_dash(Memc[rr]) k = fnextn (IRAFNAME(fits), extn, SZ_EXTN) if (strcmp (extn, "trl") == 0) { call strcat ("_trl", Memc[rr], SZ_FNAME) call strcpy ("tab", extn, SZ_EXTN) } # Add the .tab extension, if it's missing. In this case, # also add the GSC region number to the header, should # really parametrize this, but the assumption is that if # both oldirafname is set and IRAFNAME has no extension, # then we're dealing with a GSC file off the CDrom. if (extn[1] == EOS || strmatch (extn, "^#$") != 0) { call strcpy ("tab", extn, SZ_EXTN) len = strlen (Memc[rr]) call sscan (Memc[rr+len-LEN_REGION]) call gargi (key) if (key > 0) { # should really do this somewhere else... tp = tbtopn (seqfile, READ_WRITE, 0) call tbhadi (tp, REGION_KEY, key) call tbtclo (tp) } } call strcat (Memc[rr], Memc[bf], SZ_FNAME) call iki_mkfname (Memc[bf], extn, IRAFNAME(fits), SZ_FNAME) iferr (call frename (seqfile, IRAFNAME(fits)) ) { call printf ("Cannot rename %s to %s\n") call pargstr (Memc[sf]) call pargstr (IRAFNAME(fits)) } else if (short_header == YES) { call printf ("%*t %-19.19s ") call pargi (itab) call pargstr (IRAFNAME(fits)) call strcpy (IRAFNAME(fits), Memc[sf], SZ_FNAME) } else { # assume that if someone took the time to turn off # short_header in these circumstances that they want # an explicit list of output file names. call printf ("%s\n") call pargstr (IRAFNAME(fits)) } } else if (short_header == YES) { call printf ("%*t %-19.19s ") call pargi (itab) call pargstr (Memc[sf]) } if (short_header == YES) { call printf ("%-4.4d %-5.5d") call pargi (FITS_ROWLEN(fits)) call pargi (FITS_NROWS(fits)) call printf(" Ncols=%3d ") call pargi (ncols) if (old_name == NO) { call strcpy(IRAFNAME(fits), Memc[bf], LEN_CARD) if (Memc[bf] == EOS) call strcpy(" ", Memc[bf], LEN_CARD) if (tape == YES) call printf("%-30.30s") else call printf("%-22.22s") call pargstr(Memc[bf]) } call printf("\n") # See if fitsfile and/or iraffile are too long and put # in the following line do k = 1, 3 if (strlen(Memc[sf]) > 19*k) { call printf ("%*t %-19.19s \n") call pargi (itab) call pargstr (Memc[sf+19*k]) } } call sfree(sp) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/fits_rheader.x�����������������������������������������0000664�0000000�0000000�00000027501�13321663143�0023022�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include "rfits.h" # RFT_READ_HEADER -- Read a FITS header. # If BSCALE and BZERO are different from 1.0 and 0.0 scale is set to true # otherwise scale is false. # EOT is detected by an EOF on the first read and EOF is returned to the calling # routine. Any error is passed to the calling routine. int procedure rft_read_header (fits_fd, fd_usr, fits) int fits_fd # FITS file descriptor int fd_usr # Fits header spool file pointer pointer fits # FITS data structure int i, stat, nread, max_lenuser, ndiscard char card[LEN_CARD+1] int rft_decode_card(), rft_init_read_pixels(), rft_read_pixels(), strmatch() int maxcards errchk rft_decode_card, rft_init_read_pixels, rft_read_pixels errchk close include "rfits.com" begin card[LEN_CARD + 1] = '\n' card[LEN_CARD + 2] = EOS # Initialization FITS_BSCALE(fits) = 1.0d0 FITS_BZERO(fits) = 0.0d0 BLANKS(fits) = NO BLANK_VALUE(fits) = INDEFL SCALE(fits) = NO SIMPLE(fits) = YES # This xtension was set in rft_read_header if (EXTEND(fits) != IMAGE_IUE) EXTEND(fits) = NO NRECORDS(fits) = 0 ndiscard = 0 OBJECT(fits) = EOS IRAFNAME(fits) = EOS OPSIZE(fits) = -1 GCOUNT(fits) = -1 # The max_lenuser value should be smaller by the length of the # group parameter block in case we exhaust the buffer with header # cards and then we would not have space to put the gpb cards # that the stf kernel would put to the existing header. max_lenuser = ARB - 3200 maxcards = max_lenuser/LEN_CARD # fd_usr = open ("fits_hdr", READ_WRITE, SPOOL_FILE) # Do not call again if coming from ftb_rheader if (EXTEND(fits) != IMAGE_IUE) i = rft_init_read_pixels (len_record, FITS_BYTE, LSBF, TY_CHAR) # Loop until the END card is encountered nread = 0 repeat { i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) if ((i == EOF) && (nread == 0)) { # At EOT call close(fd_usr) return (EOF) } else if (EXTEND(fits) == IMAGE_IUE) { nread = nread + 1 EXTEND(fits) = NO } else if ((nread == 0) && strmatch (card, "^SIMPLE ") == 0) { call flush (STDOUT) call error (30, "RFT_READ_HEADER: Not a FITS file") } else if (i != LEN_CARD) { call error (2, "RFT_READ_HEADER: Error reading FITS header") } else nread = nread + 1 # Print FITS card images if long_header option specified if (long_header == YES) { call printf ("%s") call pargstr (card) } if (maxcards == nread) ndiscard = 1 stat = rft_decode_card (fits, fd_usr, card, ndiscard) } until (stat == YES) # stat == YES if END card encountered. if (OPSIZE(fits) == -1 && gkey == TO_MG) { # NO OPSIZE keyword gkey = DEF_GPB call printf ("Warning: fits file cannot be convert to multigroup\n") } if (ndiscard > 0) { call printf ("Warning: User area too small %d card images discarded\n") call pargi (ndiscard) } return (nread) end define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) # RFT_DECODE_CARD -- Decode a FITS card and return YES when the END # card is encountered. The keywords understood are given in fits.h. int procedure rft_decode_card (fits, fd_usr, card, ndiscard) pointer fits # FITS data structure int fd_usr # file descriptor of user area char card[LEN_CARD] # FITS card int ndiscard # Number of cards for which no space available pointer pn char cval, str[LEN_CARD], cdpat[SZ_LINE] double dval int nchar, i, j, k, len, ndim bool rft_equald() int strmatch(), ctoi(), ctol(), ctod(), cctoc(), rft_hms() int patmake(), patmatch(), date, origin errchk putline include "rfits.com" begin i = COL_VALUE if (strmatch (card, "^END ") != 0) { return(YES) } else if (strmatch (card, "^SIMPLE ") != 0) { nchar = cctoc (card, i, cval) if (cval != 'T') { call printf("RFT_DECODE_CARD: Non-standard FITS format \n") SIMPLE(fits) = NO } } else if (strmatch (card, "^BITPIX ") != 0) { nchar = ctoi (card, i, BITPIX(fits)) ieee = NO if (BITPIX(fits) < 0) { ieee = YES BITPIX(fits) = -BITPIX(fits) } nchar = patmake ("CD[1-7]_[1-7]", cdpat, SZ_LINE) } else if (strmatch (card, "^BLANK ") != 0) { BLANKS(fits) = YES nchar = ctol (card, i, BLANK_VALUE(fits)) } else if (strmatch (card, "^NAXIS ") != 0) { nchar = ctoi (card, i, NAXIS(fits)) if (NAXIS(fits) > IM_MAXDIM) call error (5, "RFT_DECODE_CARD: FITS NAXIS too large") # assume default values for CWS ndim = NAXIS(fits) do k = 1, ndim { pn = WCS_PDES(fits,k) CRVAL(pn) = 1.0 CRPIX(pn) = 1.0 CDELT(pn) = 1.0 CROTA(pn) = 0.0 call strcpy ("PIXEL", CTYPE(pn), SZ_WCSCTYPE) do j = 1, ndim { if (k == j) CDMATRIX(pn,j) = 1.0 else CDMATRIX(pn,j) = 0.0 } } date= YES origin = YES MAKE_CD(fits) = YES } else if (strmatch (card, "^NAXIS") != 0) { k = strmatch (card, "^NAXIS") nchar = ctoi (card, k, j) nchar = ctol (card, i, NAXISN(fits,j)) call strcpy (" ", RA(fits), LEN_CARD) call strcpy (" ", DEC(fits), LEN_CARD) call strcpy (" ", DATE(fits), LEN_CARD) } else if (strmatch (card, "^BLOCKED ") != 0) { # Just ignore the card } else if (strmatch (card, "^GROUPS ") != 0) { nchar = cctoc (card, i, cval) if (cval == 'T') { call error (6, "RFT_DECODE_CARD: Group data not implemented") } } else if (strmatch (card, "^SDASMGNU") != 0) { nchar = ctoi (card, i, GCOUNT(fits)) if (gkey != TO_MG) gkey = NON_GPB # If the number of rows is zero, then there is no attached # table, since the original file has PCOUNT = 0. if (GCOUNT(fits) >= 1 && gkey != TO_MG) call putline (fd_usr, card) MAKE_CD(fits) = NO } else if (strmatch (card, "^EXTEND ") != 0) { nchar = cctoc (card, i, cval) if (cval == 'T') { EXTEND(fits) = YES } } else if (strmatch (card, "^EXTNAME ") != 0) { call rft_get_fits_string (card, OBJECT(fits), LEN_CARD) call strcat (" (Xtension)",OBJECT(fits), LEN_CARD) call putline (fd_usr, card) } else if (strmatch (card, "^BSCALE ") != 0) { nchar = ctod (card, i, dval) if (! rft_equald (dval, 1.0d0) && scale == YES) SCALE(fits) = YES FITS_BSCALE(fits) = dval } else if (strmatch (card, "^BZERO ") != 0) { nchar = ctod (card, i, dval) if (! rft_equald (dval, 0.0d0) && scale == YES) SCALE(fits) = YES FITS_BZERO(fits) = dval } else if (strmatch (card, "^DATAMAX ") != 0) { if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^DATAMIN ") != 0) { if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^IRAF-MAX") != 0) { if (gkey < 0) call putline (fd_usr, card) } else if (strmatch (card, "^IRAF-MIN") != 0) { if (gkey < 0) call putline (fd_usr, card) } else if (strmatch (card, "^IRAF-B/P") != 0) { if (gkey < 0) call putline (fd_usr, card) } else if (strmatch (card, "^IRAFTYPE") != 0) { call rft_get_fits_string (card, FITSTYPE(fits), LEN_CARD) if (gkey <0) call putline (fd_usr, card) } else if (strmatch (card, "^OBJECT") != 0) { call rft_get_fits_string (card, OBJECT(fits), LEN_CARD) call putline (fd_usr, card) } else if (strmatch (card, "^IRAFNAME") != 0) { call rft_get_fits_string (card, IRAFNAME(fits), LEN_CARD) } else if (strmatch (card, "^ORIGIN ") != 0) { if (origin == NO) # don'take the first one if more than one call putline (fd_usr, card) origin = NO } else if (strmatch (card, "^OPSIZE ") != 0) { # Save if we want to create a multigroup image if (gkey == TO_MG) nchar = ctoi (card, i, OPSIZE(fits)) } else if (strmatch (card, "^FITSDATE") != 0) { # dont put in image header } else if (strmatch (card, "^DATE ") != 0) { if (date == YES) call rft_get_fits_string (card, DATE(fits), LEN_CARD) call putline (fd_usr, card) date = NO } else if (strmatch (card, "^HISTORY ") != 0) { # put all the history that "imuserarea" allows if (ndiscard >= 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^CRVAL") != 0) { k = strmatch (card, "^CRVAL") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CRVAL(pn) = dval if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^CRPIX") != 0) { k = strmatch (card, "^CRPIX") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CRPIX(pn) = dval if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^CDELT") != 0) { k = strmatch (card, "^CDELT") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CDELT(pn) = dval call putline (fd_usr, card) } else if (strmatch (card, "^CROTA") != 0) { k = strmatch (card, "^CROTA") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CROTA(pn) = dval call putline (fd_usr, card) } else if (strmatch (card, "^CTYPE") != 0) { k = strmatch (card, "^CTYPE") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) call rft_get_fits_string (card, CTYPE(pn), SZ_OBJECT) if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (patmatch (card, cdpat) != 0) { k = strmatch (card, "^CD") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) k = strmatch (card, "^CD?_") nchar = ctoi (card, k, j) nchar = ctod (card, i, dval) CDMATRIX(pn,j) = dval MAKE_CD(fits) = NO if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^UT ") != 0) { len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("UT", str, len, card, "right ascension") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^ZD ") != 0) { len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("ZD", str, len, card, "zenith distance") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^ST ") != 0) { len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("ST", str, len, card, "sidereal time") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^RA ") != 0) { call rft_get_fits_string (card, RA(fits), LEN_CARD) len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("RA", str, len, card, "right ascension") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^DEC ") != 0) { call rft_get_fits_string (card, DEC(fits), LEN_CARD) len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("DEC", str, len, card, "declination") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else { if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } return (NO) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/fits_rimage.x������������������������������������������0000664�0000000�0000000�00000026144�13321663143�0022656�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include "rfits.h" # RFT_READ_IMAGE -- Read FITS image pixels to IRAF image file procedure rft_read_image (fits_fd, fits, im) int fits_fd # FITS file descriptor pointer fits # FITS data structure pointer im # IRAF image descriptor int i, npix, npix_record, blksize, gn long v[IM_MAXDIM], nlines, il pointer tempbuf, buf real linemax, linemin, rmax, rmin, datamin, datamax long clktime(), gi_gstfval() int fstati(), rft_init_read_pixels(), rft_read_pixels() int rft_ieee_read(), rtb_read_header(), istat, noop data tempbuf /NULL/ errchk malloc, mfree, rft_init_read_pixels, rft_read_pixels, rft_scale_pix errchk rft_change_pix, rft_put_image_line, rft_pix_limits, rft_ieee_read include "rfits.com" begin if (NAXIS(fits) == 0) { # call printf ("Warning: No pixel file created\n") return } # intialize call rft_set_image_header (fits, im) rmax = -MAX_REAL rmin = MAX_REAL # FITS data is converted to type LONG. If BITPIX is not one # of the MII types then rft_read_pixels returns an ERROR. npix_record = len_record * FITS_BYTE / BITPIX(fits) if (ieee == YES) { if (PIXTYPE(im) == TY_REAL) i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_REAL) else i=rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_DOUBLE) } else i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_LONG) blksize = fstati (fits_fd, F_SZBBLK) if (mod (blksize, 2880) == 0) blksize = blksize / 2880 else blksize = 1 # If the user set xdimtogf we want to reset some of the stf # descriptor to allow for a new image to have a slot for the gpb # but not write in it until all the groups are in the pixel # file. if (gkey == TO_MG) { call gi_pstfval (im, "GCOUNT", GCOUNT(fits)) call gi_pstfval (im, "PSIZE", OPSIZE(fits)) call gi_reset (im) # Reset the NAXIS(fits) value just for printing statistic on the # user terminal. if (GCOUNT(fits) > 1) NAXIS(fits) = NAXIS(fits) - 1 } else GCOUNT(fits) = 1 npix = IM_LEN(im, 1) nlines = 1 do i = 2, IM_NDIM(im) nlines = nlines * IM_LEN(im, i) if (ieee == NO) { if (tempbuf != NULL) call mfree (tempbuf, TY_LONG) call malloc (tempbuf, npix, TY_LONG) } do gn = 1, GCOUNT(fits) { call amovkl (long(1), v, IM_MAXDIM) do il = 1, nlines { # Write image line call rft_put_image_line (im, buf, v, PIXTYPE(im)) # Read in image line if (ieee == YES) { if (rft_ieee_read(fits_fd, buf, npix, NRECORDS(fits), blksize) != npix) call printf ("Error reading FITS data\n") } else { if (rft_read_pixels (fits_fd, Meml[tempbuf], npix, NRECORDS(fits), blksize) != npix) call printf ("Error reading FITS data\n") # Scale data if (SCALE(fits) == YES) call rft_scale_pix (Meml[tempbuf], buf, npix, FITS_BSCALE(fits), FITS_BZERO(fits), PIXTYPE(im)) else call rft_change_pix (Meml[tempbuf], buf, npix, PIXTYPE(im)) # Map blanks if (BLANKS(fits) == YES) call rft_map_blanks (Meml[tempbuf], buf, npix, PIXTYPE(im), BLANK_VALUE(fits), blank, NBPIX(im)) } # Calculate image maximum and minimum call rft_pix_limits (buf, npix, PIXTYPE(im), linemin, linemax) rmax = max (rmax, linemax) rmin = min (rmin, linemin) if (NBPIX (im) != 0) { call printf ("Warning: %d bad pixels in image\n") call pargl (NBPIX (im)) } } if (gn < GCOUNT(fits)) { # Tell stf not to write gpb values into the pixels # file since they are not available yet. call gi_pstfval (im, "PSIZE", 0) call gi_opengr (im, gn+1, datamin, datamax, 0) } } # Now if the user has chosen the xdimtogf flag we want to read # the attached table and put the values straight into the gpb # part of the data file. if (gkey == TO_MG) { #Do not read a table if OPSIZE is zero (same as is PCOUNT =0) if (OPSIZE(fits) != 0) { istat = rtb_read_header (fits_fd, im, fits, noop) call rgf_read_tfits (fits_fd, im, fits) } call gi_update (im) EXTEND(fits) = NO BITPIX(fits) = gi_gstfval(im, "BITPIX") } IRAFMAX(im) = rmax IRAFMIN(im) = rmin LIMTIME(im) = clktime(long(0)) end define SZ_KEYWORD 8 # RFT_SET_IMAGE_HEADER -- Set remaining header fields not set in # rft_read_header. procedure rft_set_image_header (fits, im) pointer fits # FITS data structure pointer im # IRAF image pointer int strcmp() include "rfits.com" begin # Determine data type from BITPIX if user data type not specified. if (data_type == ERR) { if (SCALE(fits) == YES) { PIXTYPE(im) = TY_REAL # If bitpix is 64 then is a ieee FITS datatype. if (BITPIX(fits) == SZ_DOUBLE * SZB_CHAR * NBITS_BYTE) PIXTYPE(im) = TY_DOUBLE } else { if (BITPIX(fits) <= SZ_SHORT * SZB_CHAR * NBITS_BYTE) PIXTYPE(im) = TY_SHORT else PIXTYPE(im) = TY_LONG if (ieee == YES) { if (BITPIX(fits) <= SZ_LONG * SZB_CHAR * NBITS_BYTE) PIXTYPE(im) = TY_REAL else PIXTYPE(im) = TY_DOUBLE } # Get IRAFTYPE keyword value to check for unsigned input # fits file. if (strcmp (FITSTYPE(fits), "USHORT") == 0) { PIXTYPE(im) = TY_USHORT } } } else PIXTYPE(im) = data_type end # RFT_SET_PRECISION -- Procedure to determine the precision of the FITS data # type. procedure rft_set_precision (bitpix, precision) int bitpix # FITS bits per pixel int precision # FITS decimal digits of precision begin switch (bitpix) { case FITS_BYTE: precision = FITSB_PREC case FITS_SHORT: precision = FITSS_PREC case FITS_LONG: precision = FITSL_PREC default: call error (16, "RFT_SET_PRECISION: Unknown FITS type") } end # RFT_MAP_BLANKS -- Map the blank pixels. Currently only the number of blank # pixels is determined without an further mapping. procedure rft_map_blanks (a, buf, npts, pixtype, blank_value, blank, nbadpix) long a[ARB] # integer input buffer pointer buf # pointer to output image buffer int npts # number of points int pixtype # image data type long blank_value # FITS blank value real blank # user blank value long nbadpix # number of bad pixels int i begin # Do blank mapping here switch (pixtype) { case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: do i = 1, npts { if (a[i] == blank_value) { nbadpix = nbadpix + 1 Meml[buf+i-1] = blank } } case TY_REAL: do i = 1, npts { if (a[i] == blank_value) { nbadpix = nbadpix + 1 Memr[buf+i-1] = blank } } case TY_DOUBLE: do i = 1, npts { if (a[i] == blank_value) { nbadpix = nbadpix + 1 Memd[buf+i-1] = blank } } case TY_COMPLEX: do i = 1, npts { if (a[i] == blank_value) { nbadpix = nbadpix + 1 Memx[buf+i-1] = blank } } } end # RFT_PUT_IMAGE_LINE -- Procedure to output an image line to and IRAF file. procedure rft_put_image_line (im, buf, v, data_type) pointer im # IRAF image descriptor pointer buf # Pointer to output image line long v[IM_MAXDIM] # imio pointer int data_type # output pixel type int impnll(), impnlr(), impnld(), impnlx() errchk impnll, impnlr, impnld, impnlx begin switch (data_type) { case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: if (impnll (im, buf, v) == EOF) call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") case TY_REAL: if (impnlr (im, buf, v) == EOF) call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") case TY_DOUBLE: if (impnld (im, buf, v) == EOF) call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") case TY_COMPLEX: if (impnlx (im, buf, v) == EOF) call error (3, "RFT_PUT_IMAGE_LINE: Error writing FITS data") default: call error (10, "RFT_PUT_IMAGE_LINE: Unsupported IRAF image type") } end # RFT_SCALE_PIX -- Procedure to convert an IRAF image line from type long # to the requested output data type with optional scaling using the # FITS parameters BSCALE and BZERO. procedure rft_scale_pix (inbuf, outbuf, npix, bscale, bzero, data_type) long inbuf[ARB] # buffer of FITS integers pointer outbuf # pointer to output image line int npix # number of pixels double bscale, bzero # FITS bscale and bzero int data_type # IRAF image pixel type errchk achtll, achtlr, achtld, achtlx errchk altml, altmr, altmd, altmx begin switch (data_type) { case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: call achtll (inbuf, Meml[outbuf], npix) call altml (Meml[outbuf], Meml[outbuf], npix, bscale, bzero) case TY_REAL: call achtlr (inbuf, Memr[outbuf], npix) #call altmr (Memr[outbuf], Memr[outbuf], npix, real (bscale), #real (bzero)) call altmdr (Memr[outbuf], Memr[outbuf], npix, bscale, bzero) case TY_DOUBLE: call achtld (inbuf, Memd[outbuf], npix) call altmd (Memd[outbuf], Memd[outbuf], npix, bscale, bzero) case TY_COMPLEX: call achtlx (inbuf, Memx[outbuf], npix) call altmx (Memx[outbuf], Memx[outbuf], npix, real (bscale), real (bzero)) default: call error (10, "RFT_SCALE_LINE: Illegal IRAF image type") } end # ALTMDR -- procedure to scale lines procedure altmdr (a, b, npix, bscale, bzero) real a[ARB] # input array real b[ARB] # output array int npix # number of pixels double bscale, bzero # scaling parameters int i begin do i = 1, npix b[i] = a[i] * bscale + bzero end # RFT_CHANGE_PIX -- Procedure to change a line of long integers to the # IRAF image type. procedure rft_change_pix (inbuf, outbuf, npix, data_type) long inbuf[ARB] # array of FITS integers pointer outbuf # pointer to IRAF image line int npix # number of pixels int data_type # IRAF pixel type begin switch (data_type) { case TY_SHORT, TY_USHORT, TY_INT, TY_LONG: call achtll (inbuf, Meml[outbuf], npix) case TY_REAL: call achtlr (inbuf, Memr[outbuf], npix) case TY_DOUBLE: call achtld (inbuf, Memd[outbuf], npix) case TY_COMPLEX: call achtlx (inbuf, Memx[outbuf], npix) default: call error (10, "RFT_CHANGE_LINE: Illegal IRAF image type") } end # RFT_PIX_LIMITS -- Procedure to determine to maxmimum and minimum values in a # line. procedure rft_pix_limits (buf, npix, pixtype, linemin, linemax) pointer buf # pointer to IRAF image line int npix # number of pixels int pixtype # output data type real linemax, linemin # min and max pixel values long lmax, lmin real rmax, rmin double dmax, dmin complex xmax, xmin begin switch (pixtype) { case TY_SHORT, TY_INT, TY_USHORT, TY_LONG: call aliml (Meml[buf], npix, lmin, lmax) linemax = lmax linemin = lmin case TY_REAL: call alimr (Memr[buf], npix, rmin, rmax) linemax = rmax linemin = rmin case TY_DOUBLE: call alimd (Memd[buf], npix, dmin, dmax) linemax = dmax linemin = dmin case TY_COMPLEX: call alimx (Memx[buf], npix, xmin, xmax) linemax = xmax linemin = xmin default: call error (30, "RFT_PIX_LIMITS: Unknown IRAF type") } end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/fits_rpixels.x�����������������������������������������0000664�0000000�0000000�00000010677�13321663143�0023104�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include define BUF_LEN 32760 # RFT_INIT_READ_PIXELS and READ_PIXELS -- Read pixel data with record buffering # and data type conversion. The input data must meet the MII standard # except for possibly having the least significant byte first. # # Read data in records of len_record and convert to the specified IRAF # data type. Successive calls of rft_read_pixels returns the next npix pixels. # Read_pixels returns EOF or the number of pixels converted. # Init_read_pixels must be called before read_pixels. # # Error conditions are: # 1. A short input record # 2. Error in converting the pixels by miiup. # # This routine is based on the MII unpack routine which is machine dependent. # The bitpix must correspond to an MII type. If the lsbf (least significant # byte first) flag is YES then the pixels do not satisfy the MII standard. # In this case the bytes are first swapped into most significant byte first # before the MII unpack routine is called. int procedure rft_init_read_pixels (npix_record, bitpix, lsbf, spp_type) int npix_record # Number of pixels per input record int bitpix # Bits per pixel (must correspond to an MII type) int lsbf # byte swap? int spp_type # SPP data type to be returned # entry rft_read_pixels (fd, buffer, npix) int rft_read_pixels int rft_ieee_read int fd # Input file descriptor pointer buf char buffer[BUF_LEN] # Output buffer int npix # Number of pixels to read int swap int ty_mii, ty_spp, npix_rec, nch_rec, sz_rec, nchars, len_mii, recptr int bufsize, i, n, ip, op, nd pointer mii, spp, bufrd int read(), sizeof(), miilen(), nint_rec errchk mfree, malloc, read data mii/NULL/, spp/NULL/, bufrd/NULL/ include "rfits.com" begin ty_spp = spp_type swap = lsbf npix_rec = npix_record nch_rec = npix_rec * sizeof (ty_spp) if (ty_spp == TY_CHAR || ty_spp == TY_LONG) { ty_mii = bitpix len_mii = miilen (npix_rec, ty_mii) sz_rec = len_mii * SZ_INT if (mii != NULL) call mfree (mii, TY_INT) call malloc (mii, len_mii, TY_INT) ip = nch_rec } else { # is REAL or DOUBLE if (bufrd != NULL) call mfree (bufrd, TY_INT) nint_rec = npix_rec * sizeof (ty_spp) / 2 call malloc (bufrd, nint_rec, TY_INT) ip = npix_rec } if (spp != NULL) call mfree (spp, TY_CHAR) call malloc (spp, nch_rec, TY_CHAR) return (OK) entry rft_read_pixels (fd, buffer, npix, recptr, bufsize) nchars = npix * sizeof (ty_spp) op = 0 repeat { # If data is exhausted read the next record if (ip == nch_rec) { iferr (i = read (fd, Memi[mii], sz_rec)) { call fseti (fd, F_VALIDATE, bufsize * sz_rec) call printf ("Error reading record %d\n") if (mod (recptr + 1, bufsize) == 0) call pargi ((recptr + 1) / bufsize) else call pargi ((recptr + 1) / bufsize + 1) i = read (fd, Memi[mii], sz_rec) } if (i == EOF) return (EOF) if (swap == YES) switch (ty_mii) { case MII_SHORT: call bswap2 (Memi[mii], 1, Memi[mii], 1, sz_rec * SZB_CHAR) case MII_LONG: call bswap4 (Memi[mii], 1, Memi[mii], 1, sz_rec * SZB_CHAR) } call miiupk (Memi[mii], Memc[spp], npix_rec, ty_mii, ty_spp) ip = 0 recptr = recptr + 1 } n = min (nch_rec - ip, nchars - op) call amovc (Memc[spp+ip], buffer[1+op], n) ip = ip + n op = op + n } until (op == nchars) return (npix) entry rft_ieee_read(fd, buf, npix, recptr, bufsize) op = 0 repeat { # If data is exhausted read the next record if (ip == npix_rec) { iferr (i = read (fd, Meml[bufrd], nch_rec)) { call fseti (fd, F_VALIDATE, bufsize * nch_rec) call printf ("Error reading record %d\n") if (mod (recptr + 1, bufsize) == 0) call pargi ((recptr + 1) / bufsize) else call pargi ((recptr + 1) / bufsize + 1) i = read (fd, Meml[bufrd], nch_rec) } ip = 0 nd = 0 recptr = recptr + 1 } n = min (npix_rec - ip, npix - op) if (ty_spp == TY_REAL) { # call sun2vaxr (Meml[bufrd+ip], Memr[buf+op], n) call ieevupkr (Meml[bufrd+ip], Memr[buf+op], n) } else { # call sun2vaxd (Meml[bufrd+nd], Memd[buf+op], n) call ieevupkd (Meml[bufrd+nd], Memd[buf+op], n) # There are 2 Meml per Memd nd = nd + n * 2 } ip = ip + n op = op + n } until (op == npix) return (npix) end �����������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/fits_rtable.x������������������������������������������0000664�0000000�0000000�00000003161�13321663143�0022655�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include "rfits.h" # RFT_READ_TFITS -- Read FITS table in row order as character strings # and convert them to IRAF table rows. procedure rtb_read_tfits (fits_fd, fits, tp) int fits_fd # FITS file descriptor pointer fits # FITS data structure pointer tp # IRAF table descriptor int i, rowlen, blksize, nch long nlines, il, ncols pointer sp, bfp int colptr[SZ_MAXCOL] int rft_init_read_pixels(), rft_read_pixels() int tbpsta(), npix_record, fstati(), tbcnum() errchk salloc, sfree, rft_init_read_pixels, rft_read_pixels, rft_scale_pix errchk rft_change_pix, rft_put_image_line, rft_pix_limits, smark include "rfits.com" include "tab.com" begin rowlen = FITS_ROWLEN(fits) nlines = FITS_NROWS(fits) ncols = tbpsta (tp, TBL_MAXCOLS) do i = 1, ncols { colptr[i] = tbcnum (tp, i) } call smark (sp) call salloc (bfp, rowlen, TY_CHAR) npix_record = len_record * FITS_BYTE / BITPIX(fits) i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_CHAR) blksize = fstati (fits_fd, F_SZBBLK) if (mod (blksize, 2880) == 0) blksize = blksize / 2880 else blksize = 1 # Put EOS at the end, rft_red_pixels does not put one at rowlen. Memc[bfp+rowlen] = EOS do il = 1, nlines { # Read in table row nch = rft_read_pixels (fits_fd, Memc[bfp], rowlen, NRECORDS(fits), blksize) if (nch != rowlen) call printf ("Error reading FITS data\n") # Write table row call rft_put_table_row (tp, colptr, Memc[bfp], rowlen, ncols, il) } call sfree (sp) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/ftb_gfsub.x��������������������������������������������0000664�0000000�0000000�00000003322�13321663143�0022317�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include "rfits.h" # RGF_READ_TFITS -- Read FITS table in row order as character strings. # This routine is called only when the user has asked to convert # a FITS file with an extra dimension and a table attached to it # to a multigroup file. procedure rgf_read_tfits (fits_fd, im, fits) int fits_fd # FITS file descriptor pointer im # Image descriptor pointer fits # FITS data structure int i, rowlen, blksize, nch int ngroups, gn, pcount pointer sp, bfp int rft_init_read_pixels(), rft_read_pixels() int npix_record, fstati(), gi_gstfval() errchk salloc, sfree, rft_init_read_pixels, rft_read_pixels errchk smark include "rfits.com" include "tab.com" begin rowlen = FITS_ROWLEN(fits) ngroups = GCOUNT(fits) # Reset value of PSIZE to the real one since rgf_get_table_val # will use it to calculate the size of the gpb. call gi_pstfval (im,"PSIZE", OPSIZE(fits)) pcount = gi_gstfval (im, "PCOUNT") call smark (sp) call salloc (bfp, rowlen, TY_CHAR) npix_record = len_record * FITS_BYTE / BITPIX(fits) i = rft_init_read_pixels (npix_record, BITPIX(fits), LSBF, TY_CHAR) blksize = fstati (fits_fd, F_SZBBLK) if (mod (blksize, 2880) == 0) blksize = blksize / 2880 else blksize = 1 # Put EOS at the end, rft_red_pixels does not put one at rowlen. Memc[bfp+rowlen] = EOS do gn = 1, ngroups { # Read in table row nch = rft_read_pixels (fits_fd, Memc[bfp], rowlen, NRECORDS(fits), blksize) if (nch != rowlen) call printf ("Error reading FITS data\n") # Write table row call gi_crgpb (im, Memc[bfp], tbcol, gn) } call sfree (sp) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/ftb_putrow.x�������������������������������������������0000664�0000000�0000000�00000003024�13321663143�0022550�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include "rfits.h" # RFT_PUT_TABLE_ROW -- Procedure to fill each column buffer with blanks # from the last non_character to the buffer length. See also if there are # null values defined or a scaled column has been found; then copy to a double # dimension buffer. procedure rft_put_table_row (tp, colptr, buf, rowlen, ncols, rownum) pointer tp int colptr[SZ_MAXCOL] # i: column pointer descriptor char buf[ARB] # i: input string buffer int rowlen # i: number of chars in buffer int ncols # i: number of columns int rownum # i: actual row number pointer sp, pp int i, nch, ctor() int biof, len, strmatch(), ip real rval, value include "tab.com" begin call smark (sp) call salloc (pp, rowlen+1, TY_CHAR) do i = 1, ncols { # get position of first character and length of column biof = tbcol[i] len = tbcw[i] if (tnull[1,i] != EOS) { if (strmatch (buf[biof], tnull[1,i]) != 0) { # if the input buffer has a null value just skip the column, # since the output buffer already has UNDEF on it. next } } # copy the column element to a NULL terminated string call strcpy (buf[biof], Memc[pp], len) # scale data if necessary if (tzero[i] != 0.0 || tscal[i] != 1.0) { ip = 1 nch = ctor (Memc[pp], ip, rval) value = rval*tscal[i] + tzero[i] call tbeptr (tp, colptr[i], rownum, value) next } call tbeptt (tp, colptr[i], rownum, Memc[pp]) } call sfree (sp) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/ftb_rheader.x������������������������������������������0000664�0000000�0000000�00000027471�13321663143�0022636�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include "rfits.h" # RTB_READ_HEADER -- Read a FITS header for a table extension. # EOT is detected by an EOF on the first read and EOF is returned to the calling # routine. Any error is passed to the calling routine. int procedure rtb_read_header (fits_fd, im, fits, tp) int fits_fd # FITS file descriptor pointer im # Image descriptor pointer fits # FITS data structure pointer tp # IRAF table descriptor int i, stat, ind char card[LEN_CARD+1] int rft_init_read_pixels(), rft_read_pixels() int rtb_decode_card(), strncmp(), strmatch() errchk rft_read_pixels errchk stropen, close include "rfits.com" include "tab.com" begin card[LEN_CARD + 1] = '\n' card[LEN_CARD + 2] = EOS # Initialization BLANKS(fits) = NO BLANK_VALUE(fits) = INDEFL NRECORDS(fits) = 0 if (gkey != TO_MG) IRAFNAME(fits) = EOS # Header is character data in FITS_BYTE form i = rft_init_read_pixels (len_record, FITS_BYTE, LSBF, TY_CHAR) i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) if (i == EOF) # At EOT return (EOF) if (strmatch (card, "^XTENSION") != 0) { if (strncmp( card[12], "IMAGE-IUE", 9) == 0) { EXTEND(fits) = IMAGE_IUE return (IMAGE_IUE) } if (strncmp( card[12], "TABLE", 5) != 0) call error (13, "RTB_DECODE_CARD: Fits extension not supported") } else { return (EOF) } # Loop until the END card is encountered repeat { i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) if (i == EOF) { # At EOT return (EOF) } else if (i != LEN_CARD) { call error (2, "RFT_READ_HEADER: Error reading FITS header") } # Print FITS card images if long_header option specified ind = strncmp (card, " ", 8) if (long_header == YES && ind != 0) { call printf ("%s") call pargstr (card) } if (ind != 0) stat = rtb_decode_card (im, fits, tp, card) } until (stat == YES) return (stat) end define MAX_UPARM 50 # define max number of user parameter for a buffer define LEN_CARD1 81 # RTB_DECODE_CARD -- Decode a FITS card and return YES when the END # card is encountered. The keywords understood are given in fits.h. int procedure rtb_decode_card (im, fits, tp, card) pointer im # Image descriptor pointer fits # FITS data structure pointer tp # IRAF table descriptor char card[LEN_CARD] # FITS card pointer colptr char ftnfmt[SZ_COLFMT], pfmt[SZ_COLFMT] pointer ppar int nchar, ival, dtype, upar, ioff, mtsize int i, j, k, jc, tnaxis, npar, ncoln int strncmp() int strmatch(), ctoi(), ctol(), ctor() include "rfits.com" include "tab.com" data upar /NO/ data ppar /NULL/ begin i = COL_VALUE if (strmatch (card, "^END ") != 0) { # define the last column if (gkey != TO_MG) { call tbcdef (tp, colptr, colname, colunits, colfmt, datat, lendata, 1) call tbpset (tp, TBL_MAXPAR, npar+5) call tbtcre (tp) if (upar == YES) { # now write the user parameters to the table call ftb_put_upar (tp, npar, Memc[ppar]) upar = NO call mfree(ppar, TY_CHAR) } } else { call gi_pdes (im, colname, datat, lendata, ncoln) if (upar == YES) { call gi_gcomm (im, npar, Memc[ppar]) upar = NO call mfree(ppar, TY_CHAR) } } return(YES) } else if (strmatch (card, "^XTENSION") != 0) { if (strncmp( card[i+1], "TABLE", 5) != 0) call error (13, "RTB_DECODE_CARD: Fits extension not supported") } else if (strmatch (card, "^BITPIX ") != 0) { nchar = ctoi (card, i, BITPIX(fits)) } else if (strmatch (card, "^NAXIS ") != 0) { nchar = ctoi (card, i, tnaxis) if (tnaxis > 2) call error (5, "RTB_DECODE_CARD: FITS table NAXIS too large") coln = 1 # init column index } else if (strmatch (card, "^NAXIS") != 0) { call strcpy(" ", DATE(fits), LEN_CARD) k = strmatch (card, "^NAXIS") nchar = ctoi (card, k, j) if (j == 1 ) nchar = ctol (card, i, FITS_ROWLEN(fits)) else nchar = ctol (card, i, FITS_NROWS(fits)) } else if (strmatch (card, "^PCOUNT ") != 0) { nchar = ctoi (card, i, ival) if (ival != 0) call error (6, "RTB_DECODE_CARD: PCOUNT is not zero") } else if (strmatch (card, "^GCOUNT ") != 0) { nchar = ctoi (card, i, ival) if (ival > 1) call eprintf ("Warning: FITS can only read one group per table") } else if (strmatch (card, "^TFIELDS ") != 0) { nchar = ctoi (card, i, ival) if (gkey != TO_MG) { # set the number of columns call tbpset (tp, TBL_MAXCOLS, ival) # initialize defaults values } else { # The number of fields (or columns) in the table is the # number of parameter for the new GEIS file. call gi_pstfval (im, "PCOUNT", ival) if (ival > 0) # Realloc space needed for the stf descriptor call gi_realloc (im) } do jc = 1, ival { tnull[1,jc] = EOS tzero[jc] = 0.0 tscal[jc] = 1.0 } } else if (strmatch (card, "^EXTNAME ") != 0) { # Do not overwrite if if (gkey != TO_MG) call rft_get_fits_string (card, IRAFNAME(fits), LEN_CARD) } else if (strmatch (card, "^DATE ") != 0) { call rft_get_fits_string (card, DATE(fits), LEN_CARD) } else if (strmatch (card, "^TTYPE" ) != 0) { k = strmatch (card, "^TTYPE") nchar = ctoi (card, k, ncoln) # possible new column number if (ncoln != coln) { if (gkey != TO_MG) { # define previous column call tbcdef (tp, colptr, colname, colunits, colfmt, datat, lendata, 1) colunits[1] = EOS } else call gi_pdes (im, colname, datat, lendata, coln) coln = ncoln } call rft_get_fits_string (card, colname, SZ_COLNAME) } else if (strmatch (card, "^TBCOL" ) != 0) { k = strmatch (card, "^TBCOL") nchar = ctoi (card, k, jc) nchar = ctoi (card, i, tbcol[jc]) } else if (strmatch (card, "^TFORM" ) != 0) { k = strmatch (card, "^TFORM") nchar = ctoi (card, k, ncoln) # possible new column number if (ncoln != coln) { if (gkey != TO_MG) { # define previous column call tbcdef (tp, colptr, colname, colunits, colfmt, datat, lendata, 1) colunits[1] = EOS } else call gi_pdes (im, colname, datat, lendata, coln) coln = ncoln } call rft_get_fits_string (card, ftnfmt, SZ_COLFMT) call tbgtyp (ftnfmt, datat, tbcw[coln]) call tbbaln (datat, dtype, lendata) call tbbftp (ftnfmt, colfmt) if (datat < 0) { # Change format to left justified text call strcpy ("%-", pfmt, SZ_COLFMT) call strcat (colfmt[2], pfmt, SZ_COLFMT) call strcpy (pfmt, colfmt, SZ_COLFMT) } } else if (strmatch (card, "^TUNIT" ) != 0) { k = strmatch (card, "^TUNIT") nchar = ctoi (card, k, ncoln) # possible new column number if (ncoln != coln) { # define previous column if (gkey != TO_MG) { call tbcdef (tp, colptr, colname, colunits, colfmt, datat, lendata, 1) colunits[1] = EOS } else call gi_pdes (im, colname, datat, lendata, coln) coln = ncoln } call rft_get_fits_string (card, colunits, SZ_COLUNITS) } else if (strmatch (card, "^TNULL" ) != 0) { k = strmatch (card, "^TNULL") nchar = ctoi (card, k, jc) call rft_get_fits_string (card, tnull[1,jc], SZ_COLFMT) } else if (strmatch (card, "^TZERO" ) != 0) { k = strmatch (card, "^TZERO") nchar = ctoi (card, k, jc) nchar = ctor (card, i, tzero[jc]) # change datatype to real if 'datat' is int. if (datat == TY_INT) { datat = TY_REAL call strcpy ("%-15.7g", colfmt, SZ_COLFMT) } } else if (strmatch (card, "^TSCAL" ) != 0) { k = strmatch (card, "^TSCAL") nchar = ctoi (card, k, jc) nchar = ctor (card, i, tscal[jc]) # change datatype to real if 'datat' is int. if (datat == TY_INT) { datat = TY_REAL call strcpy ("%-15.7g", colfmt, SZ_COLFMT) } } else { # Allow storage for user parameters if (upar == NO) { upar = YES if (ppar != NULL) call mfree (ppar, TY_CHAR) mtsize = (LEN_CARD+1)*MAX_UPARM call malloc (ppar, mtsize, TY_CHAR) ioff = 0 npar = 0 } # Keep user parameters in a buffer until END call amovc (card, Memc[ppar+ioff], LEN_CARD) # copy EOS also ioff = ioff + LEN_CARD + 1 Memc[ppar+ioff-1] = EOS npar = npar + 1 if (npar >= mtsize/(LEN_CARD+1)) { # increase no. of cards by 10 mtsize = mtsize + (LEN_CARD+1)*50 call realloc(ppar, mtsize, TY_CHAR) } } return (NO) end # FTB_PUT_UPAR -- Procedure to write user parameters to the table # already created. procedure ftb_put_upar (tp, npar, uparbuf) pointer tp # i: table descriptor char uparbuf[LEN_CARD, npar] # i: buffer with user pars int npar # I: number of parameters read char keyword[SZ_KEYWORD], sval[LEN_CARD] char card[LEN_CARD], squo, cht, chn, dot, blkn int i, k, nscan(), stridx(), strmatch() double dval int bval, ival, iparn begin blkn = ' ' squo = '\'' cht = 'T' chn = 'F' dot = '.' do i = 1, npar { do k = 1, 8 { if (uparbuf[k,i] == blkn) { keyword[k] = EOS break } keyword[k] = uparbuf[k,i] } keyword[SZ_KEYWORD+1] = EOS call strcpy (uparbuf[10,i], card, LEN_CARD) if (stridx (squo, uparbuf[1,i]) == 11) { # is a string call rft_get_fits_string (uparbuf[1,i], sval, LEN_CARD) call tbhadt (tp, keyword, sval) } else if (strmatch(keyword, "^HISTORY") != 0 ) { call strcpy (uparbuf[9,i], sval, LEN_CARD) call trimh (sval) call tbhadt (tp, "HISTORY", sval) } else if (strmatch(keyword, "^COMMENT") != 0 ) { call strcpy (uparbuf[9,i], sval, LEN_CARD) call trimh (sval) call tbhadt (tp, "COMMENT", sval) } else if (strmatch(card, "^ T ") != 0 ) { bval = YES call tbhadb (tp, keyword, bval) } else if (strmatch(card, "^ F ") != 0 ) { bval = NO call tbhadb (tp, keyword, bval) } else { # is a number call sscan(card) call gargd(dval) if (nscan() < 1) { call strcpy (uparbuf[1,i], card, LEN_CARD) # append card regardless of content or keyword call tbhanp (tp, keyword, 't', card[9], iparn) } else { if (stridx(dot, card) == 0) { call sscan(card) call gargi(ival) call tbhadi (tp, keyword, ival) } else call tbhadd (tp, keyword, dval) } } } end # TBGTYPE -- Get datatype and field width from the format specification. # Notice that datatype for character format is not spp standard. procedure tbgtyp (ftnfmt, datatyp, width) char ftnfmt[LEN_CARD] # i: fortran format specification int datatyp # o: data type expressed as an int int width # 0: field width in character (TBFORM value) #-- int ctoi(), nchar, ipos begin call strlwr (ftnfmt) ipos = 2 nchar = ctoi (ftnfmt, ipos, width) if (ftnfmt[1] == 'e') { datatyp = TY_REAL } else if (ftnfmt[1] == 'g') { datatyp = TY_REAL } else if (ftnfmt[1] == 'f') { datatyp = TY_REAL } else if (ftnfmt[1] == 'd') { datatyp = TY_DOUBLE } else if (ftnfmt[1] == 'i') { datatyp = TY_INT } else if (ftnfmt[1] == 'b') { datatyp = TY_BOOL } else if (ftnfmt[1] == 'a') { datatyp = -width # NOTE: not an SPP data type } else { call error (5,"table datatype not supported") } end procedure trimh (card) char card[LEN_CARD] int i , strlen() begin for (i=strlen(card); i > 1 && (card[i] == ' ' || card[i] == '\n'); i=i-1) ; card[i+1] = EOS end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/mkpkg��������������������������������������������������0000664�0000000�0000000�00000001544�13321663143�0021225�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������$checkout libfinder.a mscbin$ $update libfinder.a $checkin libfinder.a mscbin$ $exit libfinder.a: esc_dash.x find_simple.x fits_read.x \ rfits.com rfits.com rfits.h fits_rheader.x rfits.com rfits.com rfits.h fits_rimage.x rfits.com rfits.h fits_rpixels.x rfits.com fits_rtable.x rfits.com rfits.h\ tab.com ftb_gfsub.x rfits.com rfits.h\ tab.com ftb_putrow.x rfits.h tab.com ftb_rheader.x rfits.com rfits.com\ rfits.h tab.com rft_subs.x \ rfits.h t_rfits.x rfits.com rfits.h wft_encodec.x wfits.h ; ������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/obsolete/����������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0022001�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/obsolete/find_simple.x���������������������������������0000664�0000000�0000000�00000003745�13321663143�0024474�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# FIND_SIMPLE -- fix the blocksize mismatch between the apple cdrom # reader and the GSC cd's. Scan the file to find the SIMPLE keyword. int procedure find_simple (fd, card, ncard) int fd #I Input file descriptor char card[ARB] #U FITS card buffer int ncard #I Size of a card int idx, stat, len pointer sp, buf int fillbuf(), strmatch(), fs_stridx() begin call smark (sp) call salloc (buf, ncard, TY_CHAR) call amovc (card, Memc[buf], ncard) repeat { idx = fs_stridx ("S", Memc[buf], ncard) if (idx == 1) { # assumes ncard is greater than 8 stat = strmatch (Memc[buf], "^SIMPLE ") if (stat != 0) break # no match, look for another "S" in this card idx = fs_stridx ("S", Memc[buf+1], ncard-1) if (idx != 0) idx = idx + 1 } if (idx == 0) { # read another card stat = fillbuf (fd, Memc[buf], ncard) } else { # shift the buffer and top it off len = ncard - idx + 1 call amovc (Memc[buf+idx-1], Memc[buf], len) stat = fillbuf (fd, Memc[buf+len], ncard-len) } } until (stat == 0) if (stat != 0) { call amovc (Memc[buf], card, ncard) # see fits_rheader to justify this card[ncard+1] = '\n' card[ncard+2] = EOS } call sfree (sp) return (stat) end int procedure fillbuf (fd, buf, bufsiz) int fd #I Input file descriptor char buf[ARB] #U FITS card buffer or fraction int bufsiz #I Size of a card or fraction int stat, junk int rft_read_pixels() errchk rft_read_pixels begin iferr (stat = rft_read_pixels (fd, buf, bufsiz, junk, 1)) return (0) else if (stat != bufsiz) # catches EOF, too return (0) else return (stat) end # FS_STRIDX -- Return the index of the first occurrence of a # character in a non-EOS delimited string. int procedure fs_stridx (ch, str, len) char ch #I search character char str[ARB] #I string to search int len #I length of str int ip begin do ip = 1, len { if (str[ip] == ch) return (ip) } return (0) end ���������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/obsolete/fits_rheader.x��������������������������������0000664�0000000�0000000�00000027770�13321663143�0024646�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include "rfits.h" # RFT_READ_HEADER -- Read a FITS header. # If BSCALE and BZERO are different from 1.0 and 0.0 scale is set to true # otherwise scale is false. # EOT is detected by an EOF on the first read and EOF is returned to the calling # routine. Any error is passed to the calling routine. int procedure rft_read_header (fits_fd, fd_usr, fits) int fits_fd # FITS file descriptor int fd_usr # Fits header spool file pointer pointer fits # FITS data structure int i, stat, nread, max_lenuser, ndiscard char card[LEN_CARD+1] int rft_decode_card(), rft_init_read_pixels(), rft_read_pixels() int find_simple() int maxcards errchk rft_decode_card, rft_init_read_pixels, rft_read_pixels errchk close include "rfits.com" begin card[LEN_CARD + 1] = '\n' card[LEN_CARD + 2] = EOS # Initialization FITS_BSCALE(fits) = 1.0d0 FITS_BZERO(fits) = 0.0d0 BLANKS(fits) = NO BLANK_VALUE(fits) = INDEFL SCALE(fits) = NO SIMPLE(fits) = YES # This xtension was set in rft_read_header if (EXTEND(fits) != IMAGE_IUE) EXTEND(fits) = NO NRECORDS(fits) = 0 ndiscard = 0 OBJECT(fits) = EOS IRAFNAME(fits) = EOS OPSIZE(fits) = -1 GCOUNT(fits) = -1 # The max_lenuser value should be smaller by the length of the # group parameter block in case we exhaust the buffer with header # cards and then we would not have space to put the gpb cards # that the stf kernel would put to the existing header. max_lenuser = ARB - 3200 maxcards = max_lenuser/LEN_CARD # fd_usr = open ("fits_hdr", READ_WRITE, SPOOL_FILE) # Do not call again if coming from ftb_rheader if (EXTEND(fits) != IMAGE_IUE) i = rft_init_read_pixels (len_record, FITS_BYTE, LSBF, TY_CHAR) # Loop until the END card is encountered nread = 0 repeat { i = rft_read_pixels (fits_fd, card, LEN_CARD, NRECORDS(fits), 1) if ((i == EOF) && (nread == 0)) { # At EOT call close(fd_usr) return (EOF) } else if (EXTEND(fits) == IMAGE_IUE) { nread = nread + 1 EXTEND(fits) = NO # here is the change to fix the cd block size problems with apple readers # } else if ((nread == 0) && strmatch (card, "^SIMPLE ") == 0) { } else if ((nread == 0) && find_simple (fits_fd, card, LEN_CARD) == 0) { call flush (STDOUT) call error (30, "RFT_READ_HEADER: Not a FITS file") } else if (i != LEN_CARD) { call error (2, "RFT_READ_HEADER: Error reading FITS header") } else nread = nread + 1 # Print FITS card images if long_header option specified if (long_header == YES) { call printf ("%s") call pargstr (card) call flush (STDOUT) } if (maxcards == nread) ndiscard = 1 stat = rft_decode_card (fits, fd_usr, card, ndiscard) } until (stat == YES) # stat == YES if END card encountered. if (OPSIZE(fits) == -1 && gkey == TO_MG) { # NO OPSIZE keyword gkey = DEF_GPB call printf ("Warning: fits file cannot be convert to multigroup\n") } if (ndiscard > 0) { call printf ("Warning: User area too small %d card images discarded\n") call pargi (ndiscard) } return (nread) end define NBITS_CHAR (SZB_CHAR * NBITS_BYTE) # RFT_DECODE_CARD -- Decode a FITS card and return YES when the END # card is encountered. The keywords understood are given in fits.h. int procedure rft_decode_card (fits, fd_usr, card, ndiscard) pointer fits # FITS data structure int fd_usr # file descriptor of user area char card[LEN_CARD] # FITS card int ndiscard # Number of cards for which no space available pointer pn char cval, str[LEN_CARD], cdpat[SZ_LINE] double dval int nchar, i, j, k, len, ndim bool rft_equald() int strmatch(), ctoi(), ctol(), ctod(), cctoc(), rft_hms() int patmake(), patmatch(), date, origin errchk putline include "rfits.com" begin i = COL_VALUE if (strmatch (card, "^END ") != 0) { return(YES) } else if (strmatch (card, "^SIMPLE ") != 0) { nchar = cctoc (card, i, cval) if (cval != 'T') { call printf("RFT_DECODE_CARD: Non-standard FITS format \n") SIMPLE(fits) = NO } } else if (strmatch (card, "^BITPIX ") != 0) { nchar = ctoi (card, i, BITPIX(fits)) ieee = NO if (BITPIX(fits) < 0) { ieee = YES BITPIX(fits) = -BITPIX(fits) } nchar = patmake ("CD[1-7]_[1-7]", cdpat, SZ_LINE) } else if (strmatch (card, "^BLANK ") != 0) { BLANKS(fits) = YES nchar = ctol (card, i, BLANK_VALUE(fits)) } else if (strmatch (card, "^NAXIS ") != 0) { nchar = ctoi (card, i, NAXIS(fits)) if (NAXIS(fits) > IM_MAXDIM) call error (5, "RFT_DECODE_CARD: FITS NAXIS too large") # assume default values for CWS ndim = NAXIS(fits) do k = 1, ndim { pn = WCS_PDES(fits,k) CRVAL(pn) = 1.0 CRPIX(pn) = 1.0 CDELT(pn) = 1.0 CROTA(pn) = 0.0 call strcpy ("PIXEL", CTYPE(pn), SZ_WCSCTYPE) do j = 1, ndim { if (k == j) CDMATRIX(pn,j) = 1.0 else CDMATRIX(pn,j) = 0.0 } } date= YES origin = YES MAKE_CD(fits) = YES } else if (strmatch (card, "^NAXIS") != 0) { k = strmatch (card, "^NAXIS") nchar = ctoi (card, k, j) nchar = ctol (card, i, NAXISN(fits,j)) call strcpy (" ", RA(fits), LEN_CARD) call strcpy (" ", DEC(fits), LEN_CARD) call strcpy (" ", DATE(fits), LEN_CARD) } else if (strmatch (card, "^BLOCKED ") != 0) { # Just ignore the card } else if (strmatch (card, "^GROUPS ") != 0) { nchar = cctoc (card, i, cval) if (cval == 'T') { call error (6, "RFT_DECODE_CARD: Group data not implemented") } } else if (strmatch (card, "^SDASMGNU") != 0) { nchar = ctoi (card, i, GCOUNT(fits)) if (gkey != TO_MG) gkey = NON_GPB # If the number of rows is zero, then there is no attached # table, since the original file has PCOUNT = 0. if (GCOUNT(fits) >= 1 && gkey != TO_MG) call putline (fd_usr, card) MAKE_CD(fits) = NO } else if (strmatch (card, "^EXTEND ") != 0) { nchar = cctoc (card, i, cval) if (cval == 'T') { EXTEND(fits) = YES } } else if (strmatch (card, "^EXTNAME ") != 0) { call rft_get_fits_string (card, OBJECT(fits), LEN_CARD) call strcat (" (Xtension)",OBJECT(fits), LEN_CARD) call putline (fd_usr, card) } else if (strmatch (card, "^BSCALE ") != 0) { nchar = ctod (card, i, dval) if (! rft_equald (dval, 1.0d0) && scale == YES) SCALE(fits) = YES FITS_BSCALE(fits) = dval } else if (strmatch (card, "^BZERO ") != 0) { nchar = ctod (card, i, dval) if (! rft_equald (dval, 0.0d0) && scale == YES) SCALE(fits) = YES FITS_BZERO(fits) = dval } else if (strmatch (card, "^DATAMAX ") != 0) { if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^DATAMIN ") != 0) { if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^IRAF-MAX") != 0) { if (gkey < 0) call putline (fd_usr, card) } else if (strmatch (card, "^IRAF-MIN") != 0) { if (gkey < 0) call putline (fd_usr, card) } else if (strmatch (card, "^IRAF-B/P") != 0) { if (gkey < 0) call putline (fd_usr, card) } else if (strmatch (card, "^IRAFTYPE") != 0) { call rft_get_fits_string (card, FITSTYPE(fits), LEN_CARD) if (gkey <0) call putline (fd_usr, card) } else if (strmatch (card, "^OBJECT") != 0) { call rft_get_fits_string (card, OBJECT(fits), LEN_CARD) call putline (fd_usr, card) } else if (strmatch (card, "^IRAFNAME") != 0) { call rft_get_fits_string (card, IRAFNAME(fits), LEN_CARD) } else if (strmatch (card, "^ORIGIN ") != 0) { if (origin == NO) # don'take the first one if more than one call putline (fd_usr, card) origin = NO } else if (strmatch (card, "^OPSIZE ") != 0) { # Save if we want to create a multigroup image if (gkey == TO_MG) nchar = ctoi (card, i, OPSIZE(fits)) } else if (strmatch (card, "^FITSDATE") != 0) { # dont put in image header } else if (strmatch (card, "^DATE ") != 0) { if (date == YES) call rft_get_fits_string (card, DATE(fits), LEN_CARD) call putline (fd_usr, card) date = NO } else if (strmatch (card, "^HISTORY ") != 0) { # put all the history that "imuserarea" allows if (ndiscard >= 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^CRVAL") != 0) { k = strmatch (card, "^CRVAL") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CRVAL(pn) = dval if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^CRPIX") != 0) { k = strmatch (card, "^CRPIX") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CRPIX(pn) = dval if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^CDELT") != 0) { k = strmatch (card, "^CDELT") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CDELT(pn) = dval call putline (fd_usr, card) } else if (strmatch (card, "^CROTA") != 0) { k = strmatch (card, "^CROTA") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) nchar = ctod (card, i, dval) CROTA(pn) = dval call putline (fd_usr, card) } else if (strmatch (card, "^CTYPE") != 0) { k = strmatch (card, "^CTYPE") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) call rft_get_fits_string (card, CTYPE(pn), SZ_OBJECT) if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (patmatch (card, cdpat) != 0) { k = strmatch (card, "^CD") nchar = ctoi (card, k, j) pn = WCS_PDES(fits,j) k = strmatch (card, "^CD?_") nchar = ctoi (card, k, j) nchar = ctod (card, i, dval) CDMATRIX(pn,j) = dval MAKE_CD(fits) = NO if (gkey != DEF_GPB) call putline (fd_usr, card) } else if (strmatch (card, "^UT ") != 0) { len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("UT", str, len, card, "right ascension") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^ZD ") != 0) { len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("ZD", str, len, card, "zenith distance") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^ST ") != 0) { len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("ST", str, len, card, "sidereal time") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^RA ") != 0) { call rft_get_fits_string (card, RA(fits), LEN_CARD) len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("RA", str, len, card, "right ascension") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else if (strmatch (card, "^DEC ") != 0) { call rft_get_fits_string (card, DEC(fits), LEN_CARD) len = rft_hms (card, str, LEN_CARD) if (len > 0) { call wft_encodec ("DEC", str, len, card, "declination") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS } if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } else { if (ndiscard > 1) ndiscard = ndiscard + 1 else { iferr (call putline (fd_usr, card)) ndiscard = ndiscard + 1 } } return (NO) end ��������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/obsolete/fits_rpixels.x��������������������������������0000664�0000000�0000000�00000011001�13321663143�0024676�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include define BUF_LEN 32760 # RFT_INIT_READ_PIXELS and READ_PIXELS -- Read pixel data with record buffering # and data type conversion. The input data must meet the MII standard # except for possibly having the least significant byte first. # # Read data in records of len_record and convert to the specified IRAF # data type. Successive calls of rft_read_pixels returns the next npix pixels. # Read_pixels returns EOF or the number of pixels converted. # Init_read_pixels must be called before read_pixels. # # Error conditions are: # 1. A short input record # 2. Error in converting the pixels by miiup. # # This routine is based on the MII unpack routine which is machine dependent. # The bitpix must correspond to an MII type. If the lsbf (least significant # byte first) flag is YES then the pixels do not satisfy the MII standard. # In this case the bytes are first swapped into most significant byte first # before the MII unpack routine is called. int procedure rft_init_read_pixels (npix_record, bitpix, lsbf, spp_type) int npix_record # Number of pixels per input record int bitpix # Bits per pixel (must correspond to an MII type) int lsbf # byte swap? int spp_type # SPP data type to be returned # entry rft_read_pixels (fd, buffer, npix) int rft_read_pixels int rft_ieee_read int fd # Input file descriptor pointer buf char buffer[BUF_LEN] # Output buffer int npix # Number of pixels to read int swap int ty_mii, ty_spp, npix_rec, nch_rec, sz_rec, nchars, len_mii, recptr int bufsize, i, n, ip, op, nd, new_ip pointer mii, spp, bufrd int read(), sizeof(), miilen(), nint_rec errchk mfree, malloc, read data mii/NULL/, spp/NULL/, bufrd/NULL/ include "rfits.com" begin ty_spp = spp_type swap = lsbf npix_rec = npix_record nch_rec = npix_rec * sizeof (ty_spp) if (ty_spp == TY_CHAR || ty_spp == TY_LONG) { ty_mii = bitpix len_mii = miilen (npix_rec, ty_mii) sz_rec = len_mii * SZ_INT if (mii != NULL) call mfree (mii, TY_INT) call malloc (mii, len_mii, TY_INT) ip = nch_rec } else { # is REAL or DOUBLE if (bufrd != NULL) call mfree (bufrd, TY_INT) nint_rec = npix_rec * sizeof (ty_spp) / 2 call malloc (bufrd, nint_rec, TY_INT) ip = npix_rec } if (spp != NULL) call mfree (spp, TY_CHAR) call malloc (spp, nch_rec, TY_CHAR) return (OK) entry rft_read_pixels (fd, buffer, npix, recptr, bufsize) nchars = npix * sizeof (ty_spp) op = 0 repeat { # If data is exhausted read the next record if (ip == nch_rec) { iferr (i = read (fd, Memi[mii], sz_rec)) { call fseti (fd, F_VALIDATE, bufsize * sz_rec) call printf ("Error reading record %d\n") if (mod (recptr + 1, bufsize) == 0) call pargi ((recptr + 1) / bufsize) else call pargi ((recptr + 1) / bufsize + 1) i = read (fd, Memi[mii], sz_rec) } if (i == EOF) return (EOF) if (swap == YES) switch (ty_mii) { case MII_SHORT: call bswap2 (Memi[mii], 1, Memi[mii], 1, sz_rec * SZB_CHAR) case MII_LONG: call bswap4 (Memi[mii], 1, Memi[mii], 1, sz_rec * SZB_CHAR) } call miiupk (Memi[mii], Memc[spp], npix_rec, ty_mii, ty_spp) ip = 0 recptr = recptr + 1 } n = min (nch_rec - ip, nchars - op) call amovc (Memc[spp+ip], buffer[1+op], n) ip = ip + n op = op + n } until (op == nchars) return (npix) entry rft_ieee_read(fd, buf, npix, recptr, bufsize) op = 0 repeat { # If data is exhausted read the next record if (ip == npix_rec) { iferr (i = read (fd, Meml[bufrd], nch_rec)) { call fseti (fd, F_VALIDATE, bufsize * nch_rec) call printf ("Error reading record %d\n") if (mod (recptr + 1, bufsize) == 0) call pargi ((recptr + 1) / bufsize) else call pargi ((recptr + 1) / bufsize + 1) i = read (fd, Meml[bufrd], nch_rec) } ip = 0 nd = 0 recptr = recptr + 1 } n = min (npix_rec - ip, npix - op) if (ty_spp == TY_REAL) { # call sun2vaxr (Meml[bufrd+ip], Memr[buf+op], n) call ieevupkr (Meml[bufrd+ip], Memr[buf+op], n) } else { # call sun2vaxd (Meml[bufrd+nd], Memd[buf+op], n) call ieevupkd (Meml[bufrd+nd], Memd[buf+op], n) # There are 2 Meml per Memd nd = nd + n * 2 } ip = ip + n op = op + n } until (op == npix) return (npix) entry rft_reset_ip (new_ip) ip = new_ip return (OK) end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/rfits.com����������������������������������������������0000664�0000000�0000000�00000001072�13321663143�0022014�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ # FITS reader common int len_record # Length of FITS records in bytes int data_type # Output data type real blank # Blank value # Option flags int long_header # Print a long header (FITS header cards) int short_header # Print a short header (Title and size) int tape # is input a mag tape? int scale # Scale the data int old_name # Use old IRAF name? int ieee # Fits data in IEEE floating point standard? int gkey # Image type to be created common /rfitscom/ len_record, data_type, blank, long_header, short_header, tape, scale, old_name, ieee, gkey ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/rfits.h������������������������������������������������0000664�0000000�0000000�00000007146�13321663143�0021475�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# FITS Definitions # The FITS standard readable by the FITS reader using these definitions: # # 1. 8 bits / byte # 2. ASCII character code # 3. MII data format (i.e. 8 bit unsigned integers and 16 and 32 bit signed # twos complement integers with most significant bytes first.) # See mii.h. # # The following deviations from the FITS standard are allowed: # # The number of FITS bytes per record is normally 2880 but may be specified # by the user. # Define the bits per pixel and precision of the 3 basic FITS types define SZ_MAXCOL 256 # Maximum number of columns define FITS_BYTE 8 # Bits in a FITS byte define FITS_SHORT 16 # Bits in a FITS short define FITS_LONG 32 # Bits in a FITS long define FITSB_PREC 3 # Decimal digits of precision in a FITS byte define FITSS_PREC 5 # Decimal digits of precision in a FITS short define FITSL_PREC 10 # Decimal digits of precision in a FITS long define LSBF NO # Least significant byte first define LEN_CARD 80 # Length of FITS card in characters define COL_VALUE 11 # Starting column for parameter values define IM_MAXDIM 7 define SZ_OBJECT 79 define SZ_EXTN 3 # default extension size define DEF_GPB 1 # gkey value for default group parameter desc. define NONDEF_GPB 2 # Non default gpb desc.; needs template define NON_GPB 3 # For image w/o gpb define TO_MG 4 # For immediate FITS w/xdim to multigroup. define IMAGE_IUE -99 # Values for the following keywords are stored in the structure below. define MAX_PCSTF 7 # max param descriptors for STF files define LEN_PDSTF 70 define LEN_FITS (67 + 2*70 + 1 + MAX_PCSTF*LEN_PDSTF) define FITS_BSCALE Memd[P2D($1)] # FITS scaling parameter define FITS_BZERO Memd[P2D($1+2)] # FITS zero parameter define BLANK_VALUE Meml[P2L($1+4)] # Blank value define BLANKS Memi[$1+5] # YES if blank keyword in header define BITPIX Memi[$1+6] # Bits per pixel (Must be an MII type) define SCALE Memi[$1+7] # Scale the data? define SIMPLE Memi[$1+8] # Standard FITS format define NRECORDS Memi[$1+9] # Number of FITS logical records define EXTEND Memi[$1+10] # Standard extension flag (tables) define FITS_NROWS Memi[$1+11] # Number of lines in table define FITS_ROWLEN Memi[$1+12] # Number of character per row define NAXIS Memi[$1+13] # Number of dimensions define NAXISN Memi[$1+14+$2-1] # Length of each axis (up to 7) define GCOUNT Memi[$1+22] define OPSIZE Memi[$1+23] # extra space define RA Memc[P2C($1+30)] # define DEC Memc[P2C($1+39)] # define DATE Memc[P2C($1+48)] # define FITSTYPE Memc[P2C($1+57)] define MAKE_CD Memi[$1+64] define OBJECT Memc[P2C($1+67)] # Up to 70 characters long define IRAFNAME Memc[P2C($1+138)]# idem # temporary storage for wcs information to be put on the STF files rigth # before closing the images. define WCS_PDES (($1) + 67 + 2*70 + ((($2)-1)*LEN_PDSTF)) define SZ_WCSCTYPE 8 # GPB Parameter descriptor. define CRVAL Memd[P2D($1)] define CRPIX Memr[$1+2] define CDELT Memd[P2D($1+4)] define CROTA Memd[P2D($1+6)] define CDMATRIX Memr[$1+($2-1)*7+8] define CTYPE Memc[P2C($1+61)] # Additional IRAF header parameters define PIXTYPE IM_PIXTYPE($1) define NBPIX IM_NBPIX($1) define IRAFMAX IM_MAX($1) define IRAFMIN IM_MIN($1) define LIMTIME IM_LIMTIME($1) # Mapping of FITS Keywords to IRAF image header define HISTORY IM_HISTORY($1) define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] # All unrecognized keywords # are stored here define SZ_OBJECT SZ_IMTITLE define SZ_HISTORY SZ_IMHIST define SZ_FCTYPE SZ_CTYPE # FITS cards not recognized by this header are stored in the USER AREA of # the image header (UNKNOWN) up to a maximum of: ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/rft_subs.x���������������������������������������������0000664�0000000�0000000�00000022432�13321663143�0022210�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include include "rfits.h" define SZ_KEYWORD 8 # UPDATE_GPB -- Procedure to update the WCS values. Since the image # created by rfits has access NEW_IMAGE, the gpb values are taken from # a template file and not from the fits header; this routine copy those # values into the image descriptor. This routines is called only if the # image created is of type STF. procedure update_gpb (im, fits) pointer im # image descriptor pointer fits # rfits descriptor pointer pn char keyname[SZ_KEYWORD] int k, i, ndim begin IM_UPDATE(im) = YES ndim = IM_NDIM(im) if (MAKE_CD(fits) == YES) call cd_matrix (im, fits) call sprintf (keyname, SZ_KEYWORD, "DATAMIN") call imputr (im, keyname, IM_MIN(im)) call sprintf (keyname, SZ_KEYWORD, "DATAMAX") call imputr (im, keyname, IM_MAX(im)) do k = 1, ndim { pn = WCS_PDES(fits,k) call sprintf (keyname, SZ_KEYWORD, "CRVAL%d") call pargi(k) call imputd (im, keyname, CRVAL(pn)) call sprintf (keyname, SZ_KEYWORD, "CRPIX%d") call pargi(k) call imputr (im, keyname, CRPIX(pn)) call sprintf (keyname, SZ_KEYWORD, "CTYPE%d") call pargi(k) call impstr (im, keyname, CTYPE(pn)) do i = 1, ndim { call sprintf (keyname, SZ_KEYWORD, "CD%d_%d") call pargi(k) call pargi(i) call imputr (im, keyname, CDMATRIX(pn,i)) } } end include # CD_MATRIX -- Procedure to calculate the CD matrix from the CDELT and CROTA # values. procedure cd_matrix (im, fits) pointer im # image descriptor pointer fits # rfits descriptor pointer pn, pn1, pn2 int ndim, sign1, sign2, i double sinrota, cosrota, radcrota begin ndim = IM_NDIM(im) # Convert CROTA and CDELT into the CD_ Matrix # 1_D case is trivial since CROTA = 0 pn1 = WCS_PDES(fits, 1) if ( ndim == 1 ) { CDMATRIX(pn1, ndim) = CDELT(pn1) } else if ( ndim >= 2 ) { pn2 = WCS_PDES(fits, 2) # Note that for coordinates for which CDELT/CROTA are fully descriptive # CROTA(1) = CROTA(2); if this is not the case then the CDi_j matrix # should be used directly and the following calculations are incorrect! radcrota = CROTA(pn1) / RADIAN cosrota = cos (radcrota) sinrota = sin (radcrota) sign1 = 1 sign2 = 1 if (CDELT(pn1) < 0) sign1= -1 if (CDELT(pn2) < 0) sign2= -1 #-- cd1_1 CDMATRIX(pn1,1) = CDELT(pn1) * cosrota #-- cd1_2 CDMATRIX(pn1,2) = abs(CDELT(pn2)) * sign1 * sinrota #-- cd2_1 CDMATRIX(pn2,1) = - abs(CDELT(pn1)) * sign2 * sinrota #-- cd2_2 CDMATRIX(pn2,2) = CDELT(pn2) * cosrota } if (ndim > 2) do i = 3, ndim { pn = WCS_PDES(fits, i) CDMATRIX(pn, i) = CDELT(pn) } end define SZ_KEYWORD 8 define NEPSILON 10.0d0 # RFT_CREATE_GPB -- Procedure to create WCS names. Since the image # created by rfits has access NEW_IMAGE, the gpb names are taken from # a template file and not from the fits header. This routine copy those # names into the image descriptor. This routines is called only if the # image created is of type STF. procedure rft_create_gpb (im, fd) pointer im # image descriptor pointer fd # text file descriptor char keyname[SZ_KEYWORD], card[LEN_CARD+1] int k, i, ndim string one "1" string zero "0" begin IM_UPDATE(im) = YES ndim = IM_NDIM(im) call sprintf (keyname, SZ_KEYWORD, "DATAMIN") call wft_encodec (keyname, zero, LEN_CARD, card, "") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS call putline (fd, card) call sprintf (keyname, SZ_KEYWORD, "DATAMAX") call wft_encodec (keyname, zero, LEN_CARD, card, "") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS call putline (fd, card) do k = 1, ndim { call sprintf (keyname, SZ_KEYWORD, "CRVAL%d") call pargi(k) call wft_encodec (keyname, one, LEN_CARD, card, "") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS call putline (fd, card) call sprintf (keyname, SZ_KEYWORD, "CRPIX%d") call pargi(k) call wft_encodec (keyname, one, LEN_CARD, card, "") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS call putline (fd, card) call sprintf (keyname, SZ_KEYWORD, "CTYPE%d") call pargi(k) call wft_encodec (keyname, "PIXEL", LEN_CARD, card, "") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS call putline (fd, card) do i = 1, ndim { call sprintf (keyname, SZ_KEYWORD, "CD%d_%d") call pargi(k) call pargi(i) if (i == k) call wft_encodec (keyname, one, LEN_CARD, card, "") else call wft_encodec (keyname, zero, LEN_CARD, card, "") card[LEN_CARD+1] = '\n' card[LEN_CARD+2] = EOS call putline (fd, card) } } end # RFT_HMS -- Procedure to decode a FITS HMS card from the mountain int procedure rft_hms (card, str, maxch) char card[LEN_CARD] # FITS card char str[LEN_CARD] # string int maxch # maximum number of characters int i, fst, lst, len, nmin, nsec char ch int stridx(), strldx(), strlen() begin # return if not a FITS string parameter if (card[COL_VALUE] != '\'') return (0) # get the FITS string call rft_get_fits_string (card, str, maxch) # test for blank string and for 2 colon delimiters if (str[1] == EOS) return (0) ch = ':' fst = stridx (ch, str) if (fst == 0) return (0) lst = strldx (ch, str) if (lst == 0) return (0) if (fst == lst) return (0) len = strlen (str) if (str[1] == '-') { nmin = lst - fst - 1 nsec = len - lst if (nmin == 2) str[fst+1] = '0' else { do i = fst + 2, lst str[i-1] = str[i] lst = lst - 1 len = len - 1 str[len+1] = EOS } if (nsec == 2) str[lst+1] = '0' else { do i = lst + 2, len str[i-1] = str[i] len = len - 1 str[len+1] = EOS } } else { do i = 1, len { if (str[i] == ' ' && i != 1) str[i] = '0' } } return (len) end # RFT_GET_FITS_STRING -- Extract a string from a FITS card and trim trailing # blanks. The EOS is marked by either ', /, or the end of the card. # There may be an optional opening ' (FITS standard). procedure rft_get_fits_string (card, str, maxchar) char card[LEN_CARD] # FITS card char str[LEN_CARD] # FITS string int maxchar # maximum number of characters int j, istart, nchar begin # Check for opening quote for (istart = COL_VALUE; istart <= LEN_CARD && card[istart] != '\''; istart = istart + 1) ; istart = istart + 1 # closing quote for (j = istart; (j= istart) && (card[j] == ' '); j = j - 1) ; nchar = min (maxchar, j - istart + 1) # copy string if (nchar <= 0) str[1] = EOS else call strcpy (card[istart], str, nchar) end # RFT_EQUALD -- Procedure to compare two double precision numbers for equality # to within the machine precision for doubles. bool procedure rft_equald (x, y) double x, y # the two numbers to be compared for equality int ex, ey double x1, x2, normed_x, normed_y begin if (x == y) return (true) call rft_normd (x, normed_x, ex) call rft_normd (y, normed_y, ey) if (ex != ey) return (false) else { x1 = 1.0d0 + abs (normed_x - normed_y) x2 = 1.0d0 + NEPSILON * EPSILOND return (x1 <= x2) } end # RFT_NORMED -- Normalize a double precision number x to the value normed_x, # in the range [1-10]. Expon is returned such that x = normed_x * # (10.0d0 ** expon). procedure rft_normd (x, normed_x, expon) double x # number to be normailized double normed_x # normalized number int expon # exponent double ax begin ax = abs (x) expon = 0 if (ax > 0) { while (ax < (1.0d0 - NEPSILON * EPSILOND)) { ax = ax * 10.0d0 expon = expon - 1 } while (ax >= (10.0d0 - NEPSILON * EPSILOND)) { ax = ax / 10.0d0 expon = expon + 1 } } if (x < 0) normed_x = -ax else normed_x = ax end # RFT_TRIM_CARD -- Procedure to trim trailing whitespace from the card procedure rft_trim_card (incard, outcard, maxch) char incard[LEN_CARD] # input FITS card image char outcard[LEN_CARD] # output FITS card int maxch # maximum size of card int ip begin ip = maxch while (incard[ip] == ' ') ip = ip - 1 call amovc (incard, outcard, ip) outcard[ip+1] = '\n' outcard[ip+2] = EOS end # RFT_LAST_USER -- Remove a partially written card from the data base procedure rft_last_user (user, maxch) char user[LEN_CARD] # user area int maxch # maximum number of characters int ip begin ip = maxch while (user[ip] != '\n') ip = ip - 1 user[ip+1] = EOS end # RFT_CLEAN_CARD -- Procedure to clean HISTORY card from any null value procedure rft_clean_card (incard, outcard, maxch) char incard[LEN_CARD] # input FITS card image char outcard[LEN_CARD] # output FITS card int maxch # maximum size of card int ip begin do ip = 1, maxch { if (incard[ip] == NULL) { call printf("%s \n") call pargstr(incard) incard[ip] = ' ' } } call amovc (incard, outcard, maxch) outcard[maxch+1] = '\n' outcard[maxch+2] = EOS end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/t_rfits.x����������������������������������������������0000664�0000000�0000000�00000013676�13321663143�0022045�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include "rfits.h" define MAX_RANGES 100 define LEN_EXTN 3 # RFITS -- Read FITS format data. Further documentation given in rfits.hlp procedure t_rfits() char infile[SZ_FNAME] # fits file char outfile[SZ_FNAME] # IRAF file char in_fname[SZ_FNAME] # input file name char out_fname[SZ_FNAME] # output file name char file_list[SZ_LINE] # list of tape files char template[SZ_FNAME] # template file char cluster[SZ_FNAME], tmp[SZ_FNAME] char root[SZ_FNAME], extn[LEN_EXTN], extn2[LEN_EXTN] pointer list int lenlist, junk int range[MAX_RANGES*2+1], nfiles, file_number, offset, stat, fits_record bool clgetb() char clgetc() int rft_get_image_type(), clgeti(), mtfile(), strlen(), btoi() int rft_read_fitz(), decode_ranges(), get_next_number(), fntgfnb() int fntlenb(), envfind(), strncmp() pointer fntopnb() real clgetr() int cl_index, cl_size, xdimtogf data fits_record/2880/ include "rfits.com" begin # Set up the standard output to flush on a newline call fseti (STDOUT, F_FLUSHNL, YES) # Get RFITS parameters. call clgstr ("fits_file", infile, SZ_FNAME) long_header = btoi (clgetb ("long_header")) short_header = btoi (clgetb ("short_header")) len_record = fits_record call clgstr ("iraf_file", outfile, SZ_FNAME) call clgstr ("template", template, SZ_FNAME) data_type = rft_get_image_type (clgetc ("datatype")) scale = btoi (clgetb ("scale")) blank = clgetr ("blank") old_name = btoi (clgetb ("oldirafname")) offset = clgeti ("offset") xdimtogf = btoi (clgetb ("xdimtogf")) # Allow only one type of output if (short_header == YES) long_header = NO # Compute the number of files to be converted tape = NO if (mtfile (infile) == YES) { tape = YES list = NULL if (infile[strlen(infile)] != ']') call clgstr ("file_list", file_list, SZ_LINE) else call strcpy ("1", file_list, SZ_LINE) if (short_header == YES) { call printf ("FILE# IRAFNAME Dimensions ") call printf (" BP DATE OBJECT\n") } } else { list = fntopnb (infile, YES) lenlist = fntlenb (list) if (lenlist > 0) { call sprintf (file_list, SZ_LINE, "1-%d") call pargi (lenlist) } else call sprintf (file_list, SZ_LINE, "0") if (short_header == YES) { call printf ("Fits_file IRAFNAME ") call printf (" Dimensions BP DATE OBJECT\n") } } # Decode the ranges if (decode_ranges (file_list, range, MAX_RANGES, nfiles) == ERR) call error (1, "T_RFITS: Illegal file number list") # Read successive FITS files, convert and write into a numbered # succession of output IRAF files. cl_size = -1 cl_index = -1 call imparse (outfile, cluster, SZ_FNAME, tmp, SZ_FNAME, tmp, SZ_FNAME, cl_index, cl_size) call strcpy (cluster, out_fname, SZ_FNAME) # Create output filename with multigroup syntax, disable old_name # parameter since we cannot rename the output GEIS file to whatever # the IRAFNAME FITS keyword has. if (cl_size > 1) { old_name = NO call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, "[1/%d]") call pargi (cl_size) } # See if there is an extension call iki_parse (cluster, root, extn) if (extn[1] == EOS) { if (envfind ("imtype", extn, SZ_FNAME) <= 0) # No extension encountered. If there is a template file # get its extension and use that for the output file. if (strlen (template) !=0) { call iki_parse (template, root, extn) } else { # Assume 'hhh' since we are using STSDAS. If the user # has not supplied and output extension he/she will # the above. call strcpy ("hhh", extn, LEN_EXTN) } call iki_mkfname (root, extn, cluster, SZ_FNAME) call strcpy (cluster, out_fname, SZ_FNAME) } # Set the type of output file (gkey) for "imh" files. if (strncmp (extn, "imh", LEN_EXTN) == 0) gkey = -1 if (gkey == -1 && xdimtogf == YES) call error (1, "You cannot select the 'imh' extension and xdimtogf") file_number = 0 while (get_next_number (range, file_number) != EOF) { # Set the type of output file. # For the explanation on the values see fits_read.x if (gkey != -1) gkey = DEF_GPB if (xdimtogf == YES) gkey = TO_MG # Get input file name if (list != NULL) junk = fntgfnb (list, in_fname, SZ_FNAME) else { call strcpy (infile, in_fname, SZ_FNAME) if (infile[strlen(infile)] != ']') { call sprintf (in_fname[strlen(in_fname)+1], SZ_FNAME, "[%d]") call pargi (file_number) } } # Get output file name if (cl_index > 1) { template[1] = EOS call sprintf (out_fname[strlen(out_fname)+1], SZ_FNAME, "[%d]") call pargi (cl_index) } if (nfiles > 1 && cl_size == 0) { call iki_parse (out_fname, root, extn2) call sprintf (root[strlen(root)+1], SZ_FNAME, "%03d") call pargi (file_number + offset) call iki_mkfname (root, extn, out_fname, SZ_FNAME) } if (nfiles > 1 && cl_size != 0) cl_index = cl_index + 1 # Convert FITS file to the output IRAF file. # If EOT is reached then exit. # If an error is detected then print a warning and continue with # the next file. iferr (stat = rft_read_fitz (in_fname, template, out_fname)) call erract (EA_FATAL) if (stat == EOF) break call strcpy (cluster, out_fname, SZ_FNAME) } if (list != NULL) call fntclsb (list) end define NTYPES 7 # RFT_GET_IMAGE_TYPE -- Convert a character to and IRAF image type. int procedure rft_get_image_type (c) char c int type_codes[NTYPES], i int stridx() string types "usilrdx" # supported image data types data type_codes /TY_USHORT, TY_SHORT, TY_INT, TY_LONG, TY_REAL, TY_DOUBLE, TY_COMPLEX/ begin i = stridx (c, types) if (i == 0) return (ERR) else return (type_codes[stridx(c,types)]) end ������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/tab.com������������������������������������������������0000664�0000000�0000000�00000001100�13321663143�0021423�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Table column descriptors char colname[SZ_COLNAME] # Column name char colunits[SZ_COLUNITS] # Column units char colfmt[SZ_COLFMT] # Column print format int tbcol[SZ_MAXCOL] # starting position for each table column int tbcw[SZ_MAXCOL] # width field in character (from TBFORM) int datat, lendata, coln char tnull[SZ_COLUNITS, SZ_MAXCOL] # null value for each column real tzero[SZ_MAXCOL] # offset value for each column real tscal[SZ_MAXCOL] # scale value for each column common /ctables/ colname, colunits, colfmt, tbcol, tbcw, datat, lendata, coln, tnull, tzero, tscal ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/wfits.h������������������������������������������������0000664�0000000�0000000�00000007461�13321663143�0021502�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Wfits header file # Mapping of FITS keywords to IRAF image header define NAXIS IM_NDIM($1) # Number of dimensions define NAXISN IM_LEN($1, $2) # Length of each dimension define OBJECT IM_TITLE($1) # Image title define HISTORY IM_HISTORY($1) # History define UNKNOWN Memc[($1+IMU-1)*SZ_STRUCT+1] # IRAF user area define PIXTYPE IM_PIXTYPE($1) define NBPIX IM_NBPIX($1) define LIMTIME IM_LIMTIME($1) define MTIME IM_MTIME($1) define CTIME IM_CTIME($1) define LEN_ORIGIN 9 # Length of origin keyword define LEN_OBJECT 63 # Maximum length of string parameter define LEN_BLANK 11 # Length of the blank string define LEN_STRING 8 # Minimum length of a FITS string # Set up a structure for FITS parameters define LEN_FITS (44 + SZ_FNAME + 1) define BSCALE Memd[P2D($1)] # FITS bscale value define BZERO Memd[P2D($1+2)] # FITS bzero value define TAPEMAX Memd[P2D($1+4)] # IRAF tape max define TAPEMIN Memd[P2D($1+6)] # IRAF tape min define IRAFMAX Memr[$1+8] # IRAF image maximum define IRAFMIN Memr[$1+9] # IRAF image minimum define BLANK Meml[P2L($1+10)]# FITS blank value define FITS_BITPIX Memi[$1+11] # FITS bits per pixel define DATA_BITPIX Memi[$1+12] # Data bits per pixel define SCALE Memi[$1+13] # Scale data? define FITS_NAXIS Memi[$1+14] # Iraf number of axis define BLANK_STRING Memc[P2C($1+19)]# String containing FITS blank value define TYPE_STRING Memc[P2C($1+31)]# String containing IRAF type define IRAFNAME Memc[P2C($1+41)]# IRAF file name define FITS_ROWLEN SCALE # Use one location of FITS structure # define FITS data types define FITS_BYTE 8 # Number of bits in a FITS byte define FITS_SHORT 16 # Number of bits in a FITS short define FITS_LONG 32 # NUmber of bits in a FITS long # define FITS precision in decimal digits define BYTE_PREC 3 # Precision of FITS byte define SHORT_PREC 5 # Precision of FITS short define LONG_PREC 10 # Precision of FITS long # define FITS blank values define BYTE_BLANK 0.0d0 # Blank value for a FITS byte define SHORT_BLANK -3.2768d4 # Blank value for a FITS short define LONG_BLANK -2.147483648d9 # Blank value for a FITS long # define FITS max and min values define BYTE_MAX 2.55d2 # Max value for a FITS byte define BYTE_MIN 1.0d0 # Min value for a FITS byte define SHORT_MAX 3.2767d4 # Max value for a FITS short define SHORT_MIN -3.2767d4 # Min value for a FITS short define LONG_MAX 2.147483647d9 # Max value for a FITS long define LONG_MIN -2.147483647d9 # Min value for a FITS long # define the FITS card image parameters define LEN_CARD 80 # Length of FITS header card define LEN_KEYWORD 8 # Length of FITS keyword define COL_VALUE 11 # First column of field define NDEC_REAL 7 # Precision of real # NZ Aug 18 '89. Change value 11 to 14 define NDEC_DOUBLE 14 # Precision of double # define the KEYWORD parameters define NOPTIONS 12 # Number of optional keywords define FIRST_CARD 1 define SECOND_CARD 2 define THIRD_CARD 3 define FOURTH_CARD 4 define FIFTH_CARD 5 define SIXTH_CARD 6 define SEVENTH_CARD 7 define EIGHTH_CARD 8 define NINTH_CARD 9 # define optional header keywords define KEY_BSCALE 1 # FITS bscale parameter define KEY_BZERO 2 # FITS bzero parameter define KEY_BUNIT 3 # FITS physical units define KEY_BLANK 4 # FITS value of blank pixel define KEY_OBJECT 5 # FITS title string define KEY_ORIGIN 6 # origin of FITS tape define KEY_DATE 7 # date the tape was written define KEY_IRAFNAME 8 # root name of IRAF image define KEY_IRAFMAX 9 # maximum value of IRAF image define KEY_IRAFMIN 10 # minimum value of IRAF image define KEY_IRAFBP 11 # bits per pixel in IRAF image define KEY_IRAFTYPE 12 # IRAF image data type define KEY_SDASMGNU 13 # Number of groups in input image # miscellaneous define CENTURY 1900 define SZ_MAXCOL 256 # Maximum number of columns for tables # for table information. ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/cdrfits/wft_encodec.x������������������������������������������0000664�0000000�0000000�00000001677�13321663143�0022651�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas include "wfits.h" # WFT_ENCODEC -- Procedure to encode an IRAF string parameter into a FITS card. procedure wft_encodec (keyword, param, maxch, card, comment) char keyword[LEN_CARD] # FITS keyword char param[LEN_CARD] # FITS string parameter int maxch # maximum number of characters in string parameter char card[LEN_CARD+1] # FITS card image char comment[LEN_CARD] # comment string int nblanks, maxchar, slashp begin maxchar = max(8, min (maxch, LEN_OBJECT)) slashp = 32 nblanks = LEN_CARD - (slashp + 1) if (maxchar > 19) { slashp = 1 nblanks = max (LEN_OBJECT - maxchar - slashp+3, 1) } call sprintf (card, LEN_CARD, "%-8.8s= '%*.*s' %*t/ %*.*s") call pargstr (keyword) call pargi (-maxchar) call pargi (maxchar) call pargstr (param) call pargi (slashp) call pargi (-nblanks) call pargi (nblanks) call pargstr (comment) end �����������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/disppars.par���������������������������������������������������0000664�0000000�0000000�00000001227�13321663143�0021062�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������subsample,i,h,1,1,,"Sampling factor, for display marking only" frame,i,h,1,1,4,"Display frame number" imcur,*imcur,h,"",,,"Image cursor\n" marker,s,h,"circle","point|circle|rectangle|plus|cross",,"Marker type" omarker,s,h,"plus","point|circle|rectangle|plus|cross",,"Overlay marker type\n" goodcolor,s,h,"blue","black|white|red|green|blue|yellow",,"Color of good marker" badcolor,s,h,"red","black|white|red|green|blue|yellow",,"Color of bad marker" objcolor,s,h,"green","black|white|red|green|blue|yellow",,"Color of program object marker\n" centcolor,s,h,"yellow","black|white|red|green|blue|yellow",,"Color of centered program object marker\n" mode,s,h,"ql" �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/dssfinder.cl���������������������������������������������������0000664�0000000�0000000�00000016126�13321663143�0021036�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure dssfinder (image) string image {prompt="DSS image name"} string objects = "" {prompt="List of program object X,Y coords\n"} bool update = no {prompt="Update image header WCS following fit?"} bool interactive = yes {prompt="Enter interactive image cursor loop?"} bool autocenter = no {prompt="Center at the catalog coords when entering task?"} bool autodisplay = yes {prompt="Redisplay after all-source keystroke command?\n"} real pangle = 0. {prompt="Position angle (CCW positive)\n"} int boxsize = 9 {prompt="Centering box full width",min=1} int subsample = 1 {prompt="Sampling factor, for display marking only"} int frame = 1 {prompt="Display frame number\n"} begin string north = "top" string east = "left" string marker = "circle" string omarker = "plus" string goodcolor = "blue" string badcolor = "red" string objcolor = "green" string date_obs = "" real edge = 200. # real pangle = 0. real scale = 1.7 real equinox = 2000. real xref = INDEF real yref = INDEF bool opaxis = no real pi = 3.14159265358979 bool firsttime = yes bool newobjects = yes string table, database, logfile, cdecsign real ra, dec, rah, ram, ras, decd, decm, decs real cra, cdec, crah, cram, cras, cdecd, cdecm, cdecs real del_ra, del_dec # real amdx1, amdx2, amdy1, amdy2 # real pangle string ra_ref, dec_ref real eq_ref string limage, tmp1, tmp2, buf1, buf2, lrewrite bool lautocenter, lautodisplay, lreselect real naxis1, naxis2, width int junk cache ("tinfo", "tvmark_", "imgets") tmp1 = mktemp ("tmp$tmp") tmp2 = mktemp ("tmp$tmp") limage = image table = limage // ".tab" database = limage // ".db" logfile = limage // ".log" lautocenter = autocenter lautodisplay = autodisplay imgets (limage, "naxis1", >& "dev$null"); naxis1 = int (imgets.value) imgets (limage, "naxis2", >& "dev$null"); naxis2 = int (imgets.value) if (naxis1 == 0 || naxis2 == 0) error (1, "Problem reading image header") # would have to invert the phenomenological solution to retrieve correctly # imgets (limage, "amdx1", >& "dev$null"); amdx1 = real (imgets.value) # imgets (limage, "amdx2", >& "dev$null"); amdx2 = real (imgets.value) # imgets (limage, "amdy1", >& "dev$null"); amdy1 = real (imgets.value) # imgets (limage, "amdy2", >& "dev$null"); amdy2 = real (imgets.value) # # average the two sine terms from the rotation matrix using the # # small angle approximation for sine, and letting cos(pangle) ~ 1 # pangle = -90. * ((amdx2/amdy1) - (amdy2/amdx1)) / pi # pangle = 90. * ((amdx2/amdy1) - (amdy2/amdx1)) / pi #printf ("pangle = %.4f degrees\n", pangle) imgets (limage, "objctra", >& "dev$null") print (imgets.value) | scan (rah, ram, ras) ra = rah + (ram + ras/60.) / 60. imgets (limage, "objctdec", >& "dev$null") print (imgets.value) | scan (decd, decm, decs) dec = abs(decd) + (decm + decs/60.) / 60. if (decd < 0) dec = -dec hselect (limage, "pltrah,pltram,pltras", yes) | scan (crah, cram, cras) cra = crah + (cram + cras/60.) / 60. hselect (limage, "pltdecd,pltdecm,pltdecs", yes) | scan (cdecd, cdecm, cdecs) hselect (limage, "pltdecsn", yes) | scan (cdecsign) cdec = cdecd + (cdecm + cdecs/60.) / 60. if (cdecsign == "-") cdec = -cdec ra_ref = cra dec_ref = cdec eq_ref = equinox del_ra = 15. * (ra - cra) * cos (dec*pi/180.) del_dec = dec - cdec width = scale * (max (naxis1, naxis2) + edge) / 3600. if (access (table) || access (table // ".tab")) { printf ("Output table %s exists, ", table) if (_qpars.reopen) { firsttime = no if (lautocenter) lautocenter = _qpars.recenter } else { printf (" ...in that case, ") if (_qpars.replace) { tdelete (table, ver-, >& "dev$null") } else { printf ("\nChoose another table name and try again.\n") return } } } if (access (logfile)) { printf ("Log file %s exists", logfile) lrewrite = _qpars.rewrite if (lrewrite == "replace") { delete (logfile, ver-, >& "dev$null") } else if (lrewrite != "append") { printf ("\nChoose another filename and try again.\n") return } } if (logfile != "" && ! access (logfile)) printf ("", > logfile) if (firsttime) { if (interactive) print ("\nSearching the Guide Star Catalog index...") gscfind (ra, dec, equinox, width, > tmp1) if (interactive) { print ("\nReading the Guide Star Catalog regions:") type (tmp1) } cdrfits ("@" // tmp1, "1", "aka", template="", long_header=no, short_header=no, datatype="", blank=0., scale=yes, xdimtogf=no, oldirafname=yes, offset=0, > tmp2) delete (tmp1, ver-, >& "dev$null") if (interactive) { print ("\nExtracting overlapping sources from regions:") type (tmp2) } tfield ("@" // tmp2, table, image=limage, catpars="", ra=ra, dec=dec, epoch=equinox, date_obs=date_obs, width=width, xref=xref, yref=yref, opaxis=opaxis, del_ra=del_ra, del_dec=del_dec, north=north, east=east, pangle=pangle, scale=scale, edge=edge) tdelete ("@" // tmp2, ver-, >& "dev$null") delete (tmp2, ver-, >& "dev$null") } tinfo (table, ttout-) if (tinfo.nrows <= 0) { beep print ("\nNo Guide Stars selected for this field!") print ("Check the input parameters and images...") return } if (firsttime) tsort (table, "plate_id,region,gsc_id", ascend+, casesens+) # Provide reasonable defaults for the mark sizes, the extra # contour is for bolding (mostly for subsampling in saoimage). # This can be overridden within TPEAK by `:eparam tvmark_'. tvmark_.radii = (boxsize/2) // "," // (boxsize/2 + 1) tvmark_.lengths = (boxsize - 1) // "," // (boxsize + 1) if (interactive) { printf ("\nInteractive centering using TPEAK:\n") printf ( " The size of the markers matches the centering box ") printf ("(%d pixels).\n", boxsize) printf (" Change the size with the command `:eparam tvmark'.\n") } lreselect = tpeak.reselect if (! firsttime) { if (objects != "") { printf ("\nRead/reread objects '%s' into table '%s' ", objects, table) newobjects = _qpars.go_ahead } if (lreselect) { printf ("\nSelect a new catalog subset ") lreselect = _qpars.go_ahead } } if (newobjects) { tpeak (limage, table, database, objects=objects, ra_ref=ra_ref, dec_ref=dec_ref, eq_ref=eq_ref, autocenter=lautocenter, autodisplay=lautodisplay, reselect=lreselect, interactive=interactive, boxsize=boxsize, subsample=subsample, rotate=0., xscale=100., yscale=100., xshift=0, yshift=0, frame=frame, marker=marker, omarker=omarker, goodcolor=goodcolor, badcolor=badcolor, objcolor=objcolor, imcur="") } else { tpeak (limage, table, database, objects="", autocenter=lautocenter, ra_ref=ra_ref, dec_ref=dec_ref, eq_ref=eq_ref, autodisplay=lautodisplay, reselect=lreselect, interactive=interactive, boxsize=boxsize, subsample=subsample, rotate=0., xscale=100., yscale=100., xshift=0, yshift=0, frame=frame, marker=marker, omarker=omarker, goodcolor=goodcolor, badcolor=badcolor, objcolor=objcolor, imcur="") } if (logfile != "") logfile (table, logfile, append+) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/fprecess.x�����������������������������������������������������0000664�0000000�0000000�00000007051�13321663143�0020535�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include # F_PRECESS -- Precess coordinates from epoch1 to epoch2. # This is currently identical to ast_precess. Much efficiency could # be gained by calculating the precession matrices only once and by # avoiding the extra conversions to/from hours/degrees <--> radians. # The method used here is based on the new IAU system described in the # supplement to the 1984 Astronomical Almanac. The precession is # done in two steps; precess epoch1 to the standard epoch J2000.0 and then # precess from the standard epoch to epoch2. The precession between # any two dates is done this way because the rotation matrix coefficients # are given relative to the standard epoch. procedure f_precess (ra1, dec1, epoch1, ra2, dec2, epoch2) double ra1, dec1, epoch1 # First coordinates double ra2, dec2, epoch2 # Second coordinates double r0[3], r1[3], p[3, 3] bool fp_equald() begin # If the input epoch is 0 or undefined then assume the input epoch # is the same as the output epoch. If the two epochs are the same # then return the coordinates from epoch1. if ((epoch1 == 0.) || IS_INDEFD (epoch1) || IS_INDEFD (epoch2) || fp_equald(epoch1, epoch2)) { ra2 = ra1 dec2 = dec1 return } # Rectangular equitorial coordinates (direction cosines). ra2 = DEGTORAD (ra1 * 15.) dec2 = DEGTORAD (dec1) r0[1] = cos (ra2) * cos (dec2) r0[2] = sin (ra2) * cos (dec2) r0[3] = sin (dec2) # If epoch1 is not the standard epoch then precess to the standard # epoch. if (epoch1 != 2000.) { call f_rotmatrix (epoch1, p) # Note that we multiply by the inverse of p which is the # transpose of p. r1[1] = p[1, 1] * r0[1] + p[1, 2] * r0[2] + p[1, 3] * r0[3] r1[2] = p[2, 1] * r0[1] + p[2, 2] * r0[2] + p[2, 3] * r0[3] r1[3] = p[3, 1] * r0[1] + p[3, 2] * r0[2] + p[3, 3] * r0[3] r0[1] = r1[1] r0[2] = r1[2] r0[3] = r1[3] } # If epoch2 is not the standard epoch then precess from the standard # epoch to the desired epoch. if (epoch2 != 2000.) { call f_rotmatrix (epoch2, p) r1[1] = p[1, 1] * r0[1] + p[2, 1] * r0[2] + p[3, 1] * r0[3] r1[2] = p[1, 2] * r0[1] + p[2, 2] * r0[2] + p[3, 2] * r0[3] r1[3] = p[1, 3] * r0[1] + p[2, 3] * r0[2] + p[3, 3] * r0[3] r0[1] = r1[1] r0[2] = r1[2] r0[3] = r1[3] } # Convert from radians to hours and degrees. ra2 = RADTODEG (atan2 (r0[2], r0[1]) / 15.) dec2 = RADTODEG (asin (r0[3])) if (ra2 < 0.) ra2 = ra2 + 24 end # F_ROTMATRIX -- Compute the precession rotation matrix from the # standard epoch J2000.0 to the specified epoch. procedure f_rotmatrix (epoch, p) double epoch # Epoch of date double p[3, 3] # Rotation matrix double t, a, b, c, ca, cb, cc, sa, sb, sc double f_julday() begin # The rotation matrix coefficients are polynomials in time measured # in Julian centuries from the standard epoch. The coefficients are # in degrees. t = (f_julday (epoch) - 2451545.0) / 36525 a = t * (0.6406161 + t * (0.0000839 + t * 0.0000050)) b = t * (0.6406161 + t * (0.0003041 + t * 0.0000051)) c = t * (0.5567530 - t * (0.0001185 + t * 0.0000116)) # Compute the cosines and sines once for efficiency. ca = cos (DEGTORAD (a)) sa = sin (DEGTORAD (a)) cb = cos (DEGTORAD (b)) sb = sin (DEGTORAD (b)) cc = cos (DEGTORAD (c)) sc = sin (DEGTORAD (c)) # Compute the rotation matrix from the sines and cosines. p[1, 1] = ca * cb * cc - sa * sb p[2, 1] = -sa * cb * cc - ca * sb p[3, 1] = -cb * sc p[1, 2] = ca * sb * cc + sa * cb p[2, 2] = -sa * sb * cc + ca * cb p[3, 2] = -sb * sc p[1, 3] = ca * sc p[2, 3] = -sa * sc p[3, 3] = cc end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/ftimes.x�������������������������������������������������������0000664�0000000�0000000�00000007106�13321663143�0020213�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# F_DATE_TO_EPOCH -- Convert Gregorian date and solar mean time to # a Julian epoch. A Julian epoch has 365.25 days per year and 24 # hours per day. procedure f_date_to_epoch (year, month, day, ut, epoch) int year # Year int month # Month (1-12) int day # Day of month double ut # Universal time for date (mean solar day) double epoch # Julian epoch int yr int f_day_of_year() begin if (year < 100) yr = 1900 + year else yr = year ut = int (ut * 360000.d0 + 0.5d0) / 360000.d0 epoch = yr + (f_day_of_year (yr, month, day) - 1 + ut/24.d0) / 365.25d0 end # F_EPOCH_TO_DATE -- Convert a Julian epoch to year, month, day, and time. procedure f_epoch_to_date (epoch, year, month, day, ut) double epoch # Julian epoch int year # Year int month # Month (1-12) int day # Day of month double ut # Universal time for date int d int f_day_of_year() begin year = epoch d = (epoch - year) * 365.25 ut = ((epoch - year) * 365.25d0 - d) * 24.d0 ut = int (ut * 360000.d0 + 0.5d0) / 360000.d0 if (ut >= 24.d0) { d = d + 1 ut = ut - 24.d0 } d = d + 1 for (month=1; d >= f_day_of_year (year, month+1, 1); month=month+1) ; day = d - f_day_of_year (year, month, 1) + 1 end # F_DAY_OF_YEAR -- The day number for the given year is returned. int procedure f_day_of_year (year, month, day) int year # Year int month # Month (1-12) int day # Day of month int d int bom[13] # Beginning of month data bom/1,32,60,91,121,152,182,213,244,274,305,335,366/ begin d = bom[month] + day - 1 if (month > 2 && mod (year, 4) == 0 && (mod (year, 100) != 0 || mod (year, 400) == 0)) d = d + 1 return (d) end # F_DAY_OF_WEEK -- Return the day of the week for the given Julian day. # The integer day of the week is 0=Sunday - 6=Saturday. The character string # is the three character abbreviation for the day of the week. Note that # the day of the week is for Greenwich if the standard UT is used. procedure f_day_of_week (jd, d, name, sz_name) double jd # Julian date int d # Day of the week (0=SUN) char name[sz_name] # Name for day of the week int sz_name # Size of name string begin d = mod (int (jd - 0.5d0) + 2, 7) switch (d) { case 0: call strcpy ("SUN", name, sz_name) case 1: call strcpy ("MON", name, sz_name) case 2: call strcpy ("TUE", name, sz_name) case 3: call strcpy ("WED", name, sz_name) case 4: call strcpy ("THU", name, sz_name) case 5: call strcpy ("FRI", name, sz_name) case 6: call strcpy ("SAT", name, sz_name) } end # F_JULDAY -- Convert epoch to Julian day. double procedure f_julday (epoch) double epoch # Epoch int year, century double jd begin year = int (epoch) - 1 century = year / 100 jd = 1721425.5d0 + 365 * year - century + int (year / 4) + int (century / 4) jd = jd + (epoch - int(epoch)) * 365.25 return (jd) end # F_MST -- Mean sidereal time of the epoch at the given longitude. # This procedure may be used to optain Greenwich Mean Sidereal Time (GMST) # by setting the longitude to 0. double procedure f_mst (epoch, longitude) double epoch # Epoch double longitude # Longitude in degrees double jd, ut, t, st double f_julday() begin # Determine JD and UT, and T (JD in centuries from J2000.0). jd = f_julday (epoch) ut = (jd - int (jd) - 0.5) * 24. t = (jd - 2451545.) / 36525. # The GMST at 0 UT in seconds is a power series in T. st = 24110.54841d0 + t * (8640184.812866d0 + t * (0.093104d0 - t * 6.2d-6)) # Correct for longitude and convert to standard hours. st = mod (st / 3600. + ut - longitude / 15., 24.0D0) if (st < 0) st = st + 24 return (st) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/gscfind.par����������������������������������������������������0000664�0000000�0000000�00000002363�13321663143�0020654�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ra,r,a,,0.,24.,'Right Ascension of the field center (hours)' dec,r,a,,-90.,90.,'Declination of the field center (degrees)' epoch,r,a,INDEF,,,'Epoch of the field center coordinates' width,r,a,,0.,180.,'Width of the field (degrees)\n' north,s,h,'orion!/cdrom0',,,'Name (and node) for Northern CDrom (vol. 1)' south,s,h,'orion!/cdrom1',,,'Name (and node) for Southern CDrom (vol. 2)' index,f,h,finder$index,,,'Guide Star Catalog index table name' verbose,b,h,no,,,'Print verbose output on the STDERR?' nregions,i,h,0,0,,'Number of regions found [output]\n' region,s,h,'REG_NO',,,'Region number column name\n' rahlow,s,h,'RA_H_LOW',,,'Lower limit RA hours column name' ramlow,s,h,'RA_M_LOW',,,' minutes' raslow,s,h,'RA_S_LOW',,,' seconds\n' rahhi,s,h,'RA_H_HI',,,'Upper limit RA hours column name' ramhi,s,h,'RA_M_HI',,,' minutes' rashi,s,h,'RA_S_HI',,,' seconds\n' decsilow,s,h,'DECSI_LO',,,'Lower limit Dec sign column name' decdlow,s,h,'DEC_D_LO',,,' degrees' decmlow,s,h,'DEC_M_LO',,,' minutes\n' decsihi,s,h,'DECSI_HI',,,'Upper limit Dec sign column name' decdhi,s,h,'DEC_D_HI',,,' degrees' decmhi,s,h,'DEC_M_HI',,,' minutes\n' �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/logfile.cl�����������������������������������������������������0000664�0000000�0000000�00000005605�13321663143�0020476�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure logfile (table, logfile) string table {prompt="Output table name"} string logfile {prompt="Logfile for abridged table listing"} bool append = yes {prompt="Silently append to output?"} begin string sp_col = "" string ltable, llogfile, tmp1, lrewrite cache ("tinfo") tmp1 = mktemp ("tmp$tmp") ltable = table llogfile = logfile if (! append) { if (access (llogfile)) { printf ("Log file %s exists", llogfile) lrewrite = _qpars.rewrite if (lrewrite == "replace") { delete (llogfile, ver-, >& "dev$null") } else if (lrewrite != "append") { printf ("\nChoose another filename and try again.\n") return } } } if (! access (llogfile)) printf ("", > llogfile) # PROGRAM OBJECTS tselect (ltable, tmp1, "OBJ_FLAG == 1") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { print ("No program objects.", >> llogfile) } else { print ("List of program objects:\n", >> llogfile) tprint (tmp1, prparam=no, prdata=yes, pwidth=80, plength=0, showrow=yes, showhdr=yes, lgroup=0, columns="GSC_ID,X_CENTER,Y_CENTER,CEN_FLAG,SUB_FLAG", rows="-", option="plain", align=yes, sp_col=sp_col, >> llogfile) } # CENTERED CATALOG SOURCES tdelete (tmp1, ver-, >& "dev$null") tselect (ltable,tmp1, "CEN_FLAG == 1 && SUB_FLAG == 1 && OBJ_FLAG != 1") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { print ("\n\nNo sources were centered.", >> llogfile) } else { print ("\n\nList of successfully centered sources:\n", >> llogfile) tprint (tmp1, prparam=no, prdata=yes, pwidth=80, plength=0, showrow=yes, showhdr=yes, lgroup=0, columns="REGION,GSC_ID,X_CENTER,Y_CENTER,MAG_BAND,MAG,CLASS,PLATE_ID", rows="-", option="plain", align=yes, sp_col=sp_col, >> llogfile) } # UNCENTERED CATALOG SOURCES tdelete (tmp1, ver-, >& "dev$null") tselect (ltable,tmp1, "CEN_FLAG != 1 && SUB_FLAG == 1 && OBJ_FLAG != 1") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { print ("\n\nAll sources were centered.", >> llogfile) } else { print ("\n\nList of UNcentered sources:\n", >> llogfile) tprint (tmp1, prparam=no, prdata=yes, pwidth=80, plength=0, showrow=yes, showhdr=yes, lgroup=0, columns="REGION,GSC_ID,X_PRED,Y_PRED,MAG_BAND,MAG,CLASS,PLATE_ID", rows="-", option="plain", align=yes, sp_col=sp_col, >> llogfile) } # SOURCES OMITTED BY SELECTPARS tdelete (tmp1, ver-, >& "dev$null") tselect (ltable, tmp1, "SUB_FLAG != 1 && OBJ_FLAG != 1") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { print ("\n\nNo sources omitted by selectpars.", >> llogfile) } else { print ("\n\nList of sources omitted by selectpars:\n", >> llogfile) tprint (tmp1, prparam=no, prdata=yes, pwidth=80, plength=0, showrow=yes, showhdr=yes, lgroup=0, columns="REGION,GSC_ID,X_PRED,Y_PRED,MAG_BAND,MAG,CLASS,PLATE_ID,CEN_FLAG", rows="-", option="plain", align=yes, sp_col=sp_col, >> llogfile) } tdelete (tmp1, ver-, >& "dev$null") end ���������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/mkpkg����������������������������������������������������������0000664�0000000�0000000�00000000743�13321663143�0017567�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Make the FINDER package $call lfinder $call relink $exit update: $call relink $call install ; install: $move xx_finder.e mscbin$x_finder.e ; relink: $checkout x_finder.o mscbin$ $omake x_finder.x $link x_finder.o -lfinder -ltbtables -lxtools -o xx_finder.e $checkin x_finder.o mscbin$ ; lfinder: $checkout libfinder.a mscbin$ $update libfinder.a $checkin libfinder.a mscbin$ ; libfinder.a: @select t_tpeak.x ; �����������������������������mscred-5.05-2018.07.09/src/mscfinder/mktpeaktab.cl��������������������������������������������������0000664�0000000�0000000�00000003411�13321663143�0021171�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MKTPEAKTAB -- Make a table for TPEAK. # The input is a list of pixel coordinates and celestial coordinates. # An optional fifth column is a integer identification number. procedure mktpeaktab (input, output) file input {prompt="Input list (x y ra dec [id])"} file output {prompt="Output table for TPEAK"} bool centered = yes {prompt="Are (x,y) centered coordinates?"} struct *fd begin file temp1, temp2 real xpos, ypos, ra, dec int id, cen_flag if (access (input) == NO) error (1, "No input list of coordinates to make TPEAK table") # Load table tools. tables ttools temp1 = mktemp ("tmp$iraf") temp2 = mktemp ("tmp$iraf") # Make the table column description file. print (catpars.id_col // " i", > temp1) print (catpars.ra_col // " d h12.1 degrees", >> temp1) print (catpars.dec_col // " d h12.1 degrees", >> temp1) print (catpars.xpred_col // " r", >> temp1) print (catpars.ypred_col // " r", >> temp1) print (catpars.xcen_col // " r", >> temp1) print (catpars.ycen_col // " r", >> temp1) print (catpars.cerr_col // " r", >> temp1) print (catpars.cen_col // " i", >> temp1) print (catpars.sub_col // " i", >> temp1) print (catpars.obj_col // " i", >> temp1) print (catpars.region_col // " i", >> temp1) # Make the table data file. if (centered) cen_flag = 1 else cen_flag = 0 id = 0 fd = input while (fscan (fd, xpos, ypos, ra, dec, id) != EOF) { if (nscan () < 4) next else if (nscan() == 4) id = id + 1 ra = ra * 15 print (id, ra, dec, xpos, ypos, xpos, ypos, 0., cen_flag, 0, 0, 0, >> temp2) } fd = "" # Create the table. tcreate (output, temp1, temp2, uparfile="", nskip=0, nlines=0, nrows=0, hist=yes, extrapar=5, tbltype="default", extracol=0) delete (temp1, verify-) delete (temp2, verify-) end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/mscfinder.cl���������������������������������������������������0000664�0000000�0000000�00000001107�13321663143�0021020�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#{ MSCFINDER.CL -- Script to set up tasks in the MSCFINDER package proto tables ttools immatch package mscfinder task msctpeak = mscfinder$msctpeak.cl task mktpeaktab = mscfinder$mktpeaktab.cl hidetask mktpeaktab task tpltsol = mscfinder$tpltsol.cl task logfile = mscfinder$logfile.cl task tvmark_ = mscfinder$tvmark_.cl task catpars = mscfinder$catpars.par task selectpars = mscfinder$selectpars.par task _qpars = mscfinder$_qpars.par task tpeak = mscfinder$x_finder.e hidetask mktpeaktab, tpeak, tpltsol hidetask logfile, tvmark_, catpars, selectpars, _qpars clbye() ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/mscfinder.men��������������������������������������������������0000664�0000000�0000000�00000000075�13321663143�0021204�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ tpeak -- Interactively center objects from a table �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/msctpeak.cl����������������������������������������������������0000664�0000000�0000000�00000013442�13321663143�0020662�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCTPEAK -- Run TPEAK on a Mosaic image given a list of celestial coordinates. # The input is a list of WCS calibrated images and a list of ra(hours), # dec(degrees), and optional integer id. procedure msctpeak (images, coordinates, database) string images {prompt="List of WCS calibrated Mosaic images"} file coordinates {prompt="List of ra(hr), dec(deg), optional id"} file database {prompt="Database for astrometric fit"} string extname = "" {prompt="Extensions"} real epoch = 1950. {prompt="Coordinate epoch"} bool update = yes {prompt="Update image header WCS following fit?"} bool autocenter = no {prompt="Center catalog coords when entering task?"} int boxsize = 9 {prompt="Centering box fullwidth\n", min=1} string projection = "tan" {prompt="Sky projection geometry"} string fitgeometry = "general" {prompt="Fitting geometry", enum="|shift|xyscale|rotate|rscale|rxyscale|general"} string function = "polynomial" {prompt="Surface type", enum="|chebyshev|legendre|polynomial"} int xxorder = 3 {prompt="Order of xi fit in x", min=2} int xyorder = 3 {prompt="Order of xi fit in y", min=2} string xxterms = "half" {prompt="Xi fit cross terms type\n", enum="|none|half|full|"} int yxorder = 3 {prompt="Order of eta fit in x", min=2} int yyorder = 3 {prompt="Order of eta fit in y", min=2} string yxterms = "half" {prompt="Eta fit cross terms type?\n", enum="|none|half|full|"} real reject = INDEF {prompt="Rejection limit in sigma units\n"} bool interactive = yes {prompt="Enter interactive image cursor loop?"} int frame = 1 {prompt="Display frame number", min=1, max=4} string marker = "circle" {prompt="Marker type", enum="point|circle|rectangle|plus|cross"} string omarker = "plus" {prompt="Overlay marker type", enum="point|circle|rectangle|plus|cross"} string goodcolor = "blue" {prompt="Color of good marker", enum="black|white|red|green|blue|yellow"} string badcolor = "red" {prompt="Color of bad marker", enum="black|white|red|green|blue|yellow"} struct *fdimages struct *fdcoords begin file image, coords, db, temp1, temp2, temp3, temp4 int id, nc, nl real xpos, ypos, ra, dec, eq_ref string ra_ref, dec_ref cache mscextensions temp1 = mktemp ("tmp$iraf") temp2 = mktemp ("tmp$iraf") temp3 = mktemp ("tmp$iraf") temp4 = mktemp ("tmp$iraf") # Query parameters. image = images coords = coordinates db = database # Expand input image list. mscextensions (image, output="file", index="0-", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > temp1) if (mscextensions.nimages == 0) { delete (temp1, verify-) printf ("WARNING: No images found\n") return } # Expand the input coordinates. id = 0 fdcoords = coords while (fscan (fdcoords, ra, dec, id) != EOF) { if (nscan() < 2) next else if (nscan() == 2) id = id + 1 print (ra, dec, ra, dec, id, >> temp2) #xpos = ra * 15. #print (xpos, dec, ra, dec, id, >> temp2) } fdcoords = "" # Initialize psets. catpars.cat_epoch = epoch catpars.ra_col = "RA_DEG" catpars.dec_col = "DEC_DEG" catpars.region_col = "REGION" catpars.xpred_col = "X_PRED" catpars.ypred_col = "Y_PRED" catpars.xcen_col = "X_CENTER" catpars.ycen_col = "Y_CENTER" catpars.cerr_col = "CEN_ERR" catpars.datatype = "real" catpars.format = "%8.2f" catpars.units = "pixels" catpars.sub_col = "SUB_FLAG" catpars.cen_col = "CEN_FLAG" catpars.obj_col = "OBJ_FLAG" catpars.id_col = "ID" selectpars.explicit = "" selectpars.disjunction = no selectpars.column1 = "" selectpars.column2 = "" selectpars.column3 = "" selectpars.column4 = "" tpltsol.append = yes tpltsol.verbose = no tpltsol.inpixsys = "logical" tpltsol.outpixsys = "physical" tpltsol.projection = projection tpltsol.fitgeometry = fitgeometry tpltsol.function = function tpltsol.xxorder = xxorder tpltsol.xyorder = xyorder tpltsol.xxterms = xxterms tpltsol.yxorder = yxorder tpltsol.yyorder = yyorder tpltsol.yxterms = yxterms tpltsol.reject = reject #tvmark_.radii = 7 # Do each image. fdimages = temp1 while (fscan (fdimages, image) != EOF) { # Set image pixel coordinates based on WCS. mscctran (temp2, temp4, image, "world", "logical", columns="1 2", units="hours native", formats="", min_sigdigit=9, verbose=no) hselect (image, "naxis1,naxis2", yes) | scan (nc, nl) fdcoords = temp4 while (fscan (fdcoords, xpos, ypos, ra, dec, id) != EOF) { if (xpos < -9 || xpos > nc+10 || ypos < -9 || ypos > nl+10) next print (ra, dec, ra, dec, id, xpos, ypos, >> temp3) } fdcoords = "" delete (temp4, verify-) if (access (temp3) == NO) { printf ("Warning: No objects for `%s'\n", image) next } mscctran (temp3, temp4, image, "world", "logical", columns="1 2", units="hours native", formats="", min_sigdigit=9, verbose=no) delete (temp3, verify-) # Make database for TPEAK mktpeaktab (temp4, temp3//".fits", centered-) delete (temp4, verify-) # Run TPEAK. ra_ref = "INDEF" dec_ref = "INDEF" eq_ref = INDEF hselect (image, "telra,teldec,telepoch", yes) | translit ("STDIN", '"', delete+, collapse-) | scan (ra_ref, dec_ref, eq_ref) if (nscan() != 3) hselect (image, "ra,dec,equinox", yes) | translit ("STDIN", '"', delete+, collapse-) | scan (ra_ref, dec_ref, eq_ref) tpeak (image, temp3//".fits", db, objects="", ra_ref=ra_ref, dec_ref=dec_ref, eq_ref=eq_ref, update=update, interactive=interactive, autocenter=autocenter, autodisplay=no, boxsize=boxsize, xscale=100., yscale=100., xshift=0, yshift=0, reselect=yes, subsample=1, frame=frame, marker=marker, omarker=omarker, goodcolor=goodcolor, badcolor=badcolor) tdelete (temp3//".fits", verify-) } fdimages = "" delete (temp1, verify-) delete (temp2, verify-) end ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/mytchcol.par���������������������������������������������������0000664�0000000�0000000�00000000471�13321663143�0021057�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������table,s,a,"",,,"> name of table to be modified in-place" oldname,s,a,"",,,"> current column name" newname,s,a,"",,,"> new column name, or null" newfmt,s,a,"",,,"> new print format for column, or null" newunits,s,a,"",,,"> new column units, or null" verbose,b,h,yes,,,"> print operations performed?" mode,s,h,"al" �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/redo.cl��������������������������������������������������������0000664�0000000�0000000�00000000707�13321663143�0020004�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure redo (output) string output {prompt="Output root name"} bool overwrite = yes {prompt="Overwrite the previous files?"} begin string loutput loutput = output if (overwrite) { delete (loutput // ".out", ver-, >& "dev$null") delete (loutput // ".ast", ver-, >& "dev$null") delete (loutput // ".coo", ver-, >& "dev$null") } astrom (osfn(loutput//".in"), > loutput // ".out") rename ("astrom.lis", loutput // ".ast") end ���������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/��������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0020006�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/allrows.x�����������������������������������������������0000664�0000000�0000000�00000001174�13321663143�0021665�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include # ALLROWS -- Return a pointer to an array containing the indices of all # the rows in a table. The calling procedure must free the array when it # is through with it. # # B.Simon 11-Dec-87 First Code procedure allrows (tp, numrow, rowptr) pointer tp # i: Table descriptor int numrow # o: Number of rows in the table pointer rowptr # o: Pointer to array of indices int irow int tbpsta() errchk tbpsta, malloc begin numrow = tbpsta (tp, TBL_NROWS) call malloc (rowptr, numrow, TY_INT) do irow = 1, numrow Memi[rowptr+irow-1] = irow end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/change.x������������������������������������������������0000664�0000000�0000000�00000034253�13321663143�0021433�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # .help change .nf____________________________________________________________________________ This procedure searches for and replaces text patterns in a string. The text patterns are passed to the procedure as arguments, so this procedure can be used to perform a variety of text processing tasks. The procedure has five arguments: a target pattern string (from), a replacement pattern string (to), an input string (in), an output string (out), and a maximum length for the output string (maxch). The input and output strings cannot be the same string. The target and replacement pattern strings contain one or more patterns separated by a delimeter character, which is taken to be the first character in the string. Starting at the first character in the input string, the procedure looks at each pattern in the target string to see if it matches the input. When the first match is found, the corresponding string from the replacement pattern is moved to the output string. The characters that were matched by the target pattern are skipped over and the procedure searches for a new match with the target pattern. If no match is found, the character in the input string that was not matched is moved to the output string and the procedure searches for a new match at the next character. The syntax for the target and replacement pattern strings largely follows that used in the substitute command by the Unix text editors `ed' and `ex'. The pattern consists of a sequence of ordinary characters, which match themselves, and metacharacters, which match a set of characters. The delimeter character, which separates patterns, is also treated as a metacharacter. A metacharacter can be matched as if it were an ordinary character by preceding it with the escape character, `\'. For example, the escape character itself is indicated in a pattern by `\\'. The metacharacters which can be used in the target pattern are: beginning of string ^ end of string $ white space # escape character \ ignore case { end ignore case } begin character class [ end character class ] not, in char class ^ range, in char class - one character ? zero or more occurences * begin tagged string \( end tagged string \) A set of characters is indicated in the target string by the character class construct. For example, punctuation could be indicated by `[,;.!]'. A range of characters contiguous in the underlying character set can be abbreviated by the range construct. For example, `[a-z]' matches any lower case character. The complement of a character set is indicated by making `^' the first character in a class. For example, `[^0-9]' matches any non-digit. Repetition of a character or character class is indicated by the following it with the `*' metacharacter. Thus, zero or more occurences of a lower case character is indicated by `[a-z]*'. The tagged string metacharacters have no effect on the match, they only serve to identify portions of the matched string for the replacement pattern. The metacharacters which are used in the replacement pattern are the delimeter character and the following: entire string & tagged string \n capitalize \u upper case \U lower case \L end case conversion \e \E The ditto metacharacter, `&', indicates that the entire portion of the input string that was matched by the target pattern is to be moved into the output string. The tag metacharacter indicates that the n-th tagged string is to be moved into the output string. For example, `\1' indicates the first tagged string and `\2' the second. The remaining metacharacters affect the case of the output string. The capitalization metacharacter only affects the immediately following metacharacter, but the upper and lower case metacharacters must be turned off explicitly with `\e' or `\E'. The following are a few examples of the results that can be obtained with this subroutine: from to action ---- -- ------ |iraf|IRAF| |sdas|SDAS| convert all mentions of iraf to sdas |==|!=|&&|\|\||!| |eq|ne|and|or|not| convert boolean operators |[a-z][A-Za-z]*| |\u&| capitalize all words |"\([^"]*\)"| |'\1'| convert double quoted strings to single quoted strings |\([^,]*\),\(?*\)| |\2,\1| reverse two fields separated by commas .endhelp________________________________________________________________________ include include include "reloperr.h" # pattern codes used in replacement pattern define EOP -1 # end of pattern define DITTO -2 # substitute matched expression define TAG -3 # substitute tagged part of matched expression define CAP -4 # capitalize next char define UCASE -5 # convert to upper case define LCASE -6 # convert to lower case define ENDCASE -7 # end case conversion define PATSEP -127 # pattern separator define CH_DITTO '&' define CH_LTAG '(' define CH_RTAG ')' define CH_INDEX '%' # CHANGE -- Change all instances of one set of patterns into another set # # B.Simon 8-Dec-87 First code procedure change (from, to, in, out, maxch) char from[ARB] # i: Target pattern in input string char to[ARB] # i: Replacement pattern for output string char in[ARB] # i: Input string char out[ARB] # o: Output string int maxch # i: Maximum length of output string #-- int ic, nc, oc pointer pat, sub, nextpat, nextsub string mismatch "Number of to and from patterns must match" int patcode(), subcode(), pat_amatch() errchk patcode, subcode, pat_amatch, dosub begin # Encode the patterns and check to see that the number of patterns # in the set match if (patcode (from, pat) != subcode (to, sub)) call error (SYNTAX, mismatch) # Check each character in the input string for a match oc = 1 for (ic = 1; in[ic] != EOS; ic = ic + nc) { # Check each pattern with an anchored match # Substitute at the first match nc = 0 nextsub = sub nextpat = pat while (Memc[nextpat] != PATSEP) { nc = pat_amatch (in, ic, Memc[nextpat]) if (nc > 0) { call dosub (Memc[nextpat], Memc[nextsub], in, ic, ic+nc-1, out, oc, maxch) break } # Advance pointers to next patterns for ( ; Memc[nextpat] != PATSEP; nextpat = nextpat + 1) ; nextpat = nextpat + 1 for ( ; Memc[nextsub] != PATSEP; nextsub = nextsub + 1) ; nextsub = nextsub + 1 } # If no pattern was matched, move a single character to the # output string if (nc == 0) { call chdeposit (in[ic], out, maxch, oc) nc = 1 } } out[oc] = EOS call mfree (pat, TY_CHAR) call mfree (sub, TY_CHAR) end # PATCODE -- Encode the target pattern set # # B.Simon 8-Dec-87 First code int procedure patcode (from, pat) char from[ARB] # i: String containing target pattern pointer pat # o: Pointer to encoded pattern #-- char delim int ic, npat, lenpat, maxpat errchk addpat begin # Allocate memory for encoded pattern maxpat = SZ_LINE call malloc (pat, maxpat, TY_CHAR) npat = 0 lenpat = 0 # Get the delimeter character used between patterns delim = from[1] if (delim != EOS) { # Encode the next pattern in the from string ic = 2 while (from[ic] != EOS) { call addpat (delim, from, ic, pat, lenpat, maxpat) npat = npat + 1 } } Memc[pat+lenpat] = PATSEP # Return the number of patterns found return (npat) end # SUBCODE -- Encode the replacement pattern set # # B.Simon 8-Dec-87 First code int procedure subcode (to, sub) char to[ARB] # i: String containing replacement pattern pointer sub # o: Pointer to encoded pattern #-- char delim int ic, nsub, lensub, maxsub errchk addsub begin # Allocate memory for encoded pattern maxsub = SZ_LINE call malloc (sub, maxsub, TY_CHAR) nsub = 0 lensub = 0 # Get the delimeter character used between patterns delim = to[1] if (delim != EOS) { # Encode the next pattern in the to string ic = 2 while (to[ic] != EOS) { call addsub (delim, to, ic, sub, lensub, maxsub) nsub = nsub + 1 } } Memc[sub+lensub] = PATSEP # Return the number of patterns found return (nsub) end # ADDPAT -- Add the next encoded pattern to the target pattern set # # B.Simon 8-Dec-87 First code procedure addpat (delim, str, index, pat, lenpat, maxpat) char delim # i: Delimeter that marks the end of pattern char str[ARB] # i: String containing pattern int index # io: Index to start of pattern pointer pat # io: Encoded pattern set int lenpat # io: Current length of pattern set int maxpat # io: Maximum length of pattern set #-- char ch pointer sp, newpat, newstr int jdx,kdx int patmake() errchk patmake begin # Allocate dynamic memory for temporary strings call smark (sp) call salloc (newpat, SZ_LINE, TY_CHAR) call salloc (newstr, SZ_LINE, TY_CHAR) # Translate characters to suit pattern encoder jdx = 1 for ( ; str[index] != delim && str[index] != EOS; index = index + 1) { switch (str[index]) { case ESCAPE: if (str[index+1] == CH_LTAG || str[index+1] == CH_RTAG) { ch = CH_INDEX index = index + 1 } else if (str[index+1] == delim) { ch = delim index = index + 1 } else { ch = ESCAPE } case CH_INDEX: ch = ESCAPE call chdeposit (ch, Memc[newstr], SZ_LINE, jdx) ch = CH_INDEX default: ch = str[index] } call chdeposit (ch, Memc[newstr], SZ_LINE, jdx) } Memc[newstr+jdx-1] = EOS # Advance index past delimeter if (str[index] != EOS) index = index + 1 # Encode a single pattern kdx = patmake (Memc[newstr], Memc[newpat], SZ_LINE) Memc[newpat+kdx] = PATSEP kdx = kdx + 1 # Reallocate memory if new pattern will not fit if (lenpat + kdx > maxpat) { maxpat = 2 * maxpat call realloc (pat, maxpat, TY_CHAR) } # Add new pattern to pattern set call amovc (Memc[newpat], Memc[pat+lenpat], kdx) lenpat = lenpat + kdx call sfree (sp) end # ADDSUB -- Add the next encoded pattern to the replacement pattern set # # B.Simon 8-Dec-87 First code procedure addsub (delim, str, index, sub, lensub, maxsub) char delim # i: Delimeter that marks the end of pattern char str[ARB] # i: String containing pattern int index # io: Index to start of pattern pointer sub # io: Encoded pattern set int lensub # io: Current length of pattern set int maxsub # io: Maximum length of pattern set #-- char ch pointer sp, newsub, newstr int jdx,kdx int submake() errchk submake begin # Allocate dynamic memory for temporary strings call smark (sp) call salloc (newsub, SZ_LINE, TY_CHAR) call salloc (newstr, SZ_LINE, TY_CHAR) # Translate characters to suit pattern encoder jdx = 1 for ( ; str[index] != delim && str[index] != EOS; index = index + 1) { switch (str[index]) { case ESCAPE: if (str[index+1] == delim) { ch = delim index = index + 1 } else { ch = ESCAPE } default: ch = str[index] } call chdeposit (ch, Memc[newstr], SZ_LINE, jdx) } Memc[newstr+jdx-1] = EOS # Advance index past delimeter if (str[index] != EOS) index = index + 1 # Encode a single pattern kdx = submake (Memc[newstr], Memc[newsub], SZ_LINE) Memc[newsub+kdx] = PATSEP kdx = kdx + 1 # Reallocate memory if new pattern will not fit if (lensub + kdx > maxsub) { maxsub = 2 * maxsub call realloc (sub, maxsub, TY_CHAR) } # Add new pattern to pattern set call amovc (Memc[newsub], Memc[sub+lensub], kdx) lensub = lensub + kdx call sfree (sp) end # SUBMAKE -- Encode a single replacement pattern # # B.Simon 8-Dec-87 First code int procedure submake (str, buf, maxbuf) char str[ARB] # i: String to be encoded char buf[ARB] # o: Pattern buffer int maxbuf # i: Buffer size #-- char ch int idx, jdx int cctoc() begin jdx = 1 for (idx = 1; str[idx] != EOS; idx = idx + 1) { switch (str[idx]) { case CH_DITTO: ch = DITTO case ESCAPE: switch (str[idx+1]) { case 'u': ch = CAP idx = idx + 1 case 'U': ch = UCASE idx = idx + 1 case 'L': ch = LCASE idx = idx + 1 case 'e','E': ch = ENDCASE idx = idx + 1 default: if (IS_DIGIT (str[idx+1])) { ch = TAG call chdeposit (ch, buf, maxbuf, jdx) idx = idx + 1 ch = TO_INTEG (str[idx]) } else if (cctoc (str, idx, ch) == 1) { ch = str[idx] } else { idx = idx - 1 } } default: ch = str[idx] } call chdeposit (ch, buf, maxbuf, jdx) } buf[jdx] = EOP return (jdx) end # DOSUB -- Put the replacement pattern in the output string # # B.Simon 8-Dec-87 First code procedure dosub (pat, sub, in, first, last, out, oc, maxch) char pat[ARB] # i: Target pattern char sub[ARB] # i: Replacement pattern char in[ARB] # i: Input string int first # i: First character matched in input string int last # i: Last character matched in input string char out[ARB] # io: Output string int oc # io: Last character in output string int maxch # i: Maximum length of output string #-- int caseflag, ic, index, ltag, rtag int patindex() begin caseflag = ENDCASE for (ic = 1; sub[ic] != EOP; ic = ic + 1) { switch (sub[ic]) { case ENDCASE: caseflag = ENDCASE case LCASE: caseflag = LCASE case UCASE: caseflag = UCASE case CAP: caseflag = CAP case TAG: ic = ic + 1 index = (sub[ic] - 1) * 2 + 1 ltag = patindex (pat, index) rtag = patindex (pat, index+1) - 1 call movechars (in, ltag, rtag, caseflag, out, oc, maxch) case DITTO: call movechars (in, first, last, caseflag, out, oc, maxch) default: call movechars (sub, ic, ic, caseflag, out, oc, maxch) } } end # MOVECHARS -- Move input characters to the output string # # B.Simon 8-Dec-87 First code procedure movechars (str1, first, last, caseflag, str2, len, maxch) char str1[ARB] # i: Input string int first # i: First character to be moved int last # i: Last character to be moved int caseflag # io: Case conversion flag char str2[ARB] # io: Output string int len # io: Length of output string int maxch # i: Maximum length of output string #-- char ch int ic begin do ic = first, last { switch (caseflag) { case ENDCASE: ch = str1[ic] case LCASE: ch = str1[ic] if (IS_UPPER (ch)) ch = TO_LOWER (ch) case UCASE,CAP: ch = str1[ic] if (IS_LOWER (ch)) ch = TO_UPPER (ch) default: ch = str1[ic] } call chdeposit (ch, str2, maxch, len) if (caseflag == CAP) caseflag = ENDCASE } end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/mjd.x���������������������������������������������������0000664�0000000�0000000�00000004611�13321663143�0020753�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include "reloperr.h" define TFIELDS 7 define REQFIELD 3 # MJD -- Compute the modified julian date of a time expressed as a string # # Dates are of the form YYYYMMDD:HHMMSSCC (fields after the colon are optional). # If an optional field is not present, its value is considered to be zero. # Dates must be between 1 Jan 1858 and 31 Dec 2099 # # B.Simon 7-Oct_87 First Code double procedure mjd (date) char date[ARB] # i: String in the form YYYYMMDD:HHMMSSCC #-- int jd, datelen, it, ic int time[TFIELDS], tpos[2,TFIELDS], tlim[2,TFIELDS] pointer sp, errtxt double df data tpos / 1, 4, 5, 6, 7, 8, 10, 11, 12, 13, 14, 15, 16, 17 / data tlim / 1858, 2099, 1, 12, 1, 31, 0, 23, 0, 59, 0, 59, 0, 99 / string badfmt "Date has incorrect format (%s)" int strlen() begin # Allocate dynamic memory for error string call smark (sp) call salloc (errtxt, SZ_LINE, TY_CHAR) datelen = strlen (date) call aclri (time, TFIELDS) # Convert the date string into integer fields do it = 1, TFIELDS { # Check for absence of optional fields if (tpos[1,it] > datelen) { if (it > REQFIELD) break else { call sprintf (Memc[errtxt], SZ_LINE, badfmt) call pargstr (date) call error (SYNTAX, Memc[errtxt]) } } # Convert a field in the date string to an integer do ic = tpos[1,it], tpos[2,it] { if (IS_DIGIT(date[ic])) time[it] = 10 * time[it] + TO_INTEG(date[ic]) else { call sprintf (Memc[errtxt], SZ_LINE, badfmt) call pargstr (date) call error (SYNTAX, Memc[errtxt]) } } # Do bounds checking on the field # Some errors can slip thru, e.g., Feb 30 if ((time[it] < tlim[1,it]) || (time[it] > tlim[2,it])) { call sprintf (Memc[errtxt], SZ_LINE, badfmt) call pargstr (date) call error (SYNTAX, Memc[errtxt]) } } # Compute integer part of modified julian date # From Van Flandern & Pulkkinen ApJ Sup 41:391-411 Nov 79 jd = 367 * time[1] - 7 * (time[1] + (time[2] + 9) / 12) / 4 - 3 * ((time[1] + (time[2] - 9) / 7) / 100 + 1) / 4 + 275 * time[2] / 9 + time[3] - 678971 # Compute fractional part of modified julian date # N.B. julian date begins at noon, modified julian date at midnight df = double (time[7] + 100 * (time[6] + 60 * (time[5] + 60 * time[4]))) / 8640000.0 call sfree (sp) return (jd + df) end �����������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/mkpkg���������������������������������������������������0000664�0000000�0000000�00000000575�13321663143�0021051�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������$checkout libfinder.a mscbin$ $update libfinder.a $checkin libfinder.a mscbin$ $exit libfinder.a: select.x reloperr.h allrows.x change.x reloperr.h mjd.x reloperr.h tbleval.x reloperr.h tblterm.com \ tblterm.x reloperr.h tblterm.com \ ; �����������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/reloperr.h����������������������������������������������0000664�0000000�0000000�00000000065�13321663143�0022012�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������define SYNTAX 1 define BOUNDS 2 define PUTNULL 11 ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/select.x������������������������������������������������0000664�0000000�0000000�00000004762�13321663143�0021467�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include "reloperr.h" define SZ_EXP 1000 define FROM_STRING "/\"[^\"]\"/'[^']'/{.eq.}/{.and.}/{.or.}\ /{.gt.}/{.ge.}/{.lt.}/{.le.}/{.not.}/{.ne.}/" # SELECT -- Select table rows according to expression # # This procedure evaluates a boolean expession for selected rows in a table. # If the expression is true and does not involve null elements, the index # of that row is kept in the index array. # # B.Simon 7-Oct-87 First Code # B.Simon 16-Dec-87 Changed to handle table subsets procedure select (tp, expr, nindex, index) pointer tp # i: Table descriptor char expr[ARB] # i: Algebraic expression used in selection int nindex # io: Number of rows selected int index[ARB] # io: Indices of selected rows #-- char ch pointer sp, oldexp, newexp, ic, aryptr, nulptr int fd, sd, jc, dtype, nary, iary int open(), stropen(), stridx() errchk open, stropen, tbl_eval string badtype "Expression is not boolean" string from FROM_STRING string to "/&/&/ ==/ \&\&/ ||/ >/ >=/ include include include include "reloperr.h" # TBL_EVAL -- Evaluate an arbitrary expression over table columns # # This procedure receives as input a table descriptor, an index array, and # a character string containing an algebraic expression. The terms in the # expression are column names. The expression is evaluated for each row in # the index array using the values from the indicated columns and the results # stored in the output array (aryptr). The array pointed to by nulptr # contains null flags. A null flag is set to true if any of the table elements # in the expression is null or an arithmetic error ocurs during the # evaluation of the expression. Otherwise the null flag is set to false. # The type of the output array is determined by the type of the expression # unless all the elements are null, in which case the type input by the # calling routine is used. The two arrays pointed to by aryptr and nulptr # must be deallocated by the calling routine. # # B.Simon 29-Sept-87 First Code # B.Simon 16-Dec-87 Changed to handle table subsets # B.Simon 13-Apr-88 tbl_term, tbl_func moved to separate file procedure tbl_eval (tp, nindex, index, expr, dtype, aryptr, nulptr) pointer tp # i: Table descriptor int nindex # i: Number of elements in index array int index[ARB] # i: Array of row indices char expr[ARB] # i: Expression to be evaluated int dtype # io: Type of output array pointer aryptr # o: Array of output values pointer nulptr # o: Array of null flags #-- include "tblterm.com" int iary, status, junk int old_handler, tbl_term_adr, tbl_func_adr pointer op string badtype "Character expressions not allowed" int locpr(), errcode() pointer evexpr() extern tbl_handler(), tbl_term(), tbl_func() begin # Initialize output variables aryptr = NULL call malloc (nulptr, nindex, TY_BOOL) # Set up error handler to catch arithmetic errors call xwhen (X_ARITH, locpr(tbl_handler), old_handler) table = tp nterm = 0 constant = true tbl_term_adr = locpr (tbl_term) tbl_func_adr = locpr (tbl_func) # Loop over all rows of the table do iary = 1, nindex { irow = index[iary] iterm = 0 # Execution will resume here when an arithmetic error occurs call zsvjmp (jumpbuf, status) if (status != OK) { Memb[nulptr+iary-1] = true # Special case to speed up the evaluation of constant expressions } else if (constant && (iary != 1)) { Memb[nulptr+iary-1] = false switch (dtype) { case TY_BOOL: Memb[aryptr+iary-1] = Memb[aryptr] case TY_INT: Memi[aryptr+iary-1] = Memi[aryptr] case TY_REAL: Memr[aryptr+iary-1] = Memr[aryptr] } # Evaluate the expression using the values in the current row } else { iferr { op = evexpr (expr, tbl_term_adr, tbl_func_adr) } then { # Catch the error sent when a table element is null if (errcode() == PUTNULL) Memb[nulptr+iary-1] = true else { call mfree (nulptr, TY_BOOL) call xwhen (X_ARITH, old_handler, junk) call erract (EA_ERROR) } # Usual case } else { Memb[nulptr+iary-1] = false # Determine array type from type of expression if (aryptr == NULL) { if (O_TYPE(op) == TY_CHAR) { call mfree (nulptr, TY_BOOL) call xwhen (X_ARITH, old_handler, junk) call error (SYNTAX, badtype) } dtype = O_TYPE(op) call calloc (aryptr, nindex, dtype) } # Assign the result of the expression to the output # array switch (dtype) { case TY_BOOL: Memb[aryptr+iary-1] = O_VALB(op) case TY_INT: Memi[aryptr+iary-1] = O_VALI(op) case TY_REAL: Memr[aryptr+iary-1] = O_VALR(op) } } } } # Allocate array when all results are null if (aryptr == NULL) { if (dtype == TY_CHAR) { call mfree (nulptr, TY_BOOL) call xwhen (X_ARITH, old_handler, junk) call error (SYNTAX, badtype) } call calloc (aryptr, nindex, dtype) } # Restore old error handler call xwhen (X_ARITH, old_handler, junk) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/tblterm.com���������������������������������������������0000664�0000000�0000000�00000000231�13321663143�0022153�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������int jumpbuf[LEN_JUMPBUF] common /jmpcom/ jumpbuf bool constant int nterm, irow, iterm pointer table common /opcom/ constant, nterm, irow, iterm, table �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/select/tblterm.x�����������������������������������������������0000664�0000000�0000000�00000010703�13321663143�0021651�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include include include include "reloperr.h" define MAXTERM 64 # TBL_TERM -- Return the value of the term in the expression # # B.Simon 13-Apr-88 Separated from tbl_eval procedure tbl_term (term, op) char term[ARB] # i: The name of the term pointer op # o: A structure holding the term value and type #-- include "tblterm.com" bool isnull int datalen[MAXTERM], datatype[MAXTERM], dtype pointer colptr[MAXTERM] pointer sp, errtxt string badname "Column name not found (%s)" string badnum "Too many terms in expression" string nulvalue "Null found in table element" int tbcigi() errchk tbcfnd, tbcigi, tbegtb, tbegtt, tbegti, tbegtr begin # Allocate storage for character strings call smark (sp) call salloc (errtxt, SZ_LINE, TY_CHAR) constant = false iterm = iterm + 1 if (iterm > MAXTERM) call error (BOUNDS, badnum) # If this is a new term, get its column pointer, type, and length if (iterm > nterm) { nterm = iterm call tbcfnd (table, term, colptr[iterm], 1) if (colptr[iterm] == NULL) { call sprintf (Memc[errtxt], SZ_LINE, badname) call pargstr (term) call error (SYNTAX, Memc[errtxt]) } dtype = tbcigi (colptr[iterm], TBL_COL_DATATYPE) switch (dtype) { case TY_BOOL: datalen[iterm] = 0 datatype[iterm] = TY_BOOL case TY_CHAR: datalen[iterm] = 1 datatype[iterm] = TY_CHAR case TY_SHORT,TY_INT,TY_LONG: datalen[iterm] = 0 datatype[iterm] = TY_INT case TY_REAL,TY_DOUBLE: datalen[iterm] = 0 datatype[iterm] = TY_REAL default: datalen[iterm] = - dtype datatype[iterm] = TY_CHAR } } # Read the table to get the value of term call xev_initop (op, datalen[iterm], datatype[iterm]) switch (datatype[iterm]) { case TY_BOOL: call tbegtb (table, colptr[iterm], irow, O_VALB(op)) isnull = false case TY_CHAR: call tbegtt (table, colptr[iterm], irow, O_VALC(op), datalen[iterm]) isnull = O_VALC(op) == EOS case TY_SHORT,TY_INT,TY_LONG: call tbegti (table, colptr[iterm], irow, O_VALI(op)) isnull = O_VALI(op) == INDEFI case TY_REAL,TY_DOUBLE: call tbegtr (table, colptr[iterm], irow, O_VALR(op)) isnull = O_VALR(op) == INDEFR } # Error exit if table element is null if (isnull) call error (PUTNULL, nulvalue) call sfree (sp) end # TBL_FUNC -- Return the value of a nonstandard function in the expression procedure tbl_func (func_name, arg_ptr, nargs, op) char func_name[ARB] # i: String containing function name pointer arg_ptr[ARB] # i: Pointers to function arguments int nargs # i: Number of function arguments pointer op # o: Pointer to output structure #-- include "tblterm.com" pointer sp, errtxt string badtyp "Invalid argument type in %s" string badarg "Incorrect number of arguments for %s" string badfun "Unknown function named %s" bool streq() double mjd() errchk mjd() begin # Allocate storage for character strings call smark (sp) call salloc (errtxt, SZ_LINE, TY_CHAR) # Call appropriate function according to name if (streq (func_name, "row")) { # Table row number function: row() constant = false if (nargs != 0) { call sprintf (Memc[errtxt], SZ_LINE, badarg) call pargstr (func_name) call error (SYNTAX, Memc[errtxt]) } call xev_initop (op, 0, TY_INT) O_VALI(op) = irow } else if (streq (func_name, "delta")) { # Difference between two Julian dates: mjd(date1) - mjd(date2) if (nargs != 2) { call sprintf (Memc[errtxt], SZ_LINE, badarg) call pargstr (func_name) call error (SYNTAX, Memc[errtxt]) } if (O_TYPE(arg_ptr[1]) != TY_CHAR || O_TYPE(arg_ptr[2]) != TY_CHAR ) { call sprintf (Memc[errtxt], SZ_LINE, badtyp) call pargstr (func_name) call error (SYNTAX, Memc[errtxt]) } call xev_initop (op, 0, TY_REAL) O_VALR(op) = mjd (O_VALC(arg_ptr[1])) - mjd (O_VALC(arg_ptr[2])) } else { call sprintf (Memc[errtxt], SZ_LINE, badfun) call pargstr (func_name) call error (SYNTAX, Memc[errtxt]) } call sfree (sp) end # TBL_HANDLER -- Error handler to catch arithmetic errors procedure tbl_handler (code, nxt_handler) int code # i: error code which trigerred this exception int nxt_handler # o: handler called after this handler exits #-- include "tblterm.com" bool junk bool xerpop() begin # Resume execution at zsvjmp nxt_handler = X_IGNORE junk = xerpop() call zdojmp (jumpbuf, code) end �������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/selectpars.par�������������������������������������������������0000664�0000000�0000000�00000001447�13321663143�0021406�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������explicit,s,h,"",,,"Overriding expression" disjunction,b,h,no,,,"Inclusively OR (vs. AND) the expressions?\n" column1,s,h,"PLATE_ID",,,"Name for selection column 1" boolop1,s,h,"==",,,"Boolean operator for column 1" value1,s,h,"",,,"Value for column 1 (single AND double quote strings)\n" column2,s,h,"CLASS",,,"Name for selection column 2" boolop2,s,h,"==",,,"Boolean operator for column 2" value2,s,h,"0",,,"Value for column 2 (single AND double quote strings)\n" column3,s,h,"",,,"Name for selection column 3" boolop3,s,h,"",,,"Boolean operator for column 3" value3,s,h,"",,,"Value for column 3 (single AND double quote strings)\n" column4,s,h,"",,,"Name for selection column 4" boolop4,s,h,"",,,"Boolean operator for column 4" value4,s,h,"",,,"Value for column 4 (single AND double quote strings)\n" �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/t_gscfind.x����������������������������������������������������0000664�0000000�0000000�00000025610�13321663143�0020664�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Copyright restrictions apply - see stsdas$copyright.stsdas # include include define NUM_COLS 13 # Number of table columns define DIR_SLEN 5 # Size of directory name define NUM_DIR 24 # Number of dec zone directories define DEC_ZONES (NUM_DIR/2) # Number of dec zones (per hemisphere) define ZONE_SIZE (90.0/DEC_ZONES)# Width of dec zones define HRSTODEG ($1*15.d0) # Convert hours to degrees (double) define NORTH 1 define SOUTH -1 define LAST_NORTH 5259 define CAT_EPOCH 2000.d0 procedure t_gscfind () # GSCFIND -- Search the Guide Star Catalog index table for fields # in the specified range of coordinates and magnitudes. Build a # list containing the pathnames of the files on the CD-ROM. pointer sp, indtab pointer tp # Index table pointer pointer cdv[NUM_COLS] # Column descriptors double ra, dec # Coordinates of field center in degrees double epoch # Input coordinate epoch real width # Width of field in degrees bool verbose double cat_ra, cat_dec double ra1, ra2, dec1, dec2 # Coordinate limits int nrgn # Number of regions found pointer north, south int prtrgn() bool clgetb() pointer tbtopn() double clgetd() real clgetr() begin call smark (sp) call salloc (indtab, SZ_FNAME, TY_CHAR) call salloc (north, SZ_FNAME, TY_CHAR) call salloc (south, SZ_FNAME, TY_CHAR) # open the index table call clgstr ("index", Memc[indtab], SZ_FNAME) tp = tbtopn (Memc[indtab], READ_ONLY, 0) # Open the index table call gcolds (tp, cdv) # Column descriptors # get the rest of the parameters ra = clgetd ("ra") dec = clgetd ("dec") epoch = clgetd ("epoch") width = clgetr ("width") call clgstr ("north", Memc[north], SZ_FNAME) call clgstr ("south", Memc[south], SZ_FNAME) verbose = clgetb ("verbose") call f_precess (ra, dec, epoch, cat_ra, cat_dec, CAT_EPOCH) cat_ra = HRSTODEG (cat_ra) call crdlim (cat_ra, cat_dec, width, ra1, ra2, dec1, dec2, verbose) nrgn = prtrgn (tp, cdv, ra1, ra2, dec1, dec2, Memc[north], Memc[south], verbose) call clputi ("nregions", nrgn) call sfree (sp) end procedure gcolds (tp, cdv) # GCOLDS -- Find the columns in the index table pointer tp # Index table descriptor pointer cdv[NUM_COLS] # Column pointers pointer sp, cnstr, errmsg int col char colpar[8,NUM_COLS] begin call smark (sp) call salloc (cnstr, SZ_COLNAME+1, TY_CHAR) call salloc (errmsg, SZ_LINE, TY_CHAR) call strcpy ("region", colpar[1,1], 8) call strcpy ("rahlow", colpar[1,2], 8) call strcpy ("ramlow", colpar[1,3], 8) call strcpy ("raslow", colpar[1,4], 8) call strcpy ("rahhi", colpar[1,5], 8) call strcpy ("ramhi", colpar[1,6], 8) call strcpy ("rashi", colpar[1,7], 8) call strcpy ("decsilow", colpar[1,8], 8) call strcpy ("decdlow", colpar[1,9], 8) call strcpy ("decmlow", colpar[1,10], 8) call strcpy ("decsihi", colpar[1,11], 8) call strcpy ("decdhi", colpar[1,12], 8) call strcpy ("decmhi", colpar[1,13], 8) do col = 1, NUM_COLS { # For each defined column # Get the column name call clgstr (colpar[1,col], Memc[cnstr], SZ_COLNAME) call tbcfnd (tp, Memc[cnstr], cdv[col], 1) if (cdv[col] <= 0) { call sprintf (Memc[errmsg], SZ_LINE, "Could not find column %s") call pargstr (Memc[cnstr]) call error (0, Memc[errmsg]) } } call sfree (sp) end # CRDLIM -- find the coordinates of the corners of a field from the # plate center and size. procedure crdlim (ra, dec, width, ra1, ra2, dec1, dec2, verbose) double ra, dec #I Coordinates of region center in degrees real width #I Size of region in degrees double ra1, ra2, dec1, dec2 #O Coordinates of region corners bool verbose #I print the coordinates on the STDERR double cosdec begin dec1 = dec - width / 2.0 if (dec1 <= -90.0) { # South pole dec1 = -90.0 dec2 = dec + width / 2.0 ra1 = 0.0 ra2 = 360.0 return } dec2 = dec + width / 2.0 if (dec2 >= +90.0) { # North pole dec2 = +90.0 dec1 = dec - width / 2.0 ra1 = 0.0 ra2 = 360.0 return } if (dec > 0.0) # North cosdec = cos (DEGTORAD (dec2)) else # South cosdec = cos (DEGTORAD (dec1)) ra1 = ra - (0.5 * width / cosdec) if (ra1 < 0) ra1 = ra1 + 360.0 ra2 = ra + (0.5 * width / cosdec) if (ra2 > 360.0) ra2 = ra2 - 360.0 if (verbose) { call eprintf ( "%00.0h %00.0h %00.0h --> %00.0h %00.0h %00.0h %00.0h\n\n") call pargd (ra/15.d0) call pargd (dec) call pargr (width) call pargd (ra1/15.d0) call pargd (ra2/15.d0) call pargd (dec1) call pargd (dec2) call flush (STDERR) } end # PRTRGN -- Search the index table to find the region identifiers # whose coordinate limits overlap the specified field. Writes to # STDOUT commands for the cdrom command to extract the regions files. int procedure prtrgn (tp, cdv, ra1, ra2, dec1, dec2, north, south, verbose) pointer tp #I Index table descriptor pointer cdv[NUM_COLS] #I Column descriptors double ra1, ra2 #I Right ascension limits in hours double dec1, dec2 #I Declination limits in degrees char north[ARB] #I Drive (including node) for Northern CD char south[ARB] #I Drive (including node) for Southern CD bool verbose #I print the coordinates on the STDERR int numrows int row double ralow, rahi double declow, dechi int regnum bool null int zone char zdir[DIR_SLEN,NUM_DIR] int nrgn int hemsph int tbpsta(), fzone() double rdira(), rdidec() begin call initzd (zdir) # Initialize the directory name for each zone numrows = tbpsta (tp, TBL_NROWS) hemsph = 0 nrgn = 0 do row = 1, numrows { # Declination range of the GS region dechi = rdidec (tp, row, cdv[11], cdv[12], cdv[13]) # Note: southern dechi and declow are reversed if (dechi > 0 && dechi < dec1) # North next else if (dechi < 0 && dechi > dec2) # South next # Limit of GS region closer to equator declow = rdidec (tp, row, cdv[8], cdv[9], cdv[10]) if (declow > 0 && declow > dec2) { # North next } else if (declow < 0 && declow < dec1) { # South next # Lower limit of region is ON equator } else if (dechi > 0 && (dechi < dec1 || declow > dec2)) { # North next } else if (dechi < 0 && (dechi > dec2 || declow < dec1)) { # South next } # Right ascension range of the GS region if (ra1 < ra2) { # 0 R.A. not in region ralow = rdira (tp, row, cdv[2], cdv[3], cdv[4]) if (ralow > ra2) next rahi = rdira (tp, row, cdv[5], cdv[6], cdv[7]) if (ralow > rahi) rahi = rahi + 360.0 if (rahi < ra1) next } else { # 0 R.A. in region ralow = rdira (tp, row, cdv[2], cdv[3], cdv[4]) rahi = rdira (tp, row, cdv[5], cdv[6], cdv[7]) if (ralow > rahi) rahi = rahi + 360.0 if ((ralow > ra2) && (rahi < ra1)) next } call tbrgti (tp, cdv[1], regnum, null, 1, row) # Region number zone = fzone (declow, dechi) # Zone number => directory name if (regnum <= LAST_NORTH) { hemsph = NORTH # Read the northern disk (Volume 1) call printf ("%s/gsc/%s/%04d.gsc\n") call pargstr (north) call pargstr (zdir[1,zone]) call pargi (regnum) } else if (regnum > LAST_NORTH) { hemsph = SOUTH # Read the southern disk (Volume 2) call printf ("%s/gsc/%s/%04d.gsc\n") call pargstr (south) call pargstr (zdir[1,zone]) call pargi (regnum) } nrgn = nrgn + 1 if (verbose) { call eprintf ( "%5d %6d %00.0h %00.0h %00.0h %00.0h %d %d %d\n") call pargi (nrgn) call pargi (row) call pargd (ralow/15.d0) call pargd (rahi/15.d0) call pargd (declow) call pargd (dechi) call pargi (hemsph) call pargi (regnum) call pargi (zone) call flush (STDERR) } } return (nrgn) end double procedure rdira (tp, row, hcol, mcol, scol) # RDIRA -- Returns R.A. in degrees from the G.S. index table pointer tp # Index table descriptor int row # Table row number pointer hcol # Column descriptor for hours pointer mcol # Column descriptor for minutes pointer scol # Column descriptor for seconds int hrs # Hours of RA int min # Minutes of RA real sec # Seconds of RA bool null # Null column? double ra begin call tbrgti (tp, hcol, hrs, null, 1, row) # Hours of R.A. if (null) return (INDEFD) call tbrgti (tp, mcol, min, null, 1, row) # Minutes of R.A. if (null) return (INDEFD) call tbrgtr (tp, scol, sec, null, 1, row) # Seconds of R.A. if (null) return (INDEFD) ra = double (hrs) + double (min) / 6.d1 + double (sec) / 3.6d3 return (HRSTODEG(ra)) end double procedure rdidec (tp, row, sgncol, dcol, mcol) # RDIDEC -- Returns the declination in decimal degrees from the G.S. # index table. This is converted from degrees, minutes, and seconds # columns. pointer tp # Index table descriptor int row # Table row number pointer sgncol # Column descriptor for sign pointer dcol # Column descriptor for degrees pointer mcol # Column descriptor for minutes char sign[4] # Sign of Dec int deg # Degrees of Dec real min # Minutes of Dec bool null # Null column? double dec char minus data minus /'-'/ int stridx() begin call tbrgtt (tp, sgncol, sign, null, 4, 1, row) # Declination sign if (null) return (INDEFD) call tbrgti (tp, dcol, deg, null, 1, row) # Degrees of Dec. if (null) return (INDEFD) call tbrgtr (tp, mcol, min, null, 1, row) # Minutes of Dec. if (null) return (INDEFD) dec = double (deg) + double (min) / 6.d1 if (stridx (minus, sign) != 0) dec = -dec return (dec) end int procedure fzone (declow, dechi) # FZONE -- Find the zone number from the range of declinations in the # region. double declow, dechi # Limits of declination of field double dec int zone begin dec = (declow + dechi) / 2.d0 zone = int (dec / ZONE_SIZE) + 1 if (dec < 0) zone = (DEC_ZONES + 2) - zone return (zone) end procedure initzd (zdir) char zdir[DIR_SLEN,NUM_DIR] begin call strcpy ("n0000", zdir[1,1], DIR_SLEN) call strcpy ("n0730", zdir[1,2], DIR_SLEN) call strcpy ("n1500", zdir[1,3], DIR_SLEN) call strcpy ("n2230", zdir[1,4], DIR_SLEN) call strcpy ("n3000", zdir[1,5], DIR_SLEN) call strcpy ("n3730", zdir[1,6], DIR_SLEN) call strcpy ("n4500", zdir[1,7], DIR_SLEN) call strcpy ("n5230", zdir[1,8], DIR_SLEN) call strcpy ("n6000", zdir[1,9], DIR_SLEN) call strcpy ("n6730", zdir[1,10], DIR_SLEN) call strcpy ("n7500", zdir[1,11], DIR_SLEN) call strcpy ("n8230", zdir[1,12], DIR_SLEN) call strcpy ("s0000", zdir[1,13], DIR_SLEN) call strcpy ("s0730", zdir[1,14], DIR_SLEN) call strcpy ("s1500", zdir[1,15], DIR_SLEN) call strcpy ("s2230", zdir[1,16], DIR_SLEN) call strcpy ("s3000", zdir[1,17], DIR_SLEN) call strcpy ("s3730", zdir[1,18], DIR_SLEN) call strcpy ("s4500", zdir[1,19], DIR_SLEN) call strcpy ("s5230", zdir[1,20], DIR_SLEN) call strcpy ("s6000", zdir[1,21], DIR_SLEN) call strcpy ("s6730", zdir[1,22], DIR_SLEN) call strcpy ("s7500", zdir[1,23], DIR_SLEN) call strcpy ("s8230", zdir[1,24], DIR_SLEN) end ������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/t_tfield.x�����������������������������������������������������0000664�0000000�0000000�00000041353�13321663143�0020520�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# TFIELD -- Task to extract sources within a specified field (RA, Dec) # from a list of tables. The predicted X&Y coordinates for the sources are # added to the output table along with columns for the centered X&Y's and a # preselect flag and a postselect flag (i.e., centering was ok). The # centering is to be done by a subsequent task or by a measuring engine # (e.g., the Grant machine at NOAO/Tucson). include include include include include define SZ_TOKEN 2 define TF_LEN 32 # parameters for the various coordinate transformations define SCALE Memr[$1] # arcseconds / user units define CAT_EPOCH Memr[$1+1] define PLT_EPOCH Memr[$1+2] define RA_TAN Memr[$1+3] # sky coordinates define DEC_TAN Memr[$1+4] define XI_CEN Memr[$1+5] # standard coordinates define ETA_CEN Memr[$1+6] define X_CEN Memr[$1+7] # plate coordinates define Y_CEN Memr[$1+8] define POS_ANGLE Memr[$1+9] define TRANSPOSE Memi[$1+10] define X_MIN Memr[$1+11] # plate edges define X_MAX Memr[$1+12] define Y_MIN Memr[$1+13] define Y_MAX Memr[$1+14] # table column pointers define RA_COL Memi[$1+15] # Right Ascension define DEC_COL Memi[$1+16] # Declination define NUMCOL 9 # number of new columns define COLPTR Memi[$1+17] # more obvious than REGION_COL define REGION_COL Memi[$1+17] # GSC region number define XPRED_COL Memi[$1+18] # predicted X coord define YPRED_COL Memi[$1+19] # predicted Y coord define XCEN_COL Memi[$1+20] # centered X coord define YCEN_COL Memi[$1+21] # centered Y coord define CERR_COL Memi[$1+22] # centering error define SUBSET_COL Memi[$1+23] # subset selection flag define CENTER_COL Memi[$1+24] # good centering flag define OBJECT_COL Memi[$1+25] # program object flag define IROWNUM Memi[$1+26] # input table row number define OROWNUM Memi[$1+27] # output table row number define REGION Memi[$1+28] # current GSC region number define REGION_KEY "REGION" # should agree with CDRFITS # for user prompting, if needed define DIR_TYPES "|top|left|bottom|right" define DIR_PROMPT "top|left|bottom|right" define DIR_HORIZ "left|right " define DIR_VERT "top|bottom " define DIR_LEN 6 define TOP 1 define LEFT 2 define BOTTOM 3 define RIGHT 4 procedure t_tfield () pointer sp, itp, otp, input, output, tf, tftmp bool firsttime, errorseen int tblist, row real ra, dec, xi, eta, x, y int clpopnu(), clgfil(), tbpsta(), tbhgti() pointer tf_open(), tf_init(), tbtopn() errchk tf_open, tf_init begin call smark (sp) call salloc (input, SZ_FNAME, TY_CHAR) call salloc (output, SZ_FNAME, TY_CHAR) # get the query parameters tblist = clpopnu ("input") call clgstr ("output", Memc[output], SZ_FNAME) call tbtext (Memc[output], Memc[output], SZ_FNAME) tf = NULL otp = NULL firsttime = true errorseen = false iferr { # get the parameters and initialize the task structure tftmp = tf_init () tf = tftmp # so tf=NULL if error in tf_init() while (clgfil (tblist, Memc[input], SZ_FNAME) != EOF) { itp = tbtopn (Memc[input], READ_ONLY, 0) iferr (REGION(tf) = tbhgti (itp, REGION_KEY)) { call eprintf ("Warning: REGION keyword not found\n") call flush (STDERR) REGION(tf) = INDEFI } # open output table, append columns if (firsttime) { otp = tf_open (itp, Memc[output], tf) firsttime = false } do row = 1, tbpsta (itp, TBL_NROWS) { IROWNUM(tf) = row # the do loop wants a simple variable call tf_geteq (itp, ra, dec, tf) call eq_to_std (ra, dec, xi, eta, tf) call std_to_plt (xi, eta, x, y, tf) if (x >= X_MIN(tf) && x <= X_MAX(tf) && y >= Y_MIN(tf) && y <= Y_MAX(tf)) { call tf_copyrow (itp, otp, x, y, tf) } } call tbtclo (itp) } } then { errorseen = true call erract (EA_WARN) } if (tf != NULL) call mfree (tf, TY_STRUCT) if (otp != NULL) call tbtclo (otp) call clpcls (tblist) call sfree (sp) if (errorseen) call error (1, "TFIELD") end # TF_INIT -- Initialize the plate / catalog information structure from # the supplied parameters / header keywords. Various computations are # needed to initialize the coordinate transforms. # This whole routine should be recoded to use double precision, # not just the naughty bits. pointer procedure tf_init () pointer tf, sp, buf, date, im real ra, dec, ra1, dec1, ra_cen, dec_cen, del_ra, del_dec real xref, yref, xref1, yref1 real plt_epoch, plt_epoch1, width, edge, pos_angle double obs_epoch, ut, dra, ddec long xsize, ysize int north, east, day, month, year, token1, token2 char tokstr[SZ_TOKEN] real clgetr(), imgetr() double imgetd() int clgwrd(), strmatch(), btoi(), nscan() bool clgetb() pointer immap() data token1 /NULL/ data token2 /NULL/ begin call smark (sp) call salloc (buf, SZ_FNAME, TY_CHAR) call salloc (date, SZ_FNAME, TY_CHAR) call malloc (tf, TF_LEN, TY_STRUCT) SCALE(tf) = DEGTORAD(clgetr ("scale") / 3600.) edge = clgetr ("edge") north = clgwrd ("north", Memc[buf], DIR_LEN, DIR_TYPES) # limit the east enumeration to orthogonal choices # does this work??? if (north == TOP || north == BOTTOM) { call clprintf ("east.p_min", DIR_HORIZ) east = clgwrd ("east", Memc[buf], DIR_LEN, DIR_TYPES) } else { call clprintf ("east.p_min", DIR_VERT) east = clgwrd ("east", Memc[buf], DIR_LEN, DIR_TYPES) } # restore the original prompt call clprintf ("east.p_min", DIR_PROMPT) # this relies on DIR_TYPES being cyclic clockwise # could just enumerate these in the switch below TRANSPOSE(tf) = btoi (mod (east-north+4, 4) == 3) # should really catch the impossible combinations... switch (north) { case TOP: if (east == LEFT) pos_angle = 0. else pos_angle = -90. case LEFT: if (east == TOP) pos_angle = 180. else pos_angle = -90. case BOTTOM: if (east == LEFT) pos_angle = 90. else pos_angle = 180. case RIGHT: if (east == TOP) pos_angle = 90. else pos_angle = 0. } if (TRANSPOSE(tf) == YES) POS_ANGLE(tf) = DEGTORAD(clgetr ("pangle") - pos_angle) else POS_ANGLE(tf) = - DEGTORAD(clgetr ("pangle") - pos_angle) # read the coord info from the image and/or the parameters call clgstr ("image", Memc[buf], SZ_FNAME) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { iferr (im = immap (Memc[buf], READ_ONLY, 0)) { call sfree (sp) call erract (EA_ERROR) } if (IM_NDIM(im) != 2) { call imunmap (im) call sfree (sp) call error (1, "Image is not two dimensional.") } xsize = IM_LEN(im,1) ysize = IM_LEN(im,2) X_MIN(tf) = 1 - edge X_MAX(tf) = xsize + edge Y_MIN(tf) = 1 - edge Y_MAX(tf) = ysize + edge X_CEN(tf) = (xsize + 1) / 2. Y_CEN(tf) = (ysize + 1) / 2. iferr (ra = imgetr (im, "RA")) ra = INDEFR iferr (dec = imgetr (im, "DEC")) dec = INDEFR iferr (plt_epoch = imgetr (im, "EPOCH")) plt_epoch = INDEFR iferr (ut = imgetd (im, "UT")) ut = 7.d0 # supply a default UT (local midnight) iferr (call imgstr (im, "DATE-OBS", Memc[date], SZ_FNAME)) Memc[date] = EOS # call eprintf ("ra = %g dec = %g epoch = %g\n date = %s ut = %g\n") # call pargr (ra) # call pargr (dec) # call pargr (plt_epoch) # call pargstr (Memc[date]) # call pargd (ut) # call flush (STDERR) call imunmap (im) } else { # this is bogus, fix it later width = DEGTORAD(clgetr ("width")) / SCALE(tf) X_MIN(tf) = - width / 2. X_MAX(tf) = width / 2. Y_MIN(tf) = - width / 2. Y_MAX(tf) = width / 2. X_CEN(tf) = 0. Y_CEN(tf) = 0. # supply a default UT (local midnight) for the obs. epoch calc. ut = 7.d0 } ra1 = clgetr ("ra") if (! IS_INDEFR(ra1)) ra = ra1 dec1 = clgetr ("dec") if (! IS_INDEFR(dec1)) dec = dec1 if (IS_INDEFR(ra) || IS_INDEFR(dec)) { call sfree (sp) call error (1, "Field's RA or Dec undefined.") } plt_epoch1 = clgetr ("epoch") if (! IS_INDEFR(plt_epoch1)) plt_epoch = plt_epoch1 # call eprintf ("ra = %g dec = %g epoch = %g\n") # call pargr (ra) # call pargr (dec) # call pargr (plt_epoch) # call flush (STDERR) call clgstr ("date_obs", Memc[buf], SZ_FNAME) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) call strcpy (Memc[buf], Memc[date], SZ_FNAME) call sscan (Memc[date]) call gargi (day) call gargtok (token1, tokstr, SZ_TOKEN) call gargi (month) call gargtok (token2, tokstr, SZ_TOKEN) call gargi (year) if (nscan() == 5 && (token1 == TOK_OPERATOR || token1 == TOK_PUNCTUATION) && (token2 == TOK_OPERATOR || token2 == TOK_PUNCTUATION)) { if (day < 1 || day > 31 || month < 1 || month > 12) { call eprintf ("DATE-OBS = >%s<\n") call pargstr (Memc[date]) call flush (STDERR) call sfree (sp) call error (1, "DATE-OBS is impossible (reversed DD/MM?)") } call f_date_to_epoch (year, month, day, ut, obs_epoch) #call eprintf ("observation epoch = %g\n") #call pargd (obs_epoch) #call flush (STDERR) call f_precess (double(ra), double(dec), double(plt_epoch), dra, ddec, obs_epoch) ra = real (dra) dec = real (ddec) PLT_EPOCH(tf) = real (obs_epoch) # call eprintf ("ra = %g dec = %g epoch = %g %d-%d-%d\n") # call pargr (ra) # call pargr (dec) # call pargr (PLT_EPOCH(tf)) # call pargi (day) # call pargi (month) # call pargi (year) # call flush (STDERR) } else { PLT_EPOCH(tf) = plt_epoch } # call eprintf ("ra = %g dec = %g epoch = %g\n") # call pargr (ra) # call pargr (dec) # call pargr (PLT_EPOCH(tf)) # call flush (STDERR) dec = DEGTORAD(dec) ra = DEGTORAD(ra * 15.) del_ra = DEGTORAD(clgetr("del_ra")) / cos(dec) del_dec = DEGTORAD(clgetr("del_dec")) if (clgetb ("opaxis")) { RA_TAN(tf) = ra DEC_TAN(tf) = dec ra_cen = ra + del_ra dec_cen = dec + del_dec } else { xref = clgetr ("xref") if (IS_INDEFR(xref)) xref = X_CEN(tf) yref = clgetr ("yref") if (IS_INDEFR(yref)) yref = Y_CEN(tf) if (TRANSPOSE(tf) == YES) { xref1 = + cos (POS_ANGLE(tf)) * (xref - X_CEN(tf)) + sin (POS_ANGLE(tf)) * (yref - Y_CEN(tf)) yref1 = - sin (POS_ANGLE(tf)) * (xref - X_CEN(tf)) + cos (POS_ANGLE(tf)) * (yref - Y_CEN(tf)) xref = yref1 yref = xref1 } else { xref1 = + cos (POS_ANGLE(tf)) * (xref - X_CEN(tf)) - sin (POS_ANGLE(tf)) * (yref - Y_CEN(tf)) yref1 = + sin (POS_ANGLE(tf)) * (xref - X_CEN(tf)) + cos (POS_ANGLE(tf)) * (yref - Y_CEN(tf)) xref = xref1 yref = yref1 } # RA is lefthanded ra_cen = ra + (SCALE(tf) * xref) / cos(dec) dec_cen = dec - (SCALE(tf) * yref) RA_TAN(tf) = ra_cen - del_ra DEC_TAN(tf) = dec_cen - del_dec } call eq_to_std (ra_cen, dec_cen, XI_CEN(tf), ETA_CEN(tf), tf) OROWNUM(tf) = 0 call sfree (sp) return (tf) end # TF_OPEN -- Check input table compatibility, open the output table # and append the X, Y, and flag columns. pointer procedure tf_open (itp, output, tf) pointer itp #I input table descriptor char output[ARB] #I output table name pointer tf #I task structure pointer char colname[SZ_COLNAME, NUMCOL] char colunits[SZ_COLUNITS, NUMCOL] char colfmt[SZ_COLFMT, NUMCOL] int type[NUMCOL], len[NUMCOL] pointer otp, sp, pp, buf int i pointer clopset(), tbtopn() int strdic() real clgpsetr() errchk tbtopn, tbtcre begin call smark (sp) call salloc (buf, SZ_LINE, TY_CHAR) # open the catalog pset for the column information call clgstr ("catpars", Memc[buf], SZ_FNAME) pp = clopset (Memc[buf]) CAT_EPOCH(tf) = clgpsetr (pp, "cat_epoch") call clgpset (pp, "region_col", colname[1,1], SZ_LINE) call clgpset (pp, "xpred_col", colname[1,2], SZ_LINE) call clgpset (pp, "ypred_col", colname[1,3], SZ_LINE) call clgpset (pp, "xcen_col", colname[1,4], SZ_LINE) call clgpset (pp, "ycen_col", colname[1,5], SZ_LINE) call clgpset (pp, "cerr_col", colname[1,6], SZ_LINE) call clgpset (pp, "sub_col", colname[1,7], SZ_LINE) call clgpset (pp, "cen_col", colname[1,8], SZ_LINE) call clgpset (pp, "obj_col", colname[1,9], SZ_LINE) call clgpset (pp, "units", colunits[1,2], SZ_COLUNITS) call clgpset (pp, "format", colfmt[1,2], SZ_COLFMT) do i = 3, 6 { call strcpy (colunits[1,2], colunits[1,i], SZ_COLUNITS) call strcpy (colfmt[1,2], colfmt[1,i], SZ_COLFMT) } call strcpy ("index", colunits[1,1], SZ_COLUNITS) call strcpy ("%5d", colfmt[1,1], SZ_COLFMT) call strcpy ("flag", colunits[1,7], SZ_COLUNITS) call strcpy ("flag", colunits[1,8], SZ_COLUNITS) call strcpy ("flag", colunits[1,9], SZ_COLUNITS) call strcpy ("%1d", colfmt[1,7], SZ_COLFMT) call strcpy ("%1d", colfmt[1,8], SZ_COLFMT) call strcpy ("%1d", colfmt[1,9], SZ_COLFMT) call clgpset (pp, "datatype", Memc[buf], SZ_LINE) switch (strdic (Memc[buf], Memc[buf], SZ_LINE, "|int|real|double")) { case 1: call amovki (TY_INT, type[2], 5) case 2: call amovki (TY_REAL, type[2], 5) case 3: call amovki (TY_DOUBLE, type[2], 5) default: call sfree (sp) call error (1, "unknown switch case in tf_open") } type[1] = TY_INT type[7] = TY_INT type[8] = TY_INT type[9] = TY_INT # apparently `lendata' isn't used by tbcdef do i = 1, NUMCOL len[i] = 0 otp = tbtopn (output, NEW_COPY, itp) call tbcdef (otp, COLPTR(tf), colname, colunits, colfmt, type, len, NUMCOL) call tbtcre (otp) call clgpset (pp, "ra_col", Memc[buf], SZ_LINE) call tbcfnd (otp, Memc[buf], RA_COL(tf), 1) call clgpset (pp, "dec_col", Memc[buf], SZ_LINE) call tbcfnd (otp, Memc[buf], DEC_COL(tf), 1) call clcpset (pp) call sfree (sp) return (otp) end # TF_GETEQ -- Get the RA and DEC from the input table. Precess from # the catalog to the plate epoch and convert to radians. procedure tf_geteq (tp, ra, dec, tf) pointer tp #I table descriptor real ra, dec #O RA and Dec in radians pointer tf #I task structure descriptor double ra_deg, dec_deg, ra_hrs, cat_epoch, plt_epoch bool undefined begin call tbrgtd (tp, RA_COL(tf), ra_deg, undefined, 1, IROWNUM(tf)) if (undefined) call error (1, "undefined right ascension in table") call tbrgtd (tp, DEC_COL(tf), dec_deg, undefined, 1, IROWNUM(tf)) if (undefined) call error (1, "undefined declination in table") ra_hrs = ra_deg / 15.d0 if (IS_INDEFR(CAT_EPOCH(tf))) cat_epoch = INDEFD else cat_epoch = double (CAT_EPOCH(tf)) if (IS_INDEFR(PLT_EPOCH(tf))) plt_epoch = INDEFD else plt_epoch = double (PLT_EPOCH(tf)) call f_precess (ra_hrs, dec_deg, cat_epoch, ra_hrs, dec_deg, plt_epoch) ra = DEGTORAD(real (ra_hrs) * 15.) dec = DEGTORAD(real (dec_deg)) end # Should do the calculations with the vector operators... # EQ_TO_STD -- Convert from equitorial coordinates to standard # (tangential) coordinates. procedure eq_to_std (ra, dec, xi, eta, tf) real ra, dec #I equitorial coords of source (radians) real xi, eta #O standard coords of source pointer tf #I task structure descriptor real denom begin denom = sin (dec) * sin (DEC_TAN(tf)) + cos (dec) * cos (DEC_TAN(tf)) * cos (ra - RA_TAN(tf)) xi = cos (dec) * sin (ra - RA_TAN(tf)) xi = xi / (SCALE(tf) * denom) eta = sin (dec) * cos (DEC_TAN(tf)) - cos (dec) * sin (DEC_TAN(tf)) * cos (ra - RA_TAN(tf)) eta = eta / (SCALE(tf) * denom) end # STD_TO_PLT -- Convert from standard coordinates to plate (measured) # coordinates. procedure std_to_plt (xi, eta, x, y, tf) real xi, eta #I standard coords of source real x, y #O plate coords of source pointer tf #I task structure descriptor real xx, yy begin # note that x = - xi, i.e., (xi,eta) coords are lefthanded xx = - cos (POS_ANGLE(tf)) * ( xi - XI_CEN(tf)) + sin (POS_ANGLE(tf)) * (eta - ETA_CEN(tf)) + X_CEN(tf) yy = + sin (POS_ANGLE(tf)) * ( xi - XI_CEN(tf)) + cos (POS_ANGLE(tf)) * (eta - ETA_CEN(tf)) + Y_CEN(tf) if (TRANSPOSE(tf) == YES) { x = yy y = xx } else { x = xx y = yy } end # TF_COPYROW -- Copy (append) a row from an input catalog table to the # output catalog table. Fill in the predicted X,Y coordinates, the # centered X,Y coordinates are set to the same values. Initialize the # SUBSET flag to YES, the centering flag to NO, and the OBJECT flag (of # course) to NO. Set the REGION field. procedure tf_copyrow (itp, otp, x, y, tf) pointer itp, otp #I input and output table desc. real x, y #I predicted X and Y coordinates pointer tf #I task structure descriptor begin OROWNUM(tf) = OROWNUM(tf) + 1 call tbrcpy (itp, otp, IROWNUM(tf), OROWNUM(tf)) call tbrpti (otp, REGION_COL(tf), REGION(tf), 1, OROWNUM(tf)) call tbrptr (otp, XPRED_COL(tf), x, 1, OROWNUM(tf)) call tbrptr (otp, YPRED_COL(tf), y, 1, OROWNUM(tf)) call tbrptr (otp, XCEN_COL(tf), x, 1, OROWNUM(tf)) call tbrptr (otp, YCEN_COL(tf), y, 1, OROWNUM(tf)) call tbrptr (otp, CERR_COL(tf), INDEFR, 1, OROWNUM(tf)) call tbrpti (otp, SUBSET_COL(tf), YES, 1, OROWNUM(tf)) call tbrpti (otp, CENTER_COL(tf), NO, 1, OROWNUM(tf)) call tbrpti (otp, OBJECT_COL(tf), NO, 1, OROWNUM(tf)) end �������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/t_tpeak.x������������������������������������������������������0000664�0000000�0000000�00000167603�13321663143�0020364�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# TPEAK -- interactively center a list of sources in an image, given # their approximate coordinates. Various options for shifting, rotating, # and 2D linear fits are provided. The output is suitable for input to # a plate solving routine. # NOTE: This is a prototype routine that is coded as an SPP `script' # using clcmd to call other IRAF tasks to do much of the work. This # method allows access to facilities such as SPP data structures while # not requiring complicated algorithms to be recoded. The expense is # in the dependence on the current CL / task configuration, in longer # execution times, and in more complicated plumbing. We even use disk # based table access exclusively for reading the catalogs. No copy is # kept in memory for internal use. include include include include include # Could make this at runtime from the commands below, but why bother? define TASKDICT "|display|tvmark_|selectpars|imcentroid|tpltsol|" define DISPCMD "display %s %d fill=%b >& dev$null" define MARKCMD "tvmark_ %d %s mark=%s color=%s" define CENTCMD "imcentroid %s reference='' coords=%s shifts=%s box=%d verb+ >& %s" define LOGCMD "logfile %s %s append+ >& dev$null" #define FITCMD "tpltsol %s %s %s imupdate=%s tabupdate+ refitcat=%s dssheader+ ra_ref=%s dec_ref=%s eq_ref=%g" define FITCMD "tpltsol %s %s %s imupdate=%s tabupdate+ refitcat=%s dssheader- ra_ref='%s' dec_ref='%s' eq_ref=%g" define CMDDICT "|autodisplay|boxsize|badcolor|goodcolor|eparam|marker|omarker|replace|rotate|scale|shift|show|subsample|update" define KEYHELP "mscfinder$tpeak.key" define AUTODISPLAY 1 define BOXSIZE 2 define BADCOLOR 3 define GOODCOLOR 4 define EPARAM 5 define MARKER 6 define OMARKER 7 define REPLACE 8 define ROTATE 9 define SCALE 10 define SHIFT 11 define SHOW 12 define SUBSAMPLE 13 define UPDATE 14 define SZ_NAME 10 # for markers and colors define MARKDICT "|point|circle|cross|plus|rectangle" define COLORDICT "|black|white|red|green|blue|yellow" define BLACK 1 define WHITE 2 define RED 3 define GREEN 4 define BLUE 5 define YELLOW 6 define BLACKCODE 202 define WHITECODE 203 define REDCODE 204 define GREENCODE 205 define BLUECODE 206 define YELLOWCODE 207 # an integer value that is guaranteed not to be YES or NO define ISOBJ (abs (YES) + abs (NO) + 1) # tables definitions define NUM_COLS 9 # number of columns we need define XPRED 1 define YPRED 2 define XCEN 3 define YCEN 4 define CERR 5 define SUBSET 6 define CENTER 7 define OBJECT 8 define ID 9 define PI 3.14159265358979 procedure t_tpeak () char mark[SZ_NAME], ovmark[SZ_NAME] char gcolor[SZ_NAME], bcolor[SZ_NAME], ocolor[SZ_NAME] pointer sp, image, table, objects, tp, cmd, buf, flags, cp[NUM_COLS] pointer database, ra_ref, dec_ref int frame, boxsize, nstars, key, junk, index, ob, subsample bool update, autodisplay, autocenter, fill, interactive bool redisplay, every_source real pangle, eq_ref # window, catalog, and peaked coords real wx, wy, cx, cy, px, py, xshift, yshift, xscale, yscale int ixshift, iyshift int clgeti(), clgcur(), opentab(), center_one(), nearest() int strmatch(), open(), getline(), nscan() real clgetr() bool clgetb(), tp_colon() begin call smark (sp) call salloc (image, SZ_FNAME, TY_CHAR) call salloc (table, SZ_FNAME, TY_CHAR) call salloc (database, SZ_FNAME, TY_CHAR) call salloc (objects, SZ_FNAME, TY_CHAR) call salloc (buf, SZ_LINE, TY_CHAR) call salloc (cmd, SZ_LINE, TY_CHAR) call salloc (ra_ref, SZ_FNAME, TY_CHAR) call salloc (dec_ref, SZ_FNAME, TY_CHAR) # query parameters call clgstr ("image", Memc[image], SZ_FNAME) call clgstr ("table", Memc[table], SZ_FNAME) # the rest of the parameters call clgstr ("ra_ref", Memc[ra_ref], SZ_LINE) call clgstr ("dec_ref", Memc[dec_ref], SZ_LINE) eq_ref = clgetr ("eq_ref") call clgstr ("database", Memc[database], SZ_FNAME) update = clgetb ("update") interactive = clgetb ("interactive") if (interactive) autocenter = clgetb ("autocenter") else autocenter = true autodisplay = clgetb ("autodisplay") fill = clgetb ("fill") boxsize = clgeti ("boxsize") pangle = clgetr ("rotate") xscale = clgetr ("xscale") yscale = clgetr ("yscale") ixshift = clgeti ("xshift") iyshift = clgeti ("yshift") frame = clgeti ("frame") subsample = clgeti ("subsample") call clgstr ("marker", mark, SZ_NAME) call clgstr ("omarker", ovmark, SZ_NAME) call clgstr ("goodcolor", gcolor, SZ_NAME) call clgstr ("badcolor", bcolor, SZ_NAME) call clgstr ("objcolor", ocolor, SZ_NAME) nstars = opentab (Memc[table], tp, cp) if (clgetb ("reselect")) call tp_select (tp, cp) call clgstr ("objects", Memc[objects], SZ_FNAME) if (Memc[objects] != EOS && strmatch (Memc[objects], "^#$") == 0) { iferr (ob = open (Memc[objects], READ_ONLY, TEXT_FILE)) { call eprintf ("Warning: problem opening `%s'\n") call pargstr (Memc[objects]) call flush (STDERR) } else { while (getline (ob, Memc[buf]) != EOF) if (strmatch (Memc[buf], "^#\#") == 0) { # comment? call sscan (Memc[buf]) call gargr (cx) call gargr (cy) call gargi (index) if (nscan () == 3) if (! IS_INDEFR (cx) && ! IS_INDEFR (cy)) call newobject (tp, cp, nstars, cx, cy, index) } } } if (! interactive) { if (autocenter) call center (Memc[image], boxsize, tp, cp, nstars, 0.,0.,false) call tbtclo (tp) call sfree (sp) return } call salloc (flags, nstars, TY_INT) # This assumes that the centered coords have been initialized # to the predicted coords. Allows reentering the task... call display (Memc[image], frame, fill) # display the uncentered sources first so user can see the # improvement from autocentering call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, bcolor, NO) if (autocenter) call center (Memc[image], boxsize, tp, cp, nstars, 0.,0.,false) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, ocolor, ISOBJ) redisplay = false every_source = false while (clgcur ("imcur", wx, wy, junk, key, Memc[cmd], SZ_LINE) != EOF) { # Find the catalog source nearest the cursor (current subset) index = nearest (wx, wy, tp, cp, nstars, cx, cy) switch (key) { # one-time toggle between single/all object(s) # applies to the 'c', 'd', 'i', 'j', 'k', 'l', and 'u' keys case 'a': if (every_source) { every_source = false call printf ("... `a' mode canceled\n") call flush (STDOUT) } else { every_source = true call printf ("Press one of c,d,i,j,k,l,p,u\n") call flush (STDOUT) } next # redisplay only the bad object list case 'b': call display (Memc[image], frame, fill) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, bcolor, NO) # recenter object(s) relative to current catalog coordinates case 'c': if (every_source) { call center (Memc[image], boxsize, tp, cp, nstars, 0., 0., true) if (autodisplay) redisplay = true else call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) every_source = false } else if (center_one (Memc[image], boxsize, cx, cy, px, py) == OK) { call newpoint (tp, cp, nstars, index, px, py) call overlay_one (frame, px, py, mark, gcolor) } else { call badpoint (tp, cp, nstars, index) call overlay_one (frame, cx, cy, mark, bcolor) call eprintf ("Centering failed at (%7.2f,%7.2f).\n") call pargr (cx) call pargr (cy) call flush (STDERR) } # delete object(s) case 'd': if (every_source) { call amovki (NO, Memi[flags], nstars) call tbcpti (tp, cp[CENTER], Memi[flags], 1, nstars) call tbtflu (tp) if (autodisplay) redisplay = true else call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, bcolor, NO) every_source = false } else { call badpoint (tp, cp, nstars, index) call overlay_one (frame, cx, cy, mark, bcolor) } # fit the current catalog sample case 'f': call tbtclo (tp) call tpltsol (Memc[image], Memc[table], Memc[database], update, true, Memc[ra_ref], Memc[dec_ref], eq_ref) nstars = opentab (Memc[table], tp, cp) if (clgetb ("reselect")) call tp_select (tp, cp) if (autodisplay) redisplay = true # redisplay only the centered object list case 'g': call display (Memc[image], frame, fill) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) # start over: reinitialize to the raw position(s) case 'i': if (every_source) { call printf ("Reinitialize X,Y coords for ALL sources? ") if (clgetb ("go_ahead")) { call reinit (tp, cp, nstars) redisplay = true every_source = false } } else { call reinit_one (tp, cp, nstars, index, cx, cy) call overlay_one (frame, cx, cy, mark, bcolor) } # center object(s) relative to current catalog coordinates case 'j': if (every_source) { call center (Memc[image], boxsize, tp, cp, nstars, 0., 0., false) if (autodisplay) redisplay = true else call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) every_source = false } else if (center_one (Memc[image], boxsize, cx, cy, px, py) == OK) { call newpoint (tp, cp, nstars, index, px, py) call overlay_one (frame, px, py, mark, gcolor) } else { call badpoint (tp, cp, nstars, index) call overlay_one (frame, cx, cy, mark, bcolor) call eprintf ("Centering failed at (%7.2f,%7.2f).\n") call pargr (cx) call pargr (cy) call flush (STDERR) } # center object(s), first shifting to current cursor coordinates case 'k': if (center_one (Memc[image], boxsize, wx, wy, px, py) == OK) { if (every_source) { xshift = cx - px yshift = cy - py call center (Memc[image], boxsize, tp, cp, nstars, xshift, yshift, false) if (autodisplay) redisplay = true else call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) every_source = false } else { call newpoint (tp, cp, nstars, index, px, py) call overlay_one (frame, px, py, mark, gcolor) } } else { call badpoint (tp, cp, nstars, index) call overlay_one (frame, cx, cy, mark, bcolor) call eprintf ("Centering failed at (%7.2f,%7.2f).\n") call pargr (cx) call pargr (cy) call flush (STDERR) } # center object(s), selecting the source explicitly case 'l': call printf ("Move cursor to matching source, type `l':\n") call flush (STDOUT) junk = clgcur ("imcur", wx, wy, junk, key, Memc[cmd], SZ_LINE) if (key != 'l') { call printf ("`l' cancelled, continue with next command.\n") call flush (STDOUT) next } if (center_one (Memc[image], boxsize, wx, wy, px, py) == OK) { if (every_source) { xshift = cx - px yshift = cy - py call center (Memc[image], boxsize, tp, cp, nstars, xshift, yshift, false) if (autodisplay) redisplay = true else call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) every_source = false } else { call newpoint (tp, cp, nstars, index, px, py) call overlay_one (frame, px, py, mark, gcolor) } } else { call badpoint (tp, cp, nstars, index) call overlay_one (frame, cx, cy, mark, bcolor) call eprintf ("Centering failed at (%7.2f,%7.2f).\n") call pargr (cx) call pargr (cy) call flush (STDERR) } # overlay the raw coordinates case 'o': call overlay (frame, tp, cp, XPRED, YPRED, nstars, subsample, ovmark, bcolor, YES) call overlay (frame, tp, cp, XPRED, YPRED, nstars, subsample, ovmark, bcolor, NO) # # recenter program objects, first shifting to current cursor coords # case 'p': # if (center_one (Memc[image], boxsize, wx, wy, px, py) == OK) { # if (every_source) { # xshift = cx - px # yshift = cy - py # call pcenter (Memc[image], boxsize, tp, cp, nstars, # xshift, yshift, true) # # if (autodisplay) # redisplay = true # else # call overlay (frame, tp, cp, XCEN, YCEN, nstars, # subsample, mark, ocolor, ISOBJ) # # every_source = false # # } else { # call newpoint (tp, cp, nstars, index, px, py) # call overlay_one (frame, px, py, mark, gcolor) # } # # } else { # call badpoint (tp, cp, nstars, index) # call overlay_one (frame, cx, cy, mark, bcolor) # # call eprintf ("Centering failed at (%7.2f,%7.2f).\n") # call pargr (cx) # call pargr (cy) # call flush (STDERR) # } # exit the program (EOF also works) case 'q': break # redisplay both the centered and bad lists case 'r': redisplay = true # undelete object(s) case 'u': if (every_source) { call amovki (YES, Memi[flags], nstars) call tbcpti (tp, cp[CENTER], Memi[flags], 1, nstars) call tbtflu (tp) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) every_source = false } else { call goodpoint (tp, cp, nstars, index) call overlay_one (frame, cx, cy, mark, gcolor) } # # add an extra (program) object (won't participate in the fit) # case 'x': # # point and prompt for a name # if (center_one (Memc[image], boxsize, wx, wy, px, py) == OK) { # call newobject (tp, cp, nstars, px, py, nstars+1) # call overlay_one (frame, px, py, mark, ocolor) # # } else { # call eprintf ("Couldn't center object!\n") # call flush (STDERR) # } # page keystroke helpfile case '?': call pagefiles (KEYHELP) # colon commands case ':': redisplay = tp_colon (Memc[image], Memc[table], nstars, tp, cp, Memc[cmd], update, autodisplay, boxsize, subsample, pangle, xscale, yscale, ixshift, iyshift, bcolor, gcolor, mark, ovmark) # beep and mention '?' help default: call printf ("\007unknown command, type `?' for help\n") call flush (STDOUT) } if (every_source) { every_source = false call printf ("... `a' mode canceled\n") call flush (STDOUT) } if (redisplay) { call display (Memc[image], frame, fill) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, gcolor, YES) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, bcolor, NO) call overlay (frame, tp, cp, XCEN, YCEN, nstars, subsample, mark, ocolor, ISOBJ) redisplay = false } } call tbtclo (tp) call sfree (sp) end # TP_COLON -- do the colon commands. bool procedure tp_colon (image, table, nstars, tp, cp, command, update, autodisplay, boxsize, subsample, pangle, xscale, yscale, xshift, yshift, bcolor, gcolor, mark, ovmark) char image[ARB] #I image name char table[ARB] #I table name int nstars #I number of entries in the table pointer tp #I table pointer pointer cp[NUM_COLS] #I array of column pointers char command[ARB] #I command line (after `:') bool update #U update image header wcs? bool autodisplay #U redisplay following all source toggle? int boxsize #U centering boxsize (will be odd) int subsample #U subsample factor for catalog objects real pangle #U relative position angle real xscale #U relative X scale, percent real yscale #U relative Y scale, percent int xshift #U relative X axis shift int yshift #U relative Y axis shift char bcolor[SZ_NAME] #U bad color char gcolor[SZ_NAME] #U good color char mark[SZ_NAME] #U marker type char ovmark[SZ_NAME] #U overlay (raw) marker type char cmd[SZ_NAME] char arg[SZ_NAME] char arg2[SZ_NAME] bool redisplay, ad, upd pointer sp, sp1, buf, longarg, longarg2, logfile int bs, ss, xs, ys real pa, xsc, ysc int strdic(), strcmp(), nscan() bool clgetb(), fp_equalr() begin call smark (sp) call salloc (longarg, SZ_FNAME, TY_CHAR) call salloc (longarg2, SZ_FNAME, TY_CHAR) call salloc (logfile, SZ_FNAME, TY_CHAR) redisplay = false call sscan (command) call gargwrd (cmd, SZ_NAME) call gargwrd (Memc[longarg], SZ_FNAME) call gargwrd (Memc[longarg2], SZ_FNAME) call strcpy (Memc[longarg], arg, SZ_NAME) call strcpy (Memc[longarg2], arg2, SZ_NAME) switch (strdic (cmd, cmd, SZ_NAME, CMDDICT)) { case AUTODISPLAY: if (nscan () == 2) { call sscan (arg) call gargb (ad) if (nscan () != 1) { call printf ("error reading autodisplay `%s'\n") call pargstr (arg) call flush (STDOUT) } else { autodisplay = ad } } else { call printf ("autodisplay %b\n") call pargb (autodisplay) call flush (STDOUT) } case BOXSIZE: if (nscan () == 2) { call sscan (arg) call gargi (bs) if (nscan () != 1) { call printf ("error reading boxsize `%s'\n") call pargstr (arg) call flush (STDOUT) } else if (mod (bs, 2) != 1) { boxsize = bs + 1 call printf ("boxsize must be odd, using boxsize = %d\n") call pargi (boxsize) call flush (STDOUT) } else { boxsize = bs } } else { call printf ("boxsize = %d\n") call pargi (boxsize) call flush (STDOUT) } case BADCOLOR: if (nscan () == 2) { if (strdic (arg, arg, SZ_NAME, COLORDICT) == 0) { call printf ("unknown color `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call strcpy (arg, bcolor, SZ_NAME) } } else { call printf ("badcolor = %s\n") call pargstr (bcolor) call flush (STDOUT) } case GOODCOLOR: if (nscan () == 2) { if (strdic (arg, arg, SZ_NAME, COLORDICT) == 0) { call printf ("unknown color `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call strcpy (arg, gcolor, SZ_NAME) } } else { call printf ("goodcolor = %s\n") call pargstr (gcolor) call flush (STDOUT) } case EPARAM: if (nscan () != 2) { call printf ("command needs an argument (%s|)\n") call pargstr (TASKDICT) call flush (STDOUT) } else if (strdic (arg, arg, SZ_NAME, TASKDICT) == 0) { call printf ("invalid parameter set `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call smark (sp1) call salloc (buf, SZ_FNAME, TY_CHAR) call sprintf (Memc[buf], SZ_FNAME, "eparam %s") call pargstr (arg) call clcmdw (Memc[buf]) call sfree (sp1) if (strcmp (arg, "selectpars") == 0) { call tp_select (tp, cp) redisplay = true } } case MARKER: if (nscan () == 2) { if (strdic (arg, arg, SZ_NAME, MARKDICT) == 0) { call printf ("unknown marker type `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call strcpy (arg, mark, SZ_NAME) } } else { call printf ("marker = %s\n") call pargstr (mark) call flush (STDOUT) } case OMARKER: if (nscan () == 2) { if (strdic (arg, arg, SZ_NAME, MARKDICT) == 0) { call printf ("unknown marker type `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call strcpy (arg, ovmark, SZ_NAME) } } else { call printf ("omarker = %s\n") call pargstr (ovmark) call flush (STDOUT) } case REPLACE: call printf ("Replace predicted X,Y coords for all sources? ") if (clgetb ("go_ahead")) { call replace (tp, cp, nstars) redisplay = false call printf ("Done!\n") } else { call printf ("Predicted coordinates not replaced.\n") } case ROTATE: if (nscan () == 2) { call sscan (arg) call gargr (pa) if (nscan () != 1) { call printf ("error reading rotate argument `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call printf ("Reposition ALL catalog sources %.4g degrees? ") call pargr (pa) call flush (STDOUT) if (clgetb ("go_ahead")) { pangle = pa call rotate (image, tp, cp, nstars, pangle) redisplay = true } else { call printf ("rotate unchanged\n") } } } else { call printf ("latest rotate argument = %.4g degrees\n") call pargr (pangle) call flush (STDOUT) } case SCALE: if (nscan () == 3) { call sscan (arg) call gargr (xsc) if (nscan () != 1) { call printf ("error reading X scale factor `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call sscan (arg2) call gargr (ysc) if (nscan () != 1) { call printf ("error reading Y scale factor `%s'\n") call pargstr (arg2) call flush (STDOUT) } else { call printf ("Scale ALL catalog sources (%.2g,%.2g) percent? ") call pargr (xsc) call pargr (ysc) call flush (STDOUT) if (clgetb ("go_ahead")) { xscale = xsc yscale = ysc call scale (image, tp, cp, nstars, xscale, yscale) redisplay = true } else { call printf ("scale unchanged\n") } } } } else if (nscan () == 2) { call sscan (arg) call gargr (xsc) if (nscan () != 1) { call printf ("error reading X scale factor `%s'\n") call pargstr (arg) call flush (STDOUT) } else { ysc = xsc call printf ("Scale ALL catalog sources %.2g percent? ") call pargr (xsc) call flush (STDOUT) if (clgetb ("go_ahead")) { xscale = xsc yscale = ysc call scale (image, tp, cp, nstars, xscale, yscale) redisplay = true } else { call printf ("scale unchanged\n") } } } else { if (fp_equalr (xscale, yscale)) { call printf ("latest scale factor = %.2g percent\n") call pargr (xscale) } else { call printf ("latest scale factor = (%.2g,%.2g) percent\n") call pargr (xscale) call pargr (yscale) } call flush (STDOUT) } case SHIFT: if (nscan () == 3) { call sscan (arg) call gargi (xs) if (nscan () != 1) { call printf ("error reading X shift `%s'\n") call pargstr (arg) call flush (STDOUT) } else { call sscan (arg2) call gargi (ys) if (nscan () != 1) { call printf ("error reading Y shift `%s'\n") call pargstr (arg2) call flush (STDOUT) } else { call printf ("Shift ALL catalog sources (%d,%d) pixels? ") call pargi (xs) call pargi (ys) call flush (STDOUT) if (clgetb ("go_ahead")) { xshift = xs yshift = ys call shift (image, tp, cp, nstars, xshift, yshift) redisplay = true } else { call printf ("shift unchanged\n") } } } } else if (nscan () == 2) { call printf ("error with `%s %s', both X&Y shifts are required\n") call pargstr (arg) call pargstr (arg2) call flush (STDOUT) } else { call printf ("latest shift = (%d,%d) pixels\n") call pargi (xshift) call pargi (yshift) call flush (STDOUT) } case SHOW: if (nscan () == 2) { call strcpy (Memc[longarg], Memc[logfile], SZ_FNAME) call printlog (table, Memc[logfile], false) } else { call printlog (table, "", true) } case SUBSAMPLE: if (nscan () == 2) { call sscan (arg) call gargi (ss) if (nscan () != 1) { call printf ("error reading subsample factor `%s'\n") call pargstr (arg) call flush (STDOUT) } else if (ss < 1) { subsample = 1 redisplay = true call printf ( "subsampling must be >= 1, using subsample = %d\n") call pargi (subsample) call flush (STDOUT) } else { subsample = ss redisplay = true } } else { call printf ("subsample = %d\n") call pargi (subsample) call flush (STDOUT) } case UPDATE: if (nscan () == 2) { call sscan (arg) call gargb (upd) if (nscan () != 1) { call printf ("error reading autodisplay `%s'\n") call pargstr (arg) call flush (STDOUT) } else { update = upd } } else { call printf ("update %b\n") call pargb (update) call flush (STDOUT) } default: call printf ("\007unknown colon command, `%s', type `?' for help\n") call pargstr (cmd) call flush (STDOUT) } call sfree (sp) return (redisplay) end # OPENTAB -- open the catalog table and locate the columns. int procedure opentab (table, tp, cp) char table[ARB] #I input (raw) table name pointer tp #O table pointer pointer cp[NUM_COLS] #O array of column pointers pointer sp, buf, pp char colname[SZ_COLNAME, NUM_COLS] pointer clopset(), tbtopn() int tbpsta() errchk tbtopn, tbcfnd begin call smark (sp) call salloc (buf, SZ_FNAME, TY_CHAR) call fseti (CLIN, F_CANCEL, OK) call clgstr ("catpars", Memc[buf], SZ_FNAME) pp = clopset (Memc[buf]) call sfree (sp) call clgpset (pp, "xpred_col", colname[1,1], SZ_COLNAME) call clgpset (pp, "ypred_col", colname[1,2], SZ_COLNAME) call clgpset (pp, "xcen_col", colname[1,3], SZ_COLNAME) call clgpset (pp, "ycen_col", colname[1,4], SZ_COLNAME) call clgpset (pp, "cerr_col", colname[1,5], SZ_COLNAME) call clgpset (pp, "sub_col", colname[1,6], SZ_COLNAME) call clgpset (pp, "cen_col", colname[1,7], SZ_COLNAME) call clgpset (pp, "obj_col", colname[1,8], SZ_COLNAME) call clgpset (pp, "id_col", colname[1,9], SZ_COLNAME) call clcpset (pp) # open the tables, find the columns, return the number of rows tp = tbtopn (table, READ_WRITE, 0) call tbcfnd (tp, colname, cp, NUM_COLS) return (tbpsta (tp, TBL_NROWS)) end # NEAREST -- Find the catalog object nearest the pixel (cursor) position # by minimizing the squared cartesian distance. Returns the catalog index. # Only examines the sources in the current subset. int procedure nearest (wx, wy, tp, cp, n, cx, cy) real wx, wy #I cursor coordinates pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table real cx, cy #O catalog coordinates of selected object pointer sp, x, y, s, xf, yf, sf real dx, dy, r2, r2min int index, i begin call smark (sp) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (s, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (sf, n, TY_BOOL) call tbcgtr (tp, cp[XCEN], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[SUBSET], Memi[s], Memb[sf], 1, n) r2min = MAX_REAL index = 1 # should never need this default do i = 1, n { if (Memb[xf+i-1] || Memb[yf+i-1] || Memb[sf+i-1]) next if (Memi[s+i-1] == YES) { dx = wx - Memr[x+i-1] dy = wy - Memr[y+i-1] r2 = dx ** 2 + dy ** 2 if (r2 < r2min) { r2min = r2 index = i } } } cx = Memr[x+index-1] cy = Memr[y+index-1] call sfree (sp) return (index) end # DISPLAY -- construct a command line and display an image. procedure display (image, frame, fill) char image[ARB] #I image name to display int frame #I frame number to display it in bool fill #I fill the frame pointer sp, cmdline begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call sprintf (Memc[cmdline], SZ_LINE, DISPCMD) call pargstr (image) call pargi (frame) call pargb (fill) # currently error checking doesn't work call clcmdw (Memc[cmdline]) call sfree (sp) end # TPLTSOL -- fit the currently centered catalog sources. procedure tpltsol (image, table, database, update, refitcat, ra, dec, eq) char image[ARB] #I image name char table[ARB] #I table name char database[ARB] #I output database name bool update #I update image header WCS? bool refitcat #I update uncentered catalog source XY's? char ra[ARB] #I plate center RA char dec[ARB] #I plate center Dec real eq #I plate center equinox pointer sp, cmdline begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) if (update) { if (refitcat) { call sprintf (Memc[cmdline], SZ_LINE, FITCMD) call pargstr (image) call pargstr (table) call pargstr (database) call pargstr ("yes") call pargstr ("yes") call pargstr (ra) call pargstr (dec) call pargr (eq) } else { call sprintf (Memc[cmdline], SZ_LINE, FITCMD) call pargstr (image) call pargstr (table) call pargstr (database) call pargstr ("yes") call pargstr ("no") call pargstr (ra) call pargstr (dec) call pargr (eq) } } else { if (refitcat) { call sprintf (Memc[cmdline], SZ_LINE, FITCMD) call pargstr (image) call pargstr (table) call pargstr (database) call pargstr ("no") call pargstr ("yes") call pargstr (ra) call pargstr (dec) call pargr (eq) } else { call sprintf (Memc[cmdline], SZ_LINE, FITCMD) call pargstr (image) call pargstr (table) call pargstr (database) call pargstr ("no") call pargstr ("no") call pargstr (ra) call pargstr (dec) call pargr (eq) } } call clcmdw (Memc[cmdline]) call sfree (sp) end # PRINTLOG -- dump table log information into a file procedure printlog (table, logfile, pageit) char table[ARB] #I table name char logfile[ARB] #I logfile name bool pageit #I page output from scratch file? pointer sp, cmdline, tmpfile, rewrite int access(), strcmp() begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call salloc (tmpfile, SZ_FNAME, TY_CHAR) call salloc (rewrite, SZ_FNAME, TY_CHAR) if (pageit) { call mktemp ("tmp$JUNK", Memc[tmpfile], SZ_FNAME) } else { if (access (logfile, 0, 0) == YES) { call printf ("File `%s' exists") call pargstr (logfile) call flush (STDOUT) call clgstr ("_qpars.rewrite", Memc[rewrite], SZ_FNAME) if (strcmp (Memc[rewrite], "cancel") == 0) return else if (strcmp (Memc[rewrite], "replace") == 0) call delete (logfile) } call strcpy (logfile, Memc[tmpfile], SZ_FNAME) } call sprintf (Memc[cmdline], SZ_LINE, LOGCMD) call pargstr (table) call pargstr (Memc[tmpfile]) call clcmdw (Memc[cmdline]) if (pageit) { call pagefiles (Memc[tmpfile]) if (access (Memc[tmpfile], 0, 0) == YES) call delete (Memc[tmpfile]) } call sfree (sp) end # OVERLAY -- construct a command line and overlay marks on the display. procedure overlay (frame, tp, cp, xcol, ycol, n, subsample, marktype, color, valid) int frame #I frame number to display it in pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int xcol, ycol #I indices into the column ptr array int n #I total number of entries in the table int subsample #I subsample factor for catalog objects char marktype[ARB] #I type of mark to draw char color[ARB] #I color of mark to draw int valid #I mark valid (or invalid) sources? pointer sp, cmdline, tmp, x, y, s, c, o, xf, yf, sf, cf, of int colorcode, i, fd, nsample, nsubsample int open(), strdic() begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call salloc (tmp, SZ_FNAME, TY_CHAR) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (s, n, TY_INT) call salloc (c, n, TY_INT) call salloc (o, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (sf, n, TY_BOOL) call salloc (cf, n, TY_BOOL) call salloc (of, n, TY_BOOL) if (valid == YES) call printf ("\nMarking centered catalog sources in ") else if (valid == NO) call printf ("\nMarking uncentered catalog sources in ") else if (valid == ISOBJ) call printf ("\nMarking objects in ") switch (strdic (color, Memc[tmp], SZ_FNAME, COLORDICT)) { case BLACK: colorcode = BLACKCODE call printf ("black...\n") case WHITE: colorcode = WHITECODE call printf ("white...\n") case RED: colorcode = REDCODE call printf ("red...\n") case GREEN: colorcode = GREENCODE call printf ("green...\n") case BLUE: colorcode = BLUECODE call printf ("blue...\n") case YELLOW: colorcode = YELLOWCODE call printf ("yellow...\n") } call flush (STDOUT) call tbcgtr (tp, cp[xcol], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[ycol], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[SUBSET], Memi[s], Memb[sf], 1, n) call tbcgti (tp, cp[CENTER], Memi[c], Memb[cf], 1, n) call tbcgti (tp, cp[OBJECT], Memi[o], Memb[of], 1, n) # dump valid or invalid X,Y pairs from the table to the tmp file call mktemp ("tmp$JUNK", Memc[tmp], SZ_FNAME) fd = open (Memc[tmp], NEW_FILE, TEXT_FILE) nsample = 0 nsubsample = 0 do i = 1, n { if (Memb[xf+i-1] || Memb[yf+i-1] || Memb[sf+i-1] || Memb[cf+i-1] || Memb[of+i-1]) { next } # not sure what tbcgti returns if the sf flag (above) was set if (Memi[s+i-1] == NO) next # hard to phrase this elegantly if (Memi[c+i-1] == valid && Memi[o+i-1] == NO) ; else if (valid == ISOBJ && Memi[o+i-1] == YES) ; else next nsample = nsample + 1 # always include the first source in the subsample if (valid != ISOBJ && subsample > 1) { if (mod (nsample, subsample) != 1) next } nsubsample = nsubsample + 1 call fprintf (fd, "%g %g\n") call pargr (Memr[x+i-1]) call pargr (Memr[y+i-1]) } call close (fd) if (valid == ISOBJ) { if (nsample <= 0) { call printf (" no objects to mark\n") } else { call printf (" all %d objects will be marked...") call pargi (nsample) } } else if (subsample > 1) { if (nsample <= 0) { call printf (" no sources to mark\n") } else if (nsubsample <= 0) { call printf(" no sources remain to mark out of %d total") call pargi (nsample) call printf(" (SUBSAMPLED 1:%d)\n") call pargi (subsample) } else { call printf (" marking %d sources out of %d total") call pargi (nsubsample) call pargi (nsample) call printf(" (SUBSAMPLED 1:%d)...") call pargi (subsample) } } else { if (nsample <= 0) { call printf (" no sources to mark\n") } else { call printf (" all %d sources will be marked...") call pargi (nsample) } } call flush (STDOUT) if (nsubsample > 0) { call sprintf (Memc[cmdline], SZ_LINE, MARKCMD) call pargi (frame) call pargstr (Memc[tmp]) call pargstr (marktype) call pargi (colorcode) call clcmdw (Memc[cmdline]) call printf ("done\n") call flush (STDOUT) } call delete (Memc[tmp]) call sfree (sp) end # CENTER -- center the sources. procedure center (image, boxsize, tp, cp, n, xshift, yshift, update) char image[ARB] #I image name int boxsize #I centering box fullwidth pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table real xshift, yshift #I X and Y shift to add before centering bool update #I update centered or uncentered sources? pointer sp, cmdline, coords, shifts, tmp, x, y, c, s, o, xf, yf, cf, sf, of int cfd, sfd, tfd, junk, i, index real xout, yout int open(), getline(), fscan(), nscan() begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call salloc (coords, SZ_FNAME, TY_CHAR) call salloc (shifts, SZ_FNAME, TY_CHAR) call salloc (tmp, SZ_FNAME, TY_CHAR) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (c, n, TY_INT) call salloc (s, n, TY_INT) call salloc (o, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (cf, n, TY_BOOL) call salloc (sf, n, TY_BOOL) call salloc (of, n, TY_BOOL) call printf ("\nCentering catalog sources...") call flush (STDOUT) call tbcgtr (tp, cp[XCEN], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[CENTER], Memi[c], Memb[cf], 1, n) call tbcgti (tp, cp[SUBSET], Memi[s], Memb[cf], 1, n) call tbcgti (tp, cp[OBJECT], Memi[o], Memb[of], 1, n) call mktemp ("tmp$JUNK", Memc[coords], SZ_FNAME) call mktemp ("tmp$JUNK", Memc[shifts], SZ_FNAME) call mktemp ("tmp$JUNK", Memc[tmp], SZ_FNAME) cfd = open (Memc[coords], NEW_FILE, TEXT_FILE) # need to handle undefined coordinates do i = 1, n { call fprintf (cfd, "%g %g\n") call pargr (Memr[x+i-1]) call pargr (Memr[y+i-1]) } call close (cfd) sfd = open (Memc[shifts], NEW_FILE, TEXT_FILE) call fprintf (sfd, "%g %g\n") call pargr (xshift) call pargr (yshift) call close (sfd) call sprintf (Memc[cmdline], SZ_LINE, CENTCMD) call pargstr (image) call pargstr (Memc[coords]) call pargstr (Memc[shifts]) call pargi (boxsize) call pargstr (Memc[tmp]) call clcmdw (Memc[cmdline]) call delete (Memc[coords]) call delete (Memc[shifts]) tfd = open (Memc[tmp], READ_ONLY, TEXT_FILE) junk = getline (tfd, Memc[shifts]) # eat the comment, recycle shifts do index = 1, n { # only update the current subset if (Memi[s+index-1] == NO) next # don't update the program objects! if (Memi[o+index-1] == YES) next # want to shift sources for which the centering failed if (update == (Memi[c+index-1] == YES)) { Memr[x+index-1] = Memr[x+index-1] - xshift Memr[y+index-1] = Memr[y+index-1] - yshift } } index = 1 # in case first read fails for (i=1; i <= n && fscan (tfd) != EOF; i=i+1) { call gargwrd (Memc[shifts], SZ_LINE) call gargr (xout) call gargwrd (Memc[coords], SZ_LINE) # ignore it call gargr (yout) call gargwrd (Memc[coords], SZ_LINE) # ignore it call gargi (index) # look for `Warning: failed to converge near ...', don't worry # about previously centered sources that flunked this time if (Memc[shifts] != 'W' && nscan () == 6) { # only update the current subset if (Memi[s+index-1] == NO) next # don't update the program objects! if (Memi[o+index-1] == YES) next # either only update centered sources or # only update previously uncentered sources if (update == (Memi[c+index-1] == YES)) { Memr[x+index-1] = xout Memr[y+index-1] = yout Memi[c+index-1] = YES } } } call tbcptr (tp, cp[XCEN], Memr[x], 1, n) call tbcptr (tp, cp[YCEN], Memr[y], 1, n) call tbcpti (tp, cp[CENTER], Memi[c], 1, n) call tbtflu (tp) call close (tfd) call delete (Memc[tmp]) call sfree (sp) call printf ("done\n") call flush (STDOUT) end # PCENTER -- center the program sources. procedure pcenter (image, boxsize, tp, cp, n, xshift, yshift, update) char image[ARB] #I image name int boxsize #I centering box fullwidth pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table real xshift, yshift #I X and Y shift to add before centering bool update #I update centered or uncentered sources? pointer sp, cmdline, coords, shifts, tmp, x, y, c, s, o, xf, yf, cf, sf, of int cfd, sfd, tfd, junk, i, index real xout, yout int open(), getline(), fscan(), nscan() begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call salloc (coords, SZ_FNAME, TY_CHAR) call salloc (shifts, SZ_FNAME, TY_CHAR) call salloc (tmp, SZ_FNAME, TY_CHAR) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (c, n, TY_INT) call salloc (s, n, TY_INT) call salloc (o, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (cf, n, TY_BOOL) call salloc (sf, n, TY_BOOL) call salloc (of, n, TY_BOOL) call tbcgtr (tp, cp[XCEN], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[CENTER], Memi[c], Memb[cf], 1, n) call tbcgti (tp, cp[SUBSET], Memi[s], Memb[cf], 1, n) call tbcgti (tp, cp[OBJECT], Memi[o], Memb[of], 1, n) call mktemp ("tmp$JUNK", Memc[coords], SZ_FNAME) call mktemp ("tmp$JUNK", Memc[shifts], SZ_FNAME) call mktemp ("tmp$JUNK", Memc[tmp], SZ_FNAME) cfd = open (Memc[coords], NEW_FILE, TEXT_FILE) # need to handle undefined coordinates do i = 1, n { call fprintf (cfd, "%g %g\n") call pargr (Memr[x+i-1]) call pargr (Memr[y+i-1]) } call close (cfd) sfd = open (Memc[shifts], NEW_FILE, TEXT_FILE) call fprintf (sfd, "%g %g\n") call pargr (xshift) call pargr (yshift) call close (sfd) call sprintf (Memc[cmdline], SZ_LINE, CENTCMD) call pargstr (image) call pargstr (Memc[coords]) call pargstr (Memc[shifts]) call pargi (boxsize) call pargstr (Memc[tmp]) call clcmdw (Memc[cmdline]) call delete (Memc[coords]) call delete (Memc[shifts]) tfd = open (Memc[tmp], READ_ONLY, TEXT_FILE) junk = getline (tfd, Memc[shifts]) # eat the comment, recycle shifts do index = 1, n { # only update the current subset if (Memi[s+index-1] == NO) next # don't update the reference objects! if (Memi[o+index-1] == NO) next # want to shift sources for which the centering failed if (update == (Memi[c+index-1] == YES)) { Memr[x+index-1] = Memr[x+index-1] - xshift Memr[y+index-1] = Memr[y+index-1] - yshift } } index = 1 # in case first read fails for (i=1; i <= n && fscan (tfd) != EOF; i=i+1) { call gargwrd (Memc[shifts], SZ_LINE) call gargr (xout) call gargwrd (Memc[coords], SZ_LINE) # ignore it call gargr (yout) call gargwrd (Memc[coords], SZ_LINE) # ignore it call gargi (index) # look for `Warning: failed to converge near ...', don't worry # about previously centered sources that flunked this time if (Memc[shifts] != 'W' && nscan () == 6) { # only update the current subset if (Memi[s+index-1] == NO) next # don't update the reference objects! if (Memi[o+index-1] == NO) next # either only update centered sources or # only update previously uncentered sources if (update == (Memi[c+index-1] == YES)) { Memr[x+index-1] = xout Memr[y+index-1] = yout Memi[c+index-1] = YES } } } call tbcptr (tp, cp[XCEN], Memr[x], 1, n) call tbcptr (tp, cp[YCEN], Memr[y], 1, n) call tbcpti (tp, cp[CENTER], Memi[c], 1, n) call tbtflu (tp) call close (tfd) call delete (Memc[tmp]) call sfree (sp) end # ROTATE -- rotate the catalog sources, mark as uncentered. procedure rotate (image, tp, cp, n, pangle) char image[ARB] #I image name pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table real pangle #I relative position angle pointer sp, x, y, c, o, xf, yf, cf, of, im int index real xx, yy, xmiddle, ymiddle, rpangle pointer immap() errchk immap, imunmap begin call smark (sp) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (c, n, TY_INT) call salloc (o, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (cf, n, TY_BOOL) call salloc (of, n, TY_BOOL) if (pangle > 0) { call printf ("\nRotating catalog sources by %.4g degrees (CCW) ...") call pargr (pangle) } else { call printf ("\nRotating catalog sources by %.4g degrees (CW) ...") call pargr (pangle) } call flush (STDOUT) # invert to match sense of tfields task position angle rpangle = - (PI * pangle) / 180. im = immap (image, READ_ONLY, 0) xmiddle = real (IM_LEN(im,1)) / 2. ymiddle = real (IM_LEN(im,2)) / 2. call imunmap (im) call tbcgtr (tp, cp[XCEN], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[CENTER], Memi[c], Memb[cf], 1, n) call tbcgti (tp, cp[OBJECT], Memi[o], Memb[of], 1, n) # rotate all catalog sources, even if not currently in subset # rotated sources (not program objects) are also marked uncentered do index = 1, n { # don't update the program objects! if (Memi[o+index-1] == YES) next xx = Memr[x+index-1] - xmiddle yy = Memr[y+index-1] - ymiddle Memr[x+index-1] = xx*cos(rpangle) + yy*sin(rpangle) + xmiddle Memr[y+index-1] = - xx*sin(rpangle) + yy*cos(rpangle) + ymiddle Memi[c+index-1] = NO } call tbcptr (tp, cp[XCEN], Memr[x], 1, n) call tbcptr (tp, cp[YCEN], Memr[y], 1, n) call tbcpti (tp, cp[CENTER], Memi[c], 1, n) call tbtflu (tp) call printf ("done\n") call flush (STDOUT) call sfree (sp) end # SCALE -- scale the catalog sources (about image center), mark as uncentered. procedure scale (image, tp, cp, n, xscale, yscale) char image[ARB] #I image name pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table real xscale #I relative X scale factor, percent real yscale #I relative Y scale factor, percent pointer sp, x, y, c, o, xf, yf, cf, of, im int index real xx, yy, xmiddle, ymiddle pointer immap() bool fp_equalr() errchk immap, imunmap begin call smark (sp) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (c, n, TY_INT) call salloc (o, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (cf, n, TY_BOOL) call salloc (of, n, TY_BOOL) if (fp_equalr (xscale, yscale)) { call printf ("\nScaling catalog sources by %.1g percent...") call pargr (xscale) } else { call printf ("\nScaling catalog sources by (%.1g,%.1g) percent...") call pargr (xscale) call pargr (yscale) } call flush (STDOUT) im = immap (image, READ_ONLY, 0) xmiddle = real (IM_LEN(im,1)) / 2. ymiddle = real (IM_LEN(im,2)) / 2. call imunmap (im) call tbcgtr (tp, cp[XCEN], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[CENTER], Memi[c], Memb[cf], 1, n) call tbcgti (tp, cp[OBJECT], Memi[o], Memb[of], 1, n) # scale all catalog sources, even if not currently in subset # scaled sources (not program objects) are also marked uncentered do index = 1, n { # don't update the program objects! if (Memi[o+index-1] == YES) next xx = Memr[x+index-1] - xmiddle yy = Memr[y+index-1] - ymiddle Memr[x+index-1] = xx*(xscale/100.0) + xmiddle Memr[y+index-1] = yy*(yscale/100.0) + ymiddle Memi[c+index-1] = NO } call tbcptr (tp, cp[XCEN], Memr[x], 1, n) call tbcptr (tp, cp[YCEN], Memr[y], 1, n) call tbcpti (tp, cp[CENTER], Memi[c], 1, n) call tbtflu (tp) call printf ("done\n") call flush (STDOUT) call sfree (sp) end # SHIFT -- shift the catalog sources, mark as uncentered. procedure shift (image, tp, cp, n, xshift, yshift) char image[ARB] #I image name pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table int xshift #I X axis shift to apply int yshift #I Y axis shift to apply pointer sp, x, y, c, o, xf, yf, cf, of int index begin call smark (sp) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (c, n, TY_INT) call salloc (o, n, TY_INT) call salloc (xf, n, TY_BOOL) call salloc (yf, n, TY_BOOL) call salloc (cf, n, TY_BOOL) call salloc (of, n, TY_BOOL) call printf ("\nShifting catalog sources by (%d,%d)...") call pargi (xshift) call pargi (yshift) call flush (STDOUT) call tbcgtr (tp, cp[XCEN], Memr[x], Memb[xf], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[yf], 1, n) call tbcgti (tp, cp[CENTER], Memi[c], Memb[cf], 1, n) call tbcgti (tp, cp[OBJECT], Memi[o], Memb[of], 1, n) # shift all catalog sources, even if not currently in subset # shifted sources (not program objects) are also marked uncentered do index = 1, n { # don't update the program objects! if (Memi[o+index-1] == YES) next Memr[x+index-1] = Memr[x+index-1] + xshift Memr[y+index-1] = Memr[y+index-1] + yshift Memi[c+index-1] = NO } call tbcptr (tp, cp[XCEN], Memr[x], 1, n) call tbcptr (tp, cp[YCEN], Memr[y], 1, n) call tbcpti (tp, cp[CENTER], Memi[c], 1, n) call tbtflu (tp) call printf ("done\n") call flush (STDOUT) call sfree (sp) end # OVERLAY_ONE -- mark a single object on the display. procedure overlay_one (frame, x, y, marktype, color) int frame #I frame number to display it in real x, y #I coordinates for the mark char marktype[ARB] #I type of mark to draw char color[ARB] #I color of mark to draw pointer sp, cmdline, tmp int colorcode, fd int open(), strdic() begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call salloc (tmp, SZ_FNAME, TY_CHAR) switch (strdic (color, Memc[tmp], SZ_FNAME, COLORDICT)) { case BLACK: colorcode = BLACKCODE case WHITE: colorcode = WHITECODE case RED: colorcode = REDCODE case GREEN: colorcode = GREENCODE case BLUE: colorcode = BLUECODE case YELLOW: colorcode = YELLOWCODE } # dump valid or invalid X,Y pairs from the table to the tmp file call mktemp ("tmp$JUNK", Memc[tmp], SZ_FNAME) fd = open (Memc[tmp], NEW_FILE, TEXT_FILE) call fprintf (fd, "%g %g\n") call pargr (x) call pargr (y) call close (fd) call sprintf (Memc[cmdline], SZ_LINE, MARKCMD) call pargi (frame) call pargstr (Memc[tmp]) call pargstr (marktype) call pargi (colorcode) call clcmdw (Memc[cmdline]) call delete (Memc[tmp]) call sfree (sp) end # CENTER_ONE -- center a single source. This is overkill, but want to # use the same algorithm whether centering a list or a single source. int procedure center_one (image, boxsize, xin, yin, xout, yout) char image[ARB] #I image name int boxsize #I centering box fullwidth real xin, yin #I initial coordinates real xout, yout #O centered coordinates (or INDEF) pointer sp, cmdline, coords, tmp, buf int cfd, tfd, nchar int open(), getline(), nscan() begin call smark (sp) call salloc (cmdline, SZ_LINE, TY_CHAR) call salloc (coords, SZ_FNAME, TY_CHAR) call salloc (tmp, SZ_FNAME, TY_CHAR) call salloc (buf, SZ_LINE, TY_CHAR) call mktemp ("tmp$JUNK", Memc[coords], SZ_FNAME) call mktemp ("tmp$JUNK", Memc[tmp], SZ_FNAME) cfd = open (Memc[coords], WRITE_ONLY, TEXT_FILE) call fprintf (cfd, "%g %g\n") call pargr (xin) call pargr (yin) call close (cfd) call sprintf (Memc[cmdline], SZ_LINE, CENTCMD) call pargstr (image) call pargstr (Memc[coords]) call pargstr ("''") call pargi (boxsize) call pargstr (Memc[tmp]) call clcmdw (Memc[cmdline]) tfd = open (Memc[tmp], READ_ONLY, TEXT_FILE) nchar = getline (tfd, Memc[buf]) # eat the comment nchar = getline (tfd, Memc[buf]) call close (tfd) call delete (Memc[coords]) call delete (Memc[tmp]) # look for `Warning: failed to converge near ...' if (nchar == EOF || nchar <= 0 || Memc[buf] == 'W') { call sfree (sp) xout = INDEFR yout = INDEFR return (ERR) } call sscan (Memc[buf]) call gargwrd (Memc[tmp], SZ_FNAME) call gargr (xout) call gargwrd (Memc[tmp], SZ_FNAME) call gargr (yout) if (nscan () != 4) { call sfree (sp) xout = INDEFR yout = INDEFR return (ERR) } call sfree (sp) return (OK) end # NEWPOINT -- mark an object as well centered. Note that the centering # could have converged on the wrong location, though. procedure newpoint (tp, cp, n, index, newx, newy) pointer tp #I catalog descriptor pointer cp[NUM_COLS] #I column descriptor int n #I number of rows int index #I catalog row index real newx, newy #I newly measured coordinates begin if (index < 1 || index > n) { call eprintf ("Warning: indexed outside of catalog\n") call eprintf ("Catalog not updated!\n") call flush (STDERR) return } call tbrptr (tp, cp[XCEN], newx, 1, index) call tbrptr (tp, cp[YCEN], newy, 1, index) call tbrpti (tp, cp[CENTER], YES, 1, index) call tbtflu (tp) end # NEWOBJECT -- add an additional (program) object. procedure newobject (tp, cp, n, newx, newy, id) pointer tp #I catalog descriptor pointer cp[NUM_COLS] #I column descriptor int n #U number of rows real newx, newy #I newly measured coordinates int id #I id number for the new entry begin n = n + 1 call tbrptr (tp, cp[XPRED], newx, 1, n) call tbrptr (tp, cp[YPRED], newy, 1, n) call tbrptr (tp, cp[XCEN], newx, 1, n) call tbrptr (tp, cp[YCEN], newy, 1, n) call tbrptr (tp, cp[CERR], INDEFR, 1, n) call tbrpti (tp, cp[SUBSET], YES, 1, n) call tbrpti (tp, cp[CENTER], YES, 1, n) call tbrpti (tp, cp[OBJECT], YES, 1, n) call tbrpti (tp, cp[ID], id, 1, n) call tbtflu (tp) end # GOODPOINT -- mark an object as centered. procedure goodpoint (tp, cp, n, index) pointer tp #I catalog descriptor pointer cp[NUM_COLS] #I column descriptor int n #I number of rows int index #I catalog row index begin if (index < 1 || index > n) { call eprintf ("Warning: indexed outside of catalog\n") call eprintf ("Catalog not updated!\n") call flush (STDERR) return } call tbrpti (tp, cp[CENTER], YES, 1, index) call tbtflu (tp) end # BADPOINT -- mark an object as not centered. procedure badpoint (tp, cp, n, index) pointer tp #I catalog descriptor pointer cp[NUM_COLS] #I column descriptor int n #I number of rows int index #I catalog row index begin if (index < 1 || index > n) { call eprintf ("Warning: indexed outside of catalog\n") call eprintf ("Catalog not updated!\n") call flush (STDERR) return } call tbrpti (tp, cp[CENTER], NO, 1, index) call tbtflu (tp) end # TP_SELECT -- update the SUB_FLAG parameter from the selectpars pset. procedure tp_select (tp, cp) pointer tp #I table pointer pointer cp[NUM_COLS] #I array of column pointers pointer sp, buf, phrase, expr, pp, index, flags int i, idx, nindex, nentries bool disjunction, firsttime pointer clopset() bool clgpsetb() int strmatch() begin call allrows (tp, nindex, index) nentries = nindex call smark (sp) call salloc (buf, SZ_LINE, TY_CHAR) call salloc (phrase, SZ_LINE, TY_CHAR) call salloc (expr, SZ_LINE, TY_CHAR) call salloc (flags, nentries, TY_INT) # cache isn't updated if pset is a parameter # call clgstr ("selectpars", Memc[buf], SZ_FNAME) # pp = clopset (Memc[buf]) pp = clopset ("selectpars") disjunction = clgpsetb (pp, "disjunction") call clgpset (pp, "explicit", Memc[expr], SZ_LINE) if (Memc[expr] == EOS || strmatch (Memc[expr], "^#$") != 0) { call strcpy ("(", Memc[expr], SZ_LINE) # disjunction = clgpsetb (pp, "disjunction") firsttime = true # just use brute force # note that buffer overflow is silently ignored call clgpset (pp, "column1", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcpy ("(", Memc[phrase], SZ_LINE) call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "boolop1", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "value1", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call strcat (")", Memc[phrase], SZ_LINE) if (! firsttime) { if (disjunction) call strcat (" || ", Memc[expr], SZ_LINE) else call strcat (" && ", Memc[expr], SZ_LINE) } else firsttime = false call strcat (Memc[phrase], Memc[expr], SZ_LINE) } } } call clgpset (pp, "column2", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcpy ("(", Memc[phrase], SZ_LINE) call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "boolop2", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "value2", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call strcat (")", Memc[phrase], SZ_LINE) if (! firsttime) { if (disjunction) call strcat (" || ", Memc[expr], SZ_LINE) else call strcat (" && ", Memc[expr], SZ_LINE) } else firsttime = false call strcat (Memc[phrase], Memc[expr], SZ_LINE) } } } call clgpset (pp, "column3", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcpy ("(", Memc[phrase], SZ_LINE) call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "boolop3", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "value3", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call strcat (")", Memc[phrase], SZ_LINE) if (! firsttime) { if (disjunction) call strcat (" || ", Memc[expr], SZ_LINE) else call strcat (" && ", Memc[expr], SZ_LINE) } else firsttime = false call strcat (Memc[phrase], Memc[expr], SZ_LINE) } } } call clgpset (pp, "column4", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcpy ("(", Memc[phrase], SZ_LINE) call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "boolop4", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call clgpset (pp, "value4", Memc[buf], SZ_LINE) if (Memc[buf] != EOS && strmatch (Memc[buf], "^#$") == 0) { call strcat (Memc[buf], Memc[phrase], SZ_LINE) call strcat (")", Memc[phrase], SZ_LINE) if (! firsttime) { if (disjunction) call strcat (" || ", Memc[expr], SZ_LINE) else call strcat (" && ", Memc[expr], SZ_LINE) } else firsttime = false call strcat (Memc[phrase], Memc[expr], SZ_LINE) } } } # apparently want to select all catalog entries if (firsttime) { call amovki (YES, Memi[flags], nentries) call tbcpti (tp, cp[SUBSET], Memi[flags], 1, nentries) call tbtflu (tp) return } call strcat (")", Memc[expr], SZ_LINE) } call clcpset (pp) call select (tp, Memc[expr], nindex, Memi[index]) # not in the form needed for vops$alut.gx call amovki (NO, Memi[flags], nentries) do idx = 1, nindex { i = Memi[index+idx-1] Memi[flags+i-1] = YES } # put back the object listing call allrows (tp, nindex, index) call select (tp, "(OBJ_FLAG == 1)", nindex, Memi[index]) do idx = 1, nindex { i = Memi[index+idx-1] Memi[flags+i-1] = YES } call tbcpti (tp, cp[SUBSET], Memi[flags], 1, nentries) call tbtflu (tp) call mfree (index, TY_INT) call sfree (sp) end # REINIT -- reinitialize the centered coordinate columns to the values # from the predicted coordinate columns. All sources are affected. procedure reinit (tp, cp, n) pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table pointer sp, x, y, rbuf, ibuf, junk begin call smark (sp) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (rbuf, n, TY_REAL) call salloc (ibuf, n, TY_INT) call salloc (junk, n, TY_BOOL) # should check the flags... call tbcgtr (tp, cp[XPRED], Memr[x], Memb[junk], 1, n) call tbcgtr (tp, cp[YPRED], Memr[y], Memb[junk], 1, n) call amovkr (INDEFR, Memr[rbuf], n) call amovki (NO, Memi[ibuf], n) call tbcptr (tp, cp[XCEN], Memr[x], 1, n) call tbcptr (tp, cp[YCEN], Memr[y], 1, n) call tbcptr (tp, cp[CERR], Memr[rbuf], 1, n) call tbcpti (tp, cp[CENTER], Memi[ibuf], 1, n) call tbtflu (tp) call sfree (sp) end # REINIT_ONE -- reinitialize the centered coordinate columns for a # single source to the values from the predicted coordinate columns. procedure reinit_one (tp, cp, n, index, x, y) pointer tp #I catalog descriptor pointer cp[NUM_COLS] #I column descriptor int n #I number of rows int index #I catalog row index real x, y #O initialized x and y coordinates bool junk begin if (index < 1 || index > n) { call eprintf ("Warning: indexed outside of catalog\n") call eprintf ("Catalog not updated!\n") call flush (STDERR) return } # should check the flags... call tbrgtr (tp, cp[XPRED], x, junk, 1, index) call tbrgtr (tp, cp[YPRED], y, junk, 1, index) call tbrptr (tp, cp[XCEN], x, 1, index) call tbrptr (tp, cp[YCEN], y, 1, index) call tbrptr (tp, cp[CERR], INDEFR, 1, n) call tbrpti (tp, cp[CENTER], NO, 1, index) call tbtflu (tp) end # REPLACE -- reinitialize the predicted coordinate columns to the current # values from the centered coordinate columns. All sources are affected. procedure replace (tp, cp, n) pointer tp #I table pointer pointer cp[NUM_COLS] #I column pointers for x, y, and valid flag int n #I total number of entries in the table pointer sp, x, y, junk begin call smark (sp) call salloc (x, n, TY_REAL) call salloc (y, n, TY_REAL) call salloc (junk, n, TY_BOOL) # should check the flags... call tbcgtr (tp, cp[XCEN], Memr[x], Memb[junk], 1, n) call tbcgtr (tp, cp[YCEN], Memr[y], Memb[junk], 1, n) call tbcptr (tp, cp[XPRED], Memr[x], 1, n) call tbcptr (tp, cp[YPRED], Memr[y], 1, n) call tbtflu (tp) call sfree (sp) end �����������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tastrom.cl�����������������������������������������������������0000664�0000000�0000000�00000006203�13321663143�0020541�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure tastrom (table, output) string table {prompt="Input table name"} string output {prompt="Output root name"} pset catpars = "" {prompt="Catalog description pset\n"} real epoch = 2000. {prompt="Report epoch\n"} real ra_tan = INDEF {prompt="RA of the tangent point"} real dec_tan = INDEF {prompt="Dec of the tangent point"} real tepoch = INDEF {prompt="Epoch for the tangent coordinates\n"} string *list begin string ltable, loutput, tmp1, tmp2, buf real cepoch, ltepoch int ra_hrs, ra_min, dec_deg, dec_min, dec_sec, dec_sign real ra_sec tmp1 = mktemp ("tmp$tmp") tmp2 = mktemp ("tmp$tmp") ltable = table loutput = output print (epoch, >> tmp1) print ("ASTR", >> tmp1) ltepoch = tepoch # to avoid generating two prompts ra_hrs = int (ra_tan) ra_min = int (60. * (ra_tan - ra_hrs)) ra_sec = 60. * (60. * (ra_tan - ra_hrs) - ra_min) if (dec_tan < 0.) { dec_tan = - dec_tan dec_sign = -1 } else { dec_sign = 1 } dec_deg = int (dec_tan) dec_min = int (60. * (dec_tan - dec_deg)) dec_sec = int (60. * (60. * (dec_tan - dec_deg) - dec_min)) if (dec_sign == -1) dec_deg = - dec_deg printf ("%2d %02d %04.1f", ra_hrs, ra_min, ra_sec, >> tmp1) printf (" %3d %02d %02d", dec_deg, dec_min, dec_sec, >> tmp1) printf (" %8.4f %8.4f\n", ltepoch, ltepoch, >> tmp1) buf = catpars.sub_col // " == 1 && " // catpars.cen_col // " == 1 && " // catpars.obj_col // " == 0" tselect (ltable, tmp2, buf) tcalc (tmp2, "RA_HRS", "RA_DEG / 15.", datatype="real", colunits="", colfmt="%13.3h") tchcol (tmp2, "DEC_DEG", "", "%12.2h@", "", verbose=no) # tchcol (tmp2, "REGION", "", "%5d\n", "", verbose=no) tchcol (tmp2, "X_CENTER", "", "%8.2f", "", verbose=no) tchcol (tmp2, "Y_CENTER", "", "%8.2f #", "", verbose=no) tchcol (tmp2, "GSC_ID", "", "%5d\n", "", verbose=no) # tprint (tmp2, columns="ra_hrs,dec_deg,region,x_center,y_center,gsc_id", # prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, # rows="-", option="plain", sp_col="", lgroup=0, >> tmp1) tprint (tmp2, columns="ra_hrs,dec_deg,gsc_id,x_center,y_center,region", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, >> tmp1) tdelete (tmp2, ver-, >& "dev$null") print ("*", >> tmp1) print ("0.0 0.0 * JUNK", >> tmp1) buf = catpars.sub_col // " == 1 && " // catpars.cen_col // " == 1 && " // catpars.obj_col // " == 1" tselect (ltable, tmp2, buf) tchcol (tmp2, "Y_CENTER", "", "%8.2f *", "", verbose=no) tchcol (tmp2, "GSC_ID", "", "%5d", "", verbose=no) tprint (tmp2, columns="x_center,y_center,gsc_id", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, >> tmp1) tdelete (tmp2, ver-, >& "dev$null") cepoch = catpars.cat_epoch print ("s/:/\ /g", > tmp2) print ("s/@/\ 0.0\ 0.0\ ", cepoch, "\ *\ /", >> tmp2) print ("s/#/\ *\ /", >> tmp2) print ("!sed -f ", osfn(tmp2), " ", osfn(tmp1), " > ", loutput, ".in") | cl delete (tmp2, ver-, >& "dev$null") delete (tmp1, ver-, >& "dev$null") astrom (osfn(loutput//".in"), > loutput // ".out") rename ("astrom.lis", loutput // ".ast") end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tfield.par�����������������������������������������������������0000664�0000000�0000000�00000002373�13321663143�0020507�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,"Input list of GSC tables" output,s,a,,,,"Output table with predicted X's & Y's" image,s,h,"",,,"Optional image header for field information" catpars,pset,h,"",,,"Catalog keyword description pset\n" ra,r,h,INDEF,0.,24.,"RA of the reference point (hours)" dec,r,h,INDEF,-90.,90.,"Dec of the reference point (degrees)" epoch,r,h,INDEF,,,"Reference coordinate epoch" date_obs,s,h,"",,,"Date of the observation (DD/MM/YY)" width,r,h,,0.,180.,"Field width (degrees)\n" xref,r,h,INDEF,,,"X coordinate of the reference point" yref,r,h,INDEF,,,"Y coordinate of the reference point\n" opaxis,b,h,no,,,"Is the reference point on the optical axis?" del_ra,r,h,0.,,,"RA offset of field center from the OA (degrees)" del_dec,r,h,0.,,,"Dec offset of field center from the OA (degrees)\n" north,s,h,"top",top|left|bottom|right,,"Direction of North in the field" east,s,h,"left",top|left|bottom|right,,"Direction of East in the field" pangle,r,h,0.,,,"Position angle of the field (CCW positive)\n" scale,r,h,,0.,,"Plate or image scale (\"/user)" edge,r,h,0.,0.,,"Edge buffer width (user units)\n" #relative,b,h,no,,,"Report relative X,Y coordinates?" #xorigin,r,h,500.,,,"X coordinate of the first table entry" #yorigin,r,h,500.,,,"Y coordinate of the first table entry" ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tfinder.cl�����������������������������������������������������0000664�0000000�0000000�00000015457�13321663143�0020516�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure tfinder (image, table) string image {prompt="Image name for field information"} string table {prompt="Output table name"} string objects = "" {prompt="List of program object X,Y coords"} string logfile = "" {prompt="Logfile for abridged table listing"} pset catpars = "" {prompt="Catalog description pset\n"} real ra = INDEF {prompt="RA of the reference point (hours)", min=0., max=24.} real dec = INDEF {prompt="Dec of the reference point (degrees)", min=-90., max=90.} real epoch = INDEF {prompt="Coordinate epoch"} string date_obs = "" {prompt="Date of the observation (DD/MM/YY)"} real xref = INDEF {prompt="X coordinate of the reference point"} real yref = INDEF {prompt="Y coordinate of the reference point\n"} bool opaxis = no {prompt="Is the reference point on the optical axis?"} real del_ra = 0. {prompt="RA offset of field center from the OA (degrees)"} real del_dec = 0. {prompt="Dec offset of field center from the OA (degrees)\n"} real scale {prompt="Plate or image scale (\"/user)"} real edge = 0. {prompt="Edge buffer width (user units)"} int boxsize = 9 {prompt="Centering box fullwidth",min=1} int frame = 1 {prompt="Display frame number\n"} string north = "top" {prompt="Direction of North in the field", enum="top|left|bottom|right"} string east = "left" {prompt="Direction of East in the field", enum="top|left|bottom|right"} real pangle = 0. {prompt="Position angle (CCW positive)\n"} string sort = "plate_id,region,gsc_id" {prompt="Columns for sorting Output"} bool verbose = yes {prompt="Print a running commentary?\n"} string marker = "circle" {prompt="Marker type", enum="point|circle|rectangle|plus|cross"} string omarker = "plus" {prompt="Overlay marker type", enum="point|circle|rectangle|plus|cross"} string goodcolor = "blue" {prompt="Color of good marker", enum="black|white|red|green|blue|yellow"} string badcolor = "red" {prompt="Color of bad marker", enum="black|white|red|green|blue|yellow"} string objcolor = "green" {prompt="Color of program object marker\n", enum="black|white|red|green|blue|yellow"} bool replace = yes {prompt="replace?", mode="q" } string *list begin string sp_col = "" string limage, ltable, tmp1, tmp2, buf1, buf2 real lscale, naxis1, naxis2, ira, idec, iepoch, iwidth int junk cache ("tinfo", "tvmark_", "imgets") tmp1 = mktemp ("tmp$tmp") tmp2 = mktemp ("tmp$tmp") limage = image ltable = table if (access (ltable) || access (ltable // ".tab")) { printf ("Output table %s already exists, ", ltable) if (replace) { tdelete (ltable, ver-, >& "dev$null") } else { printf ("\nChoose another table name and try again.\n") return } } if (access (logfile)) { printf ("Log file %s already exists, ", logfile) if (replace) { delete (logfile, ver-, >& "dev$null") } else { printf ("\nChoose another log file name and try again.\n") return } } lscale = scale # query the user if no default was supplied imgets (limage, "naxis1", >& "dev$null"); naxis1 = int (imgets.value) imgets (limage, "naxis2", >& "dev$null"); naxis2 = int (imgets.value) if (naxis1 == 0 || naxis2 == 0) error (1, "Problem reading image header") if (ra == INDEF) { imgets (limage, "ra", >& "dev$null") ira = real (imgets.value) if (ira == 0) error (1, "No RA in image header or parameter file.") } else ira = ra if (dec == INDEF) { imgets (limage, "dec", >& "dev$null") idec = real (imgets.value) if (idec == 0) error (1, "No declination in image header or parameter file.") } else idec = dec if (epoch == INDEF) { imgets (limage, "epoch", >& "dev$null") iepoch = real (imgets.value) if (iepoch == 0) iepoch = INDEF } else iepoch = epoch iwidth = lscale * (max (naxis1, naxis2) + edge) / 3600. if (verbose) print ("\nSearching the Guide Star Catalog index...") gscfind (ira, idec, iepoch, iwidth, > tmp1) if (verbose) { print ("\nReading the Guide Star Catalog regions:") type (tmp1) } cdrfits ("@" // tmp1, "1", "aka", template="", long_header=no, short_header=no, datatype="", blank=0., scale=yes, xdimtogf=no, oldirafname=yes, offset=0, > tmp2) delete (tmp1, ver-, >& "dev$null") if (verbose) { print ("\nExtracting overlapping sources from regions:") type (tmp2) } tfield ("@" // tmp2, ltable, image=limage, catpars=catpars, ra=ira, dec=idec, epoch=iepoch, date_obs=date_obs, width=iwidth, xref=xref, yref=yref, opaxis=opaxis, del_ra=del_ra, del_dec=del_dec, north=north, east=east, pangle=pangle, scale=lscale, edge=edge) tdelete ("@" // tmp2, ver-, >& "dev$null") delete (tmp2, ver-, >& "dev$null") tinfo (ltable, ttout-) if (tinfo.nrows <= 0) { beep print ("\nNo Guide Stars selected for this field!") print ("Check the input parameters and images...") return } # Provide reasonable defaults for the mark sizes, the extra # contour is for bolding (mostly for subsampling in saoimage). # This can be overridden within TPEAK by `:eparam tvmark_'. tvmark_.radii = (boxsize/2) // "," // (boxsize/2 + 1) tvmark_.lengths = (boxsize - 1) // "," // (boxsize + 1) if (verbose) { print ("\nInteractive centering using TPEAK:") print (" The size of the markers matches the centering box (", boxsize, "pixels).") print (" Change the size with the command `:eparam tvmark'.") } tpeak (limage, ltable, objects=objects, boxsize=boxsize, frame=frame, marker=marker, omarker=omarker, goodcolor=goodcolor, badcolor=badcolor, objcolor=objcolor, imcur="") files (sort, sort-, > tmp1) list = tmp1 if (fscan (list, sp_col) == 1) tsort (ltable, sort) # adjust ascend & casesens externally list = ""; delete (tmp1, ver-, >& "dev$null") if (logfile != "") { tselect (ltable, tmp1, "CEN_FLAG == 1") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { print ("No sources were centered!", > logfile) } else { print ("List of successfully centered sources:\n", > logfile) tprint (tmp1, prparam=no, prdata=yes, pwidth=80, plength=0, showrow=yes, showhdr=yes, lgroup=0, columns="REGION,GSC_ID,X_CENTER,Y_CENTER,MAG_BAND,MAG,CLASS,PLATE_ID", rows="-", option="plain", align=yes, sp_col=sp_col, >> logfile) } tdelete (tmp1, ver-, >& "dev$null") tselect (ltable, tmp1, "CEN_FLAG != 1") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { print ("\nAll sources were centered!", >> logfile) } else { print ("\n\nList of UNcentered sources:\n", >> logfile) tprint (tmp1, prparam=no, prdata=yes, pwidth=80, plength=0, showrow=yes, showhdr=yes, lgroup=0, columns="REGION,GSC_ID,X_PRED,Y_PRED,MAG_BAND,MAG,CLASS,PLATE_ID", rows="-", option="plain", align=yes, sp_col=sp_col, >> logfile) } tdelete (tmp1, ver-, >& "dev$null") } end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tpeak.key������������������������������������������������������0000664�0000000�0000000�00000013352�13321663143�0020351�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������ TPEAK Commands -------------- Cursor Keystroke Summary "good" = centered, "bad" = uncentered a All source toggle j Center from the current coords b Redisplay only bad sources k Center with one keystroke c Recenter good sources l Center with two keystrokes d Delete source(s) o Overlay the raw coordinates f Fit good sources, reposition bad r Redisplay good and bad sources g Redisplay only good sources u Undelete source(s) i Initialize to the raw coordinates q Exit the task ? Get this help Colon Command Summary autodisplay badcolor boxsize eparam goodcolor marker omarker replace rotate scale shift show subsample update Cursor Keystroke Commands a All source toggle for d/i/j/k/l/u keys. Entering `a' before one of these keystrokes will make the action apply either to all sources for d[elete] or u[ndelete], or to all currently uncentered (bad) sources for i[nitialize] and the three centering keys: `j', `k', or `l'. b Redisplay only the bad (uncentered) sources. c Recenter the list of sources with good (previously centered) positions. d Delete the source(s). (Mark as uncentered.) f Fit good source list, reposition uncentered sources to match. If ":update" is "yes", write the resulting world coordinate system (WCS) into the input image header. g Redisplay only the good (centered) sources. i Initialize the source(s) to their raw coordinates. j Center the source(s) at the current coordinates. k Center the source(s) shifted to the cursor, using one keystroke. l Center the source(s) shifted to the cursor, using two keystrokes. The `l' key allows an initial source selection keystroke for crowded fields (first 'l' selects source marker, second 'l' selects pixel coordinates). The `k' key selects and shifts using only one cursor position (nearest marker to pixel). The `j' key only uses the cursor position for selecting the source marker to be centered from the catalog coordinates. o Overlay the raw catalog coordinates using the omarker and the badcolor. q Exit the task. r Redisplay both the good and bad (centered and uncentered) sources. u Undelete the source(s). (Mark as centered - no further centering done.) ? Get this help. Colon Commands Issue a command with an argument of the specified type to set the corresponding value, or with no argument to print the current setting. Commands and arguments may be abbreviated. :autodisplay [y/n] Redisplay automatically after "all source" command? :boxsize [int] Centering box fullwidth :show [file] List plate, region and coordinate info [to a file] :subsample [int] Overlay subsampling factor for display only :badcolor [str] Color for bad (uncentered) positions :goodcolor [str] Color for good (centered) positions :marker [str] Marker for current positions :omarker [str] Marker for initial positions Colors: [black|white|red|green|blue|yellow] Markers: [point|circle|cross|plus|rectangle] The "f" keystroke will perform a plate solution using the current list of centered catalog sources. This plate solution will be used to calculate the celestial coordinates for the program object list, but can also optionally be used to update the world coordinate system (WCS) in the image header. The WCS information can be used by a variety of IRAF tasks. If ":update" is yes, the image header WCS will be updated following the next fit. If ":update" is no, the WCS will not be updated. :update [y/n] Update input image WCS after next fit? The catalog sources (not program objects) can be repositioned from the current coordinates by specifying a relative shift in each axis or a rotation or percent scaling factor(s) that will be applied to all catalog sources relative to the center of the frame. If only one argument is specified to :scale, both coordinates are rescaled by the same factor. Note that each time rotate, scale or shift is specified, the coordinates will be recomputed relative to the current coordinates, centered or not. These commands will often best be applied to the original predicted coordinates immediately after entering the task or after reinitializing the coordinates using the "a" and "i" keystrokes. No centering is performed following these commands, and the catalog sources will be marked as uncentered afterwards. :rotate [real] Angle relative to current coordinates :scale [x [y]] [real] Percent scale factor (can specify each axis) :shift [x y] [int] X,Y shifts relative to current coordinates Special circumstances may benefit from updating the original predicted coordinates provided by TFIELD. The :replace command will reset these coordinates to the current coordinates. This operation should not normally need to be performed. :replace Replace the predicted coords with the current coords Note that the "predicted" program object coordinates will be updated also. Various parameters from the various tasks called by TPEAK may be adjusted to tweak the behavior of the task: :eparam [task] Edit parameters for DISPLAY, IMCENTROID, SELECTPARS, TPLTSOL or TVMARK All the parameters of DISPLAY are adjustable (excluding the image name and frame number which are set by TPEAK) and most of the parameters of TVMARK are adjustable. This allows control over the appearance of the display. The IMCENTROID parameters can be tweaked to refine the centering algorithm and the TPLTSOL parameters to refine the interactive coordinate fitting algorithm. One useful technique is to set tvmark.outimage before redisplaying the good (and/or bad) sources for the last time (reset tvmark.outimage before exiting the task). This provides a snapshot of the overlayed sources suitable for hardcopy. ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tpeak.par������������������������������������������������������0000664�0000000�0000000�00000003142�13321663143�0020337�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������image,s,a,,,,"Image name" table,s,a,,,,"Table for initial and centered coords" database,s,a,,,,"Database file name for astrometric fit" objects,s,h,"",,,"List of program object X,Y coordinates" catpars,pset,h,"",,,"Catalog keyword description pset\n" ra_ref,s,h,"",,,"Plate center RA (hours)" dec_ref,s,h,"",,,"Plate center Dec (degrees)" eq_ref,r,h,INDEF,,,"Plate center coordinate equinox\n" update,b,h,no,,,"Update image header WCS following fit?" interactive,b,h,yes,,,"Enter interactive image cursor loop?" autocenter,b,h,no,,,"Center at the catalog coords when entering task?" autodisplay,b,h,yes,,,"Redisplay after all-source keystroke command?" fill,b,h,yes,,,"Fill display?\n" boxsize,i,h,9,1,,"Centering box fullwidth" rotate,r,h,0.,,,"Relative position angle of the field (CCW positive)" xscale,r,h,100,,,"Relative X scale factor, percent" yscale,r,h,100,,,"Relative Y scale factor, percent" xshift,i,h,0,,,"Relative X axis shift" yshift,i,h,0,,,"Relative Y axis shift\n" reselect,b,h,no,,,"Override any previously set subset flags?" subsample,i,h,1,1,,"Sampling factor, for display marking only" frame,i,h,1,1,4,"Display frame number" imcur,*imcur,h,"",,,"Image cursor\n" marker,s,h,"circle","point|circle|rectangle|plus|cross",,"Marker type" omarker,s,h,"plus","point|circle|rectangle|plus|cross",,"Overlay marker type" goodcolor,s,h,"blue","black|white|red|green|blue|yellow",,"Color of good marker" badcolor,s,h,"red","black|white|red|green|blue|yellow",,"Color of bad marker" objcolor,s,h,"green","black|white|red|green|blue|yellow",,"Color of program object marker\n" go_ahead,b,q,no,,,"(yes/no)" mode,s,h,"ql" ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tpltsol.cl�����������������������������������������������������0000664�0000000�0000000�00000027157�13321663143�0020564�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure tpltsol (image, table, database) string image {prompt="Input image name"} string table {prompt="Input table name"} string database {prompt="Output database name"} string results = "" {prompt="Results summary file\n"} bool append = no {prompt="Append to database and results file?"} bool imupdate = no {prompt="Update the image WCS?"} bool tabupdate = no {prompt="Update input table?"} bool refitcat = no {prompt="Recompute XYs for uncentered sources?"} bool verbose = yes {prompt="Print verbose progress messages?\n"} bool dssheader = yes {prompt="Read plate center from DSS header?"} string ra_ref = "" {prompt="Plate center RA (hours)"} string dec_ref = "" {prompt="Plate center Dec (degrees)"} real eq_ref = INDEF {prompt="Plate center coordinate equinox\n"} string inpixsys = "logical" {prompt="Input pixel system", enum="|logical|physical|"} string outpixsys = "logical" {prompt="Output pixel system", enum="|logical|physical|"} string insystem = "j2000" {prompt="Input celestial coordinate system\n"} string projection = "tan" {prompt="Sky projection geometry"} string fitgeometry = "general" {prompt="Fitting geometry", enum="|shift|xyscale|rotate|rscale|rxyscale|general"} string function = "polynomial" {prompt="Surface type\n", enum="|chebyshev|legendre|polynomial"} int xxorder = 2 {prompt="Order of xi fit in x", min=2} int xyorder = 2 {prompt="Order of xi fit in y", min=2} string xxterms = "half" {prompt="Xi fit cross terms type\n", enum="|none|half|full|"} int yxorder = 2 {prompt="Order of eta fit in x", min=2} int yyorder = 2 {prompt="Order of eta fit in y", min=2} string yxterms = "half" {prompt="Eta fit cross terms type?\n", enum="|none|half|full|"} real reject = INDEF {prompt="Rejection limit in sigma units\n"} bool interactive = yes {prompt="Fit the transformation interactively?"} string graphics = "stdgraph" {prompt="Default graphics device"} gcur cursor = "" {prompt="Graphics cursor"} pset catpars = "" {prompt="Catalog description pset\n"} string *list begin string a1=""#" string a2, a3, a4, a5, a6, a7, a8 string limage, ltable, ldatabase, lresults, decsign, solution, geom string tmp1, tmp2, tmp3, tmpresults, buf, lrewrite real rah, ram, ras, decd, decm, decs, ra, dec, pltequinox real xpred, ypred, xmin, xmax, ymin, ymax int rowno, index, nobj cache ("tinfo", "tabpar") tmp1 = mktemp ("tmp$tmp") tmp2 = mktemp ("tmp$tmp") tmp3 = mktemp ("tmp$tmp") tmpresults = mktemp ("tmp$tmp") limage = image ltable = table ldatabase = database lresults = results if (!append) { if (access(ldatabase)) { printf ("Output database %s exists", ldatabase) lrewrite = _qpars.rewrite if (lrewrite == "replace") { delete (ldatabase, ver-, >& "dev$null") } else if (lrewrite != "append") { printf ("\nChoose another filename and try again.\n") return } } if (access (lresults)) { printf ("Results file %s exists", lresults) lrewrite = _qpars.rewrite if (lrewrite == "replace") { delete (lresults, ver-, >& "dev$null") } else if (lrewrite != "append") { printf ("\nChoose another filename and try again.\n") return } } } if (lresults == "" && ! tabupdate) tmpresults = "" if (dssheader) { hselect (limage, "PLTRAH,PLTRAM,PLTRAS", yes) | scan (rah, ram, ras) ra = rah + ((ram + ras/60.0) / 60.0) hselect (limage, "PLTDECSN,PLTDECD,PLTDECM,PLTDECS", yes) | scan (decsign, decd, decm, decs) dec = decd + ((decm + decs/60.0) / 60.0) if (decsign == "-") dec = -dec hselect (limage, "EQUINOX", yes) | scan (pltequinox) } else { ra = real (ra_ref) dec = real (dec_ref) pltequinox = eq_ref } tcopy (ltable, tmp2, verbose-) tcalc (tmp2, "rowno", "rownum", datatype="int", colunits="", colfmt="%5d") buf = catpars.sub_col // " == 1 && " // catpars.cen_col // " == 1 && " // catpars.obj_col // " == 0" tselect (tmp2, tmp1, buf) tdelete (tmp2, ver-, >& "dev$null") tinfo (tmp1, ttout-) nobj = tinfo.nrows # This is the FINDER logic which is too restrictive. # if (nobj <= 0) { # printf ("No centered sources in input table\n") # return # } else if (nobj < 4 && fitgeometry != "shift") { # printf ("Too few sources, computing only shift\n") # geom = "shift" # } else if (nobj < 6 && fitgeometry == "general") { # printf ("Too few sources, computing only xyscale \n") # geom = "xyscale" # } else if (nobj <= 8 && fitgeometry == "general") { # printf ("Too few sources, computing only rxyscale\n") # geom = "rxyscale" # } else # geom = fitgeometry if (nobj < 3) { printf ("A minimum of 3 centered sources is required\n") return } else if (nobj < 6) geom = "rxyscale" else geom = fitgeometry tcalc (tmp1, "RA_HRS", "RA_DEG / 15.0d0", datatype="double", colunits="", colfmt="%13.4h") tchcol (tmp1, "X_CENTER", "", "%10.3f", "", verbose=no) tchcol (tmp1, "Y_CENTER", "", "%10.3f", "", verbose=no) tchcol (tmp1, "DEC_DEG", "", "%13.3h", "", verbose=no) #outpixsys = inpixsys if (inpixsys != outpixsys) { tprint (tmp1, columns="x_center,y_center,ra_hrs,dec_deg", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp3) xmin = 1 ymin = 1 hselect (limage, "NAXIS1,NAXIS2", yes) | scan (xmax, ymax) wcsctran (tmp3, tmp2, limage, inpixsys, outpixsys, columns="1 2", units="", formats="", min_sigdigit=9, verbose=no) hselect (limage, "NAXIS1,NAXIS2", yes) | scan (xmax, ymax) print (xmin, ymin) | wcsctran ("STDIN", "STDOUT", limage, inpixsys, outpixsys, columns="1,2", units="", formats="", min_sigdigit=9, verbose=no) | scan (xpred, ypred) print (xmax, ymax) | wcsctran ("STDIN", "STDOUT", limage, inpixsys, outpixsys, columns="1,2", units="", formats="", min_sigdigit=9, verbose=no) | scan (xmax, ymax) xmin = min (xpred, xmax) xmax = max (xpred, xmax) ymin = min (ypred, ymax) ymax = max (ypred, ymax) delete (tmp3, ver-, >& "dev$null") } else { tprint (tmp1, columns="x_center,y_center,ra_hrs,dec_deg", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp2) xmin = 1 ymin = 1 hselect (limage, "NAXIS1,NAXIS2", yes) | scan (xmax, ymax) } solution = "" hselect (image, "extname", yes) | scan (solution) if (solution == "") solution = limage ccmap (tmp2, ldatabase, solutions=solution, images=limage, results=tmpresults, xcolumn=1, ycolumn=2, lngcolumn=3, latcolumn=4, xmin=xmin, xmax=xmax, ymin=ymin, ymax=ymax, lngunits="hours", latunits="degrees", insystem=insystem, refpoint="user", lngref=ra, latref=dec, refsystem="equinox"//pltequinox, lngrefunits="hours", latrefunits="degrees", projection=projection, fitgeometry=geom, function=function, xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, yyorder=yyorder, yxterms=yxterms, reject=reject, update=imupdate, pixsystem=outpixsys, verbose=verbose, interactive=interactive, graphics=graphics, cursor=cursor) delete (tmp2, ver-, >& "dev$null") if (tabupdate) { printf (" \ntransferring deletions to the table...") index = 0 list = tmpresults while (fscan (list, a1, a2, a3, a4, a5, a6, a7, a8) != EOF) { if (nscan() != 8 || substr(a1,1,1) == "#") next index += 1 if (a5=="INDEF" && a6=="INDEF" && a7=="INDEF" && a8=="INDEF") { tabpar (tmp1, "rowno", index) partab (0, ltable, catpars.cen_col, int(tabpar.value)) } } list = "" tdelete (tmp1, ver-, >& "dev$null") printf ("done\n") if (refitcat) { tcopy (ltable, tmp1, verbose-) tcalc (tmp1, "rowno", "rownum", datatype="int", colunits="", colfmt="%5d") buf = catpars.cen_col // " == 0 && " // catpars.obj_col // " == 0" tselect (tmp1, tmp2, buf) tdelete (tmp1, ver-, >& "dev$null") tinfo (tmp2, ttout-) if (tinfo.nrows >= 1) { printf ("calculating coords for uncentered sources...") tcalc (tmp2, "RA_HRS", "RA_DEG / 15.0d0", datatype="double", colunits="", colfmt="%13.4h") # tchcol (tmp2, "X_CENTER", "", "%8.2f", "", verbose=no) # tchcol (tmp2, "Y_CENTER", "", "%8.2f", "", verbose=no) tchcol (tmp2, "DEC_DEG", "", "%13.3h", "", verbose=no) tprint (tmp2, columns="rowno,RA_HRS,DEC_DEG", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp1) tdelete (tmp2, ver-, >& "dev$null") if (inpixsys != outpixsys) { cctran (tmp1, tmp3, ldatabase, solution, geometry="geometric", forward=no, lngunits="hours", latunits="degrees", xcolumn=2, ycolumn=3, lngformat="%10.3f", latformat="%10.3f", min_sigdigit=9) wcsctran (tmp3, tmp2, limage, outpixsys, inpixsys, columns="2 3", units="", formats="", min_sigdigit=9, verbose=no) delete (tmp3, ver-, >& "dev$null") } else { cctran (tmp1, tmp2, ldatabase, solution, geometry="geometric", forward=no, lngunits="hours", latunits="degrees", xcolumn=2, ycolumn=3, lngformat="%10.3f", latformat="%10.3f", min_sigdigit=9) } delete (tmp1, ver-, >& "dev$null") printf ("done\n") printf ("transferring new predicted catalog coords to table...") list = tmp2 while (fscan (list, rowno, xpred, ypred) != EOF) { partab (xpred, ltable, "X_CENTER", rowno) partab (ypred, ltable, "Y_CENTER", rowno) } list = "" delete (tmp2, ver-, >& "dev$null") printf ("done\n") } else { tdelete (tmp1, ver-, >& "dev$null") } } else { tcopy (ltable, tmp1, verbose-) tcalc (tmp1, "rowno", "rownum", datatype="int", colunits="", colfmt="%5d") buf = catpars.obj_col // " == 1" tselect (tmp1, tmp2, buf) tdelete (tmp1, ver-, >& "dev$null") tinfo (tmp2, ttout-) if (tinfo.nrows >= 1) { printf ("calculating object coordinates...") tchcol (tmp2, "X_CENTER", "", "%10.3f", "", verbose=no) tchcol (tmp2, "Y_CENTER", "", "%10.3f", "", verbose=no) tprint (tmp2, columns="rowno,x_center,y_center", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp1) if (inpixsys != outpixsys) { tprint (tmp2, columns="rowno,x_center,y_center", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp3) wcsctran (tmp3, tmp2, limage, inpixsys, outpixsys, columns="2 3", units="", formats="", min_sigdigit=9, verbose=no) delete (tmp3, ver-, >& "dev$null") } else { tprint (tmp2, columns="rowno,x_center,y_center", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp1) } tdelete (tmp2, ver-, >& "dev$null") cctran (tmp1, tmp2, ldatabase, limage, geometry="geometric", forward+, xcolumn=2, ycolumn=3, lngformat="%13.4h", latformat="%13.3h", min_sigdigits=7) delete (tmp1, ver-, >& "dev$null") printf ("done\n") printf ("transferring object coordinates to table...") list = tmp2 while (fscan (list, rowno, ra, dec) != EOF) { ra = ra * 15. partab (ra, ltable, "RA_DEG", rowno) partab (dec, ltable, "DEC_DEG", rowno) } list = "" delete (tmp2, ver-, >& "dev$null") printf ("done\n") } else { tdelete (tmp2, ver-, >& "dev$null") } } } else { tdelete (tmp1, ver-, >& "dev$null") } if (lresults != "") rename (tmpresults, lresults, field="all") else delete (tmpresults, ver-, >& "dev$null") end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tpltsol.cl.DEBUG�����������������������������������������������0000664�0000000�0000000�00000021127�13321663143�0021400�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure tpltsol (image, table, database) string image {prompt="Input image name"} string table {prompt="Input table name"} string database {prompt="Output database name"} string results = "" {prompt="Results summary file\n"} bool imupdate = no {prompt="Update the image WCS?"} bool tabupdate = no {prompt="Update input table?"} bool refitcat = no {prompt="Recompute XYs for uncentered sources?"} bool verbose = yes {prompt="Print verbose progress messages?\n"} bool dssheader = yes {prompt="Read plate center from DSS header?"} string ra_ref = "" {prompt="Plate center RA (hours)"} string dec_ref = "" {prompt="Plate center Dec (degrees)"} real eq_ref = INDEF {prompt="Plate center coordinate equinox\n"} string insystem = "j2000" {prompt="Input celestial coordinate system\n"} string projection = "tan" {prompt="Sky projection geometry", enum="|lin|tan|sin|arc"} string fitgeometry = "general" {prompt="Fitting geometry", enum="|shift|xyscale|rotate|rscale|rxyscale|general"} string function = "polynomial" {prompt="Surface type\n", enum="|chebyshev|legendre|polynomial"} int xxorder = 2 {prompt="Order of xi fit in x", min=2} int xyorder = 2 {prompt="Order of xi fit in y", min=2} bool xxterms = no {prompt="Include cross-terms in xi fit?\n"} int yxorder = 2 {prompt="Order of eta fit in x", min=2} int yyorder = 2 {prompt="Order of eta fit in y", min=2} bool yxterms = no {prompt="Include cross-terms in eta fit?\n"} real reject = INDEF {prompt="Rejection limit in sigma units\n"} bool interactive = yes {prompt="Fit the transformation interactively?"} string graphics = "stdgraph" {prompt="Default graphics device"} gcur cursor = "" {prompt="Graphics cursor"} pset catpars = "" {prompt="Catalog description pset\n"} string *list begin string a1=""#" string a2, a3, a4, a5, a6, a7, a8 string limage, ltable, ldatabase, lresults, decsign string tmp1, tmp2, tmpresults, buf, lrewrite real rah, ram, ras, decd, decm, decs, ra, dec, pltequinox real xpred, ypred int xsize, ysize, rowno, index cache ("tinfo", "tabpar") tmp1 = mktemp ("tmp$tmp") tmp2 = mktemp ("tmp$tmp") tmpresults = mktemp ("tmp$tmp") limage = image ltable = table ldatabase = database lresults = results if (access(ldatabase)) { printf ("Output database %s exists", ldatabase) lrewrite = _qpars.rewrite if (lrewrite == "replace") { delete (ldatabase, ver-, >& "dev$null") } else if (lrewrite != "append") { printf ("\nChoose another filename and try again.\n") return } } if (access (lresults)) { printf ("Results file %s exists", lresults) lrewrite = _qpars.rewrite if (lrewrite == "replace") { delete (lresults, ver-, >& "dev$null") } else if (lrewrite != "append") { printf ("\nChoose another filename and try again.\n") return } } if (lresults == "" && ! tabupdate) tmpresults = "" hselect (limage, "NAXIS1,NAXIS2", yes) | scan (xsize, ysize) if (dssheader) { hselect (limage, "PLTRAH,PLTRAM,PLTRAS", yes) | scan (rah, ram, ras) ra = rah + ((ram + int(ras)/60.0) / 60.0) hselect (limage, "PLTDECSN,PLTDECD,PLTDECM,PLTDECS", yes) | scan (decsign, decd, decm, decs) dec = decd + ((decm + int(decs)/60.0) / 60.0) if (decsign == "-") dec = -dec hselect (limage, "EQUINOX", yes) | scan (pltequinox) } else { # ra = real (ra_ref) # dec = real (dec_ref) printf ("%13.1h\n", real(ra_ref)) | scan (ra) printf ("%13.0h\n", real(dec_ref)) | scan (dec) pltequinox = eq_ref } tcopy (ltable, tmp2, verbose-) tcalc (tmp2, "rowno", "rownum", datatype="int", colunits="", colfmt="%5d") buf = catpars.sub_col // " == 1 && " // catpars.cen_col // " == 1 && " // catpars.obj_col // " == 0" tselect (tmp2, tmp1, buf) tdelete (tmp2, ver-, >& "dev$null") tinfo (tmp1, ttout-) if (tinfo.nrows <= 0) { printf ("No centered sources in input table\n") return } tcalc (tmp1, "RA_HRS", "RA_DEG / 15.", datatype="real", colunits="", colfmt="%13.3h") tchcol (tmp1, "X_CENTER", "", "%8.2f", "", verbose=no) tchcol (tmp1, "Y_CENTER", "", "%8.2f", "", verbose=no) tchcol (tmp1, "DEC_DEG", "", "%12.2h", "", verbose=no) tprint (tmp1, columns="x_center,y_center,ra_hrs,dec_deg", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp2) #copy (tmp2, "tpltsol.coords") ccmap (tmp2, ldatabase, images=limage, results=tmpresults, xcolumn=1, ycolumn=2, lngcolumn=3, latcolumn=4, xmin=1.0, xmax=xsize, ymin=1.0, ymax=ysize, lngunits="hours", latunits="degrees", insystem=insystem, refpoint="user", lngref=ra, latref=dec, refsystem="equinox "//pltequinox, lngrefunits="hours", latrefunits="degrees", projection=projection, fitgeometry=fitgeometry, function=function, xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, yyorder=yyorder, yxterms=yxterms, reject=reject, update=imupdate, verbose=verbose, interactive=interactive, graphics=graphics, cursor=cursor) delete (tmp2, ver-, >& "dev$null") if (tabupdate) { printf (" \ntransferring deletions to the table...") index = 0 list = tmpresults while (fscan (list, a1, a2, a3, a4, a5, a6, a7, a8) != EOF) { if (nscan() != 8 || substr(a1,1,1) == "#") next index += 1 if (a5=="INDEF" && a6=="INDEF" && a7=="INDEF" && a8=="INDEF") { tabpar (tmp1, "rowno", index) partab (0, ltable, catpars.cen_col, int(tabpar.value)) } } list = "" tdelete (tmp1, ver-, >& "dev$null") printf ("done\n") if (refitcat) { tcopy (ltable, tmp1, verbose-) tcalc (tmp1, "rowno", "rownum", datatype="int", colunits="", colfmt="%5d") buf = catpars.cen_col // " == 0 && " // catpars.obj_col // " == 0" tselect (tmp1, tmp2, buf) tdelete (tmp1, ver-, >& "dev$null") tinfo (tmp2, ttout-) if (tinfo.nrows >= 1) { printf ("calculating coords for uncentered sources...") tcalc (tmp2, "RA_HRS", "RA_DEG / 15.", datatype="real", colunits="", colfmt="%13.3h") # tchcol (tmp2, "X_CENTER", "", "%8.2f", "", verbose=no) # tchcol (tmp2, "Y_CENTER", "", "%8.2f", "", verbose=no) tchcol (tmp2, "DEC_DEG", "", "%12.2h", "", verbose=no) tprint (tmp2, columns="rowno,RA_HRS,DEC_DEG", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp1) tdelete (tmp2, ver-, >& "dev$null") cctran (tmp1, tmp2, ldatabase, limage, geometry="geometric", forward-, xcolumn=2, ycolumn=3, lngformat="%10.3f", latformat="%10.3f", min_sigdigits=7) delete (tmp1, ver-, >& "dev$null") printf ("done\n") printf ("transferring new predicted catalog coords to table...") list = tmp2 while (fscan (list, rowno, xpred, ypred) != EOF) { partab (xpred, ltable, "X_CENTER", rowno) partab (ypred, ltable, "Y_CENTER", rowno) } list = "" delete (tmp2, ver-, >& "dev$null") printf ("done\n") } else { tdelete (tmp1, ver-, >& "dev$null") } } else { tcopy (ltable, tmp1, verbose-) tcalc (tmp1, "rowno", "rownum", datatype="int", colunits="", colfmt="%5d") buf = catpars.obj_col // " == 1" tselect (tmp1, tmp2, buf) tdelete (tmp1, ver-, >& "dev$null") tinfo (tmp2, ttout-) if (tinfo.nrows >= 1) { printf ("calculating object coordinates...") tchcol (tmp2, "X_CENTER", "", "%8.2f", "", verbose=no) tchcol (tmp2, "Y_CENTER", "", "%8.2f", "", verbose=no) tprint (tmp2, columns="rowno,x_center,y_center", prparam-, prdata+, pwidth=80, plength=0, showrow-, showhdr-, rows="-", option="plain", sp_col="", lgroup=0, > tmp1) tdelete (tmp2, ver-, >& "dev$null") cctran (tmp1, tmp2, ldatabase, limage, geometry="geometric", forward+, xcolumn=2, ycolumn=3, lngformat="%11.1h", latformat="%11.1h", min_sigdigits=7) delete (tmp1, ver-, >& "dev$null") printf ("done\n") printf ("transferring object coordinates to table...") list = tmp2 while (fscan (list, rowno, ra, dec) != EOF) { ra = ra * 15. partab (ra, ltable, "RA_DEG", rowno) partab (dec, ltable, "DEC_DEG", rowno) } list = "" delete (tmp2, ver-, >& "dev$null") printf ("done\n") } else { tdelete (tmp1, ver-, >& "dev$null") } } } else { tdelete (tmp1, ver-, >& "dev$null") } if (lresults != "") rename (tmpresults, lresults, field="all") else delete (tmpresults, ver-, >& "dev$null") end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tvmark_.cl�����������������������������������������������������0000664�0000000�0000000�00000000517�13321663143�0020515�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������sleep (1) if (access (coords) == YES) tv.tvmark (frame=frame, coords=coords, mark=mark, radii=radii, lengths=lengths, color=color, label=label, number=number, pointsize=pointsize, txsize=txsize, nxoffset=0, nyoffset=0, logfile="", autolog-, outimage="", deletions="", commands="", font="raster", tolerance=1.5, interactive-) ; ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/tvmark_.par����������������������������������������������������0000664�0000000�0000000�00000001057�13321663143�0020701�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# TVMARK front end frame,i,a,1,,,Default frame number for display coords,f,a,,,,Input coordinate list mark,s,h,"point","point|circle|rectangle|line|plus|cross|none",,The mark type color,i,h,255,,,Gray level of marks to be drawn radii,s,h,"10",,,Radii in image pixels of concentric circles lengths,s,h,"0",,,Lengths and width in image pixels of concentric rectangles label,b,h,no,,,Label the marked coordinates number,b,h,no,,,Number the marked coordinates pointsize,i,h,3,,,Size of dot in display pixels txsize,i,h,4,,,Size of text and numbers in font units ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfinder/x_finder.x�����������������������������������������������������0000664�0000000�0000000�00000000025�13321663143�0020513�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������task tpeak = t_tpeak �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscfindgain.cl�����������������������������������������������������������0000664�0000000�0000000�00000010365�13321663143�0017364�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCFINDGAIN - calculate the gain and readnoise given two flats and two # bias frames. Algorithm (method of Janesick) courtesy Phil Massey. # # flatdif = flat1 - flat2 # biasdif = bias1 - bias2 # # e_per_adu = ((mean(flat1)+mean(flat2)) - (mean(bias1)+mean(bias2))) / # ((rms(flatdif))**2 - (rms(biasdif))**2) # # readnoise = e_per_adu * rms(biasdif) / sqrt(2) # # In our implementation, `mean' may actually be any of `mean', # `midpt', or `mode' as in the IMSTATISTICS task. procedure mscfindgain (flat1, flat2, zero1, zero2) string flat1 {prompt="First flat frame"} string flat2 {prompt="Second flat frame"} string zero1 {prompt="First zero frame"} string zero2 {prompt="Second zero frame"} string extname = "" {prompt="Select extension names"} string mask = "BPM" {prompt="Bad pixel mask"} string section = "" {prompt="Selected image section"} string center = "mean" {prompt="Central statistical measure", enum="mean|midpt|mode"} int nclip = 3 {prompt="Number of clipping iterations"} real lclip = 4 {prompt="Lower clipping sigma factor"} real uclip = 4 {prompt="Upper clipping sigma factor"} real binwidth = 0.1 {prompt="Bin width of histogram in sigma"} bool verbose = yes {prompt="Verbose output?"} string *fd1, *fd2 begin bool first, err file f1, f2, z1, z2, lf1, lf2, lz1, lz2 file f1list, flatdiff, zerodiff, statsfile real e_per_adu, readnoise, m_f1, m_f2, m_b1, m_b2, s_fd, s_bd, junk struct images,ext # Temporary files. f1list = mktemp ("tmp$iraf") flatdif = mktemp ("tmp$iraf") zerodif = mktemp ("tmp$iraf") statsfile = mktemp ("tmp$iraf") # Query parameters. f1 = flat1 f2 = flat2 z1 = zero1 z2 = zero2 # Expand first flat as the reference. mscextensions (f1, output="file", index="", extname=extname, extver="", lindex=no, lname=yes, lver=no, ikparams="", > f1list) first = YES # For each f1 get the extension for all the other images. fd1 = f1list while (fscan (fd1, f1) != EOF) { hselect (f1, "extname", yes) | scan (ext) ext = "[" // ext // "]" lf1 = f1 // section lf2 = f2 // ext // section lz1 = z1 // ext // section lz2 = z2 // ext // section imarith (lf1, "-", lf2, flatdif) imarith (lz1, "-", lz2, zerodif) printf ("%s,%s,%s,%s,%s,%s\n", lf1, lf2, lz1, lz2, flatdif, zerodif) | scan (images) ximstat (images, mask="^"//mask, fields=center//",stddev", lower=INDEF, upper=INDEF, nclip=nclip, lclip=lclip, uclip=uclip, binwidth=binwidth, format-, > statsfile) imdelete (flatdif, verify-) imdelete (zerodif, verify-) fd2 = statsfile err = NO if (fscan (fd2, m_f1, junk) != 2) { printf ("WARNING: Failed to compute statisics for %s\n", lf1) err = YES } if (fscan (fd2, m_f2, junk) != 2) { printf ("WARNING: Failed to compute statisics for %s\n", lf2) err = YES } if (fscan (fd2, m_b1, junk) != 2) { printf ("WARNING: Failed to compute statisics for %s\n", lz1) err = YES } if (fscan (fd2, m_b2, junk) != 2) { printf ("WARNING: Failed to compute statisics for %s\n", lz1) err = YES } if (fscan (fd2, junk, s_fd) != 2) { printf ("WARNING: Failed to compute statisics for %s - %s\n", lf1, lf2) err = YES } if (fscan (fd2, junk, s_bd) != 2) { printf ("WARNING: Failed to compute statisics for %s - %s\n", lz1, lz2) err = YES } fd2 = ""; delete (statsfile, verify-) if (err == YES) next e_per_adu = ((m_f1 + m_f2) - (m_b1 + m_b2)) / (s_fd**2 - s_bd**2) readnoise = e_per_adu * s_bd / sqrt(2) # round to three decimal places e_per_adu = real (nint (e_per_adu * 1000.)) / 1000. readnoise = real (nint (readnoise * 1000.)) / 1000. # print results if (verbose) { if (first) { printf ("MSCFINDGAIN:\n") printf (" mask = %s, center = %s, binwidth = %g\n", mask, center, binwidth) printf (" nclip = %d, lclip = %g, uclip = %g\n", nclip, lclip, uclip) first = NO } printf ("\n Flats = %s & %s\n", lf1, lf2) printf (" Zeros = %s & %s\n", lz1, lz2) printf (" Gain = %5.2f electrons per ADU\n", e_per_adu) printf (" Read noise = %5.2f electrons\n", readnoise) } else printf ("%s\t%5.2f\t%5.2f\n", ext, e_per_adu, readnoise) } fd1 = ""; delete (f1list, verify-) end ���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscgetcatalog.cl���������������������������������������������������������0000664�0000000�0000000�00000001352�13321663143�0017713�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCGETCATALOG -- Get catalog stars. procedure mscgetcatalog (input, output) string input {prompt="List of Mosaic files"} file output {prompt="Output file of sources"} real magmin = 0. {prompt="Minimum magnitude"} real magmax = 25. {prompt="Maximum magnitude"} string catalog="usnob1@noao" {prompt="Catalog"} real rmin = 21. {prompt="Minimum radius (arcmin)"} begin file inlist inlist = mktemp ("tmp$iraf") mscextensions (input, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, dataless=no, ikparams="", > inlist) getcatalog ("@"//inlist, output=output, catalog=catalog, magmin=magmin, magmax=magmax, rmin=rmin, radecsys="FK5", equinox=2000.) delete (inlist, verify=no) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscgmask.par�������������������������������������������������������������0000664�0000000�0000000�00000000236�13321663143�0017067�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,List of input images output,s,a,,,,List of output masks masks,s,a,,,,List of parent masks mval,i,h,1,1,,Mask value empty,b,h,,,,All masks empty? ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscheader.cl�������������������������������������������������������������0000664�0000000�0000000�00000001127�13321663143�0017031�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCHEADER -- Image header listing for multiextension files. procedure mcsheader (images) string images {prompt="images names"} bool longheader = yes {prompt="print header full header?"} bool ghdr = no {prompt="print global header separately?"} string extnames = "" {prompt="extension names"} begin struct cmd printf ('"imheader $input long=%b"\n', longheader) | scan (cmd) if (ghdr) msccmd (cmd, images, extname=extnames, dataless=yes, ikparams="noinherit", verbose=no) else msccmd (cmd, images, extname=extnames, dataless=no, ikparams="", verbose=no) end �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscimage.cl��������������������������������������������������������������0000664�0000000�0000000�00000030204�13321663143�0016661�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure mscimage begin file in, out, ref, pl, image, trimsec, outsec, plsec file inlists, extlist, pllist, coord, db, wcsref, outtemp, pltemp int nc, nl, ncref, nlref int cmin, cmax, lmin, lmax, nimage, nimages, nxblk, nyblk real x, y, rval, xmin, xmax, ymin, ymax, crpix1, crpix2 string extname, str cache mscextensions, mscgmask # Temporary files. inlists = mktemp ("tmp$iraf") extlist = mktemp ("tmp$iraf") pllist = mktemp ("tmp$iraf") coord = mktemp ("tmp$iraf") db = mktemp ("tmp$iraf") # Temporary images. outtemp = mktemp ("tmp") wcsref = mktemp ("tmp") pltemp = mktemp ("tmp") # Expand input MEF lists. joinlists (input, output, output=inlists, delim=" ", short+, type="image") # Process each input MEF file. fd_in = inlists while (fscan (fd_in, in, out) != EOF) { # Check for an existing output image. if (imaccess (out)) { printf ("Warning: Image already exists (%s)\n", out) next } # Set output pl file rootname. if (pixmask) { pl = out nc = strlen (pl) if (nc > 5 && substr (pl, nc-4, nc) == ".fits") pl = substr (pl, 1, nc-5) else if (nc > 4 && substr (out, nc-3, nc) == ".imh") pl = substr (pl, 1, nc-4) pl = pl // "_bpm" if (format == "image" && imaccess (pl)) { printf ("Warning: Mask already exists (%s)\n", pl) next } } else pl = "" # Expand extensions and check for data. mscextensions (in, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) nimages = mscextensions.nimages nimage = 0 if (nimages < 1) { printf ("WARNING: No input image data found in `%s'.\n", in) delete (extlist, verify=no) next } # Set WCS image or create template. if (!imaccess(wcsref)) { ref = reference if (wcssource == "match") wcsref = ref else mscwtemplate ("@"//extlist, wcsref, wcssource=wcssource, reference=ref, ra=ra, dec=dec, scale=scale, rotation=rotation, projection="",verbose=verbose) } # Create output mosaic. fd_ext = extlist while (fscan (fd_ext, image) != EOF) { nimage = nimage + 1 # Set output MEF format. if (nimages > 1) { hselect (image, "extname", yes) | scan (extname) if (nscan() == 0) extname = "im"+nimage printf ("%s[%s,append]\n", outtemp, extname) | scan (outsec) printf ("%s%s\n", pl, extname) | scan (plsec) } else { extname = "" outsec = outtemp plsec = pl } # Check for existing pixel mask before we actually do anything. if (pixmask && imaccess (plsec)) { delete (coord, verify=no) delete (db, verify=no) printf ("Warning: Mask already exists (%s)\n", plsec) next } if (verbose) printf ("Resampling %s ...\n", image) # Trim data. hselect (image, "naxis1,naxis2", yes) | scan (nc, nl) cmin = 1+ntrim; cmax = nc-ntrim lmin = 1+ntrim; lmax = nl-ntrim printf ("[%d:%d,%d:%d]\n", cmin, cmax, lmin, lmax) | scan (trimsec) # Determine grid points and mapping into the output. if (wcssource == "match") { hselect (ref, "naxis1,naxis2", yes) | scan (ncref, nlref) xmin = (ncref - 1.) / (nx - 1.) ymin = (nlref - 1.) / (ny - 1.) for (ymax=1; ymax<=nlref+1; ymax=ymax+ymin) for (xmax=1; xmax<=ncref+1; xmax=xmax+xmin) print (xmax, ymax, xmax, ymax, >> coord) mscctran (coord, db, ref, "logical", "world", columns="3 4", units="", formats="%.4H %.3h", min_sigdigit=10, verbose=no) delete (coord, verify-) wcsctran (db, coord, image//trimsec, inwcs="world", outwcs="logical", columns="3 4", units="hours native", formats="", min_sigdigit=10, verbose=no) delete (db, verify-) } else { nc = cmax - cmin + 1 nl = lmax - lmin + 1 xmin = (nc - 1.) / (nx - 1.) ymin = (nl - 1.) / (ny - 1.) for (ymax=1; ymax<=nl+1; ymax=ymax+ymin) for (xmax=1; xmax<=nc+1; xmax=xmax+xmin) print (xmax, ymax, xmax, ymax, >> coord) mscctran (coord, db, image//trimsec, "logical", "world", columns="1 2", units="", formats="%.4H %.3h", min_sigdigit=10, verbose=no) delete (coord, verify-) wcsctran (db, coord, wcsref, inwcs="world", outwcs="logical", columns="1 2", units="hours native", formats="", min_sigdigit=10, verbose=no) delete (db, verify-) } # Determine the output limits. xmax = 0.; xmin = 1.; ymax = 0.; ymin = 1. fd_coord = coord while (fscan (fd_coord, x, y) != EOF) { if (nscan() < 2) next if (xmax < xmin) { xmin = x; xmax = x; ymin = y; ymax = y } else { xmin = min (x, xmin); xmax = max (x, xmax) ymin = min (y, ymin); ymax = max (y, ymax) } } fd_coord = "" if (xmax <= xmin || ymax <= ymin) error (1, "No overlap for matching reference") cmin = nint (xmin - 1.5) cmax = nint (xmax + 1.5) lmin = nint (ymin - 1.5) lmax = nint (ymax + 1.5) # Compute transformation. geomap (coord, db, cmin, cmax, lmin, lmax, transforms="", results="", fitgeometry=fitgeometry, function="chebyshev", xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, yyorder=yyorder, yxterms=yxterms, reject=INDEF, calctype="double", verbose=no, interactive=interactive, graphics="stdgraph", cursor="") # Match reference image size. if (wcssource == "match") { cmin = 1; lmin = 1 cmax = ncref; lmax = nlref } # Transform extension into output. if (nxblock == INDEF) nxblk = cmax - cmin + 3 else nxblk = nxblock if (nyblock == INDEF) nyblk = lmax - lmin + 3 else nyblk = nyblock geotran (image//trimsec, outsec, db, coord, geometry="geometric", xin=INDEF, yin=INDEF, xshift=INDEF, yshift=INDEF, xout=INDEF, yout=INDEF, xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF, xmin=cmin, xmax=cmax, ymin=lmin, ymax=lmax, xsample=10., ysample=10., xscale=1., yscale=1., ncols=INDEF, nlines=INDEF, interpolant=interpolant, boundary="constant", constant=constant, fluxconserve=fluxconserve, nxblock=nxblk, nyblock=nyblk, verbose=no) # Set WCS. wcscopy (outsec, wcsref, verbose-) xmin = 0.; ymin = 0. hselect (outsec, "crpix1,crpix2", yes) | scan (xmin, ymin) xmin = xmin - cmin + 1 ymin = ymin - lmin + 1 if (nimage == 1) { crpix1 = xmin crpix2 = ymin } else { crpix1 = max (crpix1, xmin) crpix2 = max (crpix2, ymin) } hedit (outsec, "crpix1", xmin, add+, verify-, show-, update+) hedit (outsec, "crpix2", ymin, add+, verify-, show-, update+) # Set output mask. if (pixmask) { printf ("%s%s\n", pl, extname) | scan (plsec) mscgmask (image//trimsec, pltemp//".pl", "BPM", mval=10000) geotran (pltemp, plsec//".fits", db, coord, geometry="geometric", xin=INDEF, yin=INDEF, xshift=INDEF, yshift=INDEF, xout=INDEF, yout=INDEF, xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF, xmin=cmin, xmax=cmax, ymin=lmin, ymax=lmax, xsample=10., ysample=10., interpolant=minterpolant, boundary="constant", constant=20000., fluxconserve=no, nxblock=nxblk, nyblock=nyblk, verbose=no) imdelete (pltemp, verify-) # Convert values to mask with 1=bad pixel, 2=out of bounds. # imexpr ("abs(a) < 1 ? 0 : int (abs(a) / 10010 + 1)", # plsec//".pl", plsec//".fits", dims="auto", # intype="auto", outtype="int", refim="auto", # rangecheck=no, verbose=no) mscpmask (plsec//".fits", plsec//".pl") imdelete (plsec//".fits", verify-) # Set WCS of mask and enter mask name in output image. hedit (outsec, "BPM", plsec//".pl", add+, show-, verify-, update+) wcscopy (plsec, outsec, verbose-) print (plsec, >> pllist) } else hedit (outsec, "BPM", del+, add-, addonly-, show-, verify-, update+) delete (coord, verify=no) delete (db, verify=no) } fd_ext = ""; delete (extlist, verify=no) # Create the final output. if (nimages > 1 && format == "image") { # Stack multiple pieces into a single image. if (verbose) printf ("Creating image %s ...\n", out) mscextensions (outtemp, output="file", index="", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) # Make masks. if (pixmask) { combine ("@"//pllist, pltemp//".pl", headers="", bpmasks=pl, rejmasks="", nrejmasks="", expmasks="", sigmas="", imcmb="", ccdtype="", amps=no, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="wcs", masktype="none", maskvalue="0", blank=0., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=0.99, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., > "dev$null") imdelete (pltemp, verify-) combine ("@"//extlist, out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigmas="", imcmb="", ccdtype="", amps=no, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="wcs", masktype="badvalue", maskvalue="2", blank=0., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., > "dev$null") hedit (out, "BPM", pl, add+, verify-, show-, update+) hedit (pl, "IMCMB???,PROCID??", add-, addonly-, del+, update+, verify-, show-) } else { combine ("@"//extlist, out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigmas="", imcmb="", ccdtype="", amps=no, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="wcs", masktype="none", maskvalue="2", blank=0., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., > "dev$null") } # Fix up header. hselect ("@"//extlist, "gain", yes) | average (data_value=0.) | scan (rval) hedit (out, "gain", rval, add+, del-, update+, verify-, show-) hselect ("@"//extlist, "rdnoise", yes) | average (data_value=0.) | scan (rval) hedit (out, "rdnoise", rval, add+, del-, update+, verify-, show-) hedit (out, "IMCMB???,PROCID??", add-, addonly-, del+, update+, verify-, show-) hedit (out, "NEXTEND,DETSEC,CCDSEC,AMPSEC,IMAGEID,DATASEC,TRIMSEC,BIASSEC", add-, addonly-, del+, update+, verify-, show-) imdelete (outtemp, verify-) if (access (pllist)) { imdelete ("@"//pllist, verify-) delete (pllist, verify-) } delete (extlist, verify=no) } else if (nimages > 1) { # Set MEF output. imrename (outtemp, out, verbose-) mscextensions (out, output="file", index="", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) fd_ext = extlist while (fscan (fd_ext, image) != EOF) { hselect (image, "naxis1,naxis2,crpix1,crpix2", yes) | scan (nc, nl, xmin, ymin) cmin = nint (crpix1 - xmin + 1) lmin = nint (crpix2 - ymin + 1) cmax = nc + cmin - 1 lmax = nl + lmin - 1 printf ("[%d:%d,%d:%d]\n", cmin, cmax, lmin, lmax) | scan (str) hedit (image, "DETSEC", str, add+, verify-, show-, update+) hedit (image, "DTM1_1", 1., add+, verify-, show-, update+) hedit (image, "DTM2_2", 1., add+, verify-, show-, update+) cmin = cmin - 1 lmin = lmin - 1 hedit (image, "DTV1", cmin, add+, verify-, show-, update+) hedit (image, "DTV2", lmin, add+, verify-, show-, update+) hedit (image, "CCDSUM,CCDSEC,AMPSEC,ATM1_1,ATM2_2,ATV1,ATV2", del+, add-, addonly-, verify-, show-, update+) } fd_ext = ""; delete (extlist, verify-) } else { # If just a single input image produce a single output. imrename (outsec, out, verbose-) } if (access (pllist)) delete (pllist, verify-) } fd_in = ""; delete (inlists, verify=no) # Delete all remaining temporary files. if (wcssource != "match" && imaccess(wcsref)) imdelete (wcsref, verify-) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscimage.par�������������������������������������������������������������0000664�0000000�0000000�00000003236�13321663143�0017052�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,"List of input mosaic exposures" output,s,a,,,,"List of output images" format,s,h,"image","|image|mef|",,"Output format (image|mef)" pixmask,b,h,yes,,,"Create pixel mask?" verbose,b,h,)_.verbose,,,"Verbose output? # Output WCS parameters" wcssource,s,h,"image","|image|parameters|match|",,"Output WCS source (image|parameters|match)" reference,f,h,"",,,"Reference image" ra,r,h,INDEF,0,24,"RA of tangent point (hours)" dec,r,h,INDEF,-90,90,"DEC of tangent point (degrees)" scale,r,h,INDEF,,,"Scale (arcsec/pixel)" rotation,r,h,INDEF,-360,360,"Rotation of DEC from N to E (degrees) # Resampling parmeters" blank,r,h,0,,,Blank value interpolant,s,h,"linear",,,"Interpolant for data" minterpolant,s,h,"linear",,,"Interpolant for mask" boundary,s,h,"reflect","nearest|constant|reflect|wrap",,"Boundary extension" constant,r,h,0,,,"Constant boundary extension value" fluxconserve,b,h,no,,,"Preserve flux per unit area?" ntrim,i,h,8,0,,"Edge trim in each extension" nxblock,i,h,INDEF,,,"X dimension of working block size in pixels" nyblock,i,h,INDEF,,,"Y dimension of working block size in pixels # Geometric mapping parameters" interactive,b,h,no,,,"Fit mapping interactively?" nx,i,h,10,,,"Number of x grid points" ny,i,h,20,,,"Number of y grid points" fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general,,"Fitting geometry" xxorder,i,h,4,2,,"Order of x fit in x" xyorder,i,h,4,2,,"Order of x fit in y" xxterms,s,h,"half",,,"X fit cross terms type" yxorder,i,h,4,2,,"Order of y fit in x" yyorder,i,h,4,2,,"Order of y fit in y" yxterms,s,h,"half",,,"Y fit cross terms type " fd_in,*struct,h,"",,, fd_ext,*struct,h,"",,, fd_coord,*struct,h,"",,, mode,s,h,"ql",,, ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscimatch.cl�������������������������������������������������������������0000664�0000000�0000000�00000016314�13321663143�0017052�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure mscimatch (input, coords) string input {prompt="List of input images"} file coords {prompt="Coordinates"} file reference {prompt="Reference image"} int box1 = 21 {prompt="Box size for statistics"} int box2 = 51 {prompt="Box size for statistics"} real lower = 1. {prompt="Lower limit for good data"} real upper = INDEF {prompt="Upper limit for good data"} bool update = yes {prompt="Update images?"} bool interactive = yes {prompt="Interactive?"} bool fit = yes {prompt="Fit interactively?"} bool verbose = yes {prompt="Verbose?"} bool accept = yes {prompt="Accept scaling?", mode="q"} struct *fd1, *fd2 begin file images, refstats, fitstats, results, temp file ref, in, coord, refpix, inpix string image int nc, nl, x1, x2, y1, y2, nbox1, nbox2, npix, nstat, nfit real ra, dec, xc, yc, refstat1, refstat2, instat1, instat2, sky real msczero, mscscale, dsky bool ifit images = mktemp ("tmp$iraf") refstats = mktemp ("tmp$iraf") fitstats = mktemp ("tmp$iraf") results = mktemp ("tmp$iraf") temp = mktemp ("tmp$iraf") # Expand the input list. sections (input, option="fullname", > images) # Set the reference image. fd1 = images if (fscan (fd1, ref) == EOF) error (1, "No input images") if (fscan (reference, ref) == 0) ; # Set the coordinate file. if (fscan (coords, coord) == 0) error (1, "No coordinate file") fd2 = coord if (verbose) { printf ("MSCIMATCH:\n") printf (" Using %s as the reference image\n", ref) printf (" Computing statistics for %s...\n", ref) } # Measure the reference image. nbox1 = box1 * box1 nbox2 = box2 * box2 sky = INDEF hselect (ref, "naxis1,naxis2,pixfile", yes) | scan (nc, nl, refpix) while (fscan (fd2, ra, dec) != EOF) { print (ra, dec) | mscctran ("STDIN", "STDOUT", ref, "world", "logical", col="1 2", units="hours native", formats="", min_sig=9, verbose=no) | scan (xc, yc) x1 = nint (xc - box1 / 2) x2 = x1 + box1 - 1 y1 = nint (yc - box1 / 2) y2 = y1 + box1 - 1 if (x1 < 1 || x2 > nc || y1 < 1 || y2 > nl) next printf ("%s[%d:%d,%d:%d]\n", ref, x1, x2, y1, y2) | scan (image) imstat (image, fields="npix,mean", lower=lower, upper=upper, binwidth=0.1, format=no) | scan (npix, refstat1) if (npix != nbox1 || refstat1 == INDEF) next if (sky == INDEF) sky = refstat1 else sky = min (refstat1, sky) if (box2 <= box1) { print (ra, dec, refstat1, >> refstats) next } x1 = nint (xc - box2 / 2) x2 = x1 + box2 - 1 y1 = nint (yc - box2 / 2) y2 = y1 + box2 - 1 if (x1 < 1 || x2 > nc || y1 < 1 || y2 > nl) { print (ra, dec, refstat1, >> refstats) next } printf ("%s[%d:%d,%d:%d]\n", ref, x1, x2, y1, y2) | scan (image) imstat (image, fields="npix,mean", lower=lower, upper=upper, binwidth=0.1, format=no) | scan (npix, refstat2) if (npix != nbox2 || refstat2 == INDEF) { print (ra, dec, refstat1, >> refstats) next } refstat2 = (refstat2 * nbox2 - refstat1 * nbox1) / (nbox2 - nbox1) print (ra, dec, refstat1, refstat2, >> refstats) sky = min (refstat2, sky) } if (!access (refstats)) error (1, "No coordinates in " // ref) if (update) { hedit (ref, "msczero", 0., add+, del-, show-, verify-, update+) hedit (ref, "mscscale", 1., add+, del-, show-, verify-, update+) mscstack.zero = "!msczero" mscstack.scale = "!mscscale" } fd1 = images while (fscan (fd1, in) != EOF) { hselect (in, "naxis1,naxis2,pixfile", yes) | scan (nc, nl, inpix) if (refpix == inpix) next if (verbose) { printf (" Matching %s to %s\n", in, ref) printf (" Computing statistics for %s...\n", in) } # Measure input image. nfit = 0 fd2 = refstats while (fscan (fd2, ra, dec, refstat1, refstat2) != EOF) { nstat = nscan() - 2 print (ra, dec) | mscctran ("STDIN", "STDOUT", in, "world", "logical", col="1 2", units="hours native", formats="", min_sig=9, verbose=no) | scan (xc, yc) x1 = nint (xc - box1 / 2) x2 = x1 + box1 - 1 y1 = nint (yc - box1 / 2) y2 = y1 + box1 - 1 if (x1 < 1 || x2 > nc || y1 < 1 || y2 > nl) next printf ("%s[%d:%d,%d:%d]\n", in, x1, x2, y1, y2) | scan (image) imstat (image, fields="npix,mean", lower=lower, upper=upper, binwidth=0.1, format=no) | scan (npix, instat1) if (npix != nbox1 || instat1 == INDEF) next refstat1 = refstat1 - instat1 print (instat1, refstat1, >> fitstats) nfit = nfit + 1 if (nstat < 2) next x1 = nint (xc - box2 / 2) x2 = x1 + box2 - 1 y1 = nint (yc - box2 / 2) y2 = y1 + box2 - 1 if (x1 < 1 || x2 > nc || y1 < 1 || y2 > nl) next printf ("%s[%d:%d,%d:%d]\n", in, x1, x2, y1, y2) | scan (image) imstat (image, fields="npix,mean", lower=lower, upper=upper, binwidth=0.1, format=no) | scan (npix, instat2) if (npix != nbox2 || instat2 == INDEF) next instat2 = (instat2 * nbox2 - instat1 * nbox1) / (nbox2 - nbox1) refstat2 = refstat2 - instat2 print (instat2, refstat2, >> fitstats) nfit = nfit + 1 } if (!access (fitstats)) { printf ("WARNING: No matching coordinates in %s\n", in) next } if (nfit < 2) { printf ("WARNING: Insufficient measurements for fit (%d)\n", nfit) delete (fitstats, verify-) next } if (verbose) printf (" Fitting statistics...\n") if (interactive && fit) { msccurfit (fitstats, results, function="legendre", weighting="uniform", order=2, interactive=yes, axis=1, listdata=no, verbose=no, calctype="double", power=yes, device="stdgraph", cursor="") } else if (verbose) { print ("q", > temp) msccurfit (fitstats, results, function="legendre", weighting="uniform", order=2, interactive=yes, axis=1, listdata=no, verbose=no, calctype="double", power=yes, device="stdgraph", cursor=temp) delete (temp, verify-) } else { msccurfit (fitstats, results, function="legendre", weighting="uniform", order=2, interactive=no, axis=1, listdata=no, verbose=no, calctype="double", power=yes, device="stdgraph", cursor="") } delete (fitstats, verify-) tail (results, nlines=1) | scan (image, nstat, msczero) if (nscan() != 3 || nstat > 2) { printf ("WARNING: Error fitting %s\n", in) next } if (nstat == 1) mscscale = 0 else { mscscale = msczero tail (results, nlines=2) | scan (image, nstat, msczero) if (nscan() != 3 || nstat != 1) { printf ("WARNING: Error fitting %s\n", in) next } } delete (results, verify-) mscscale = mscscale + 1 msczero = msczero / mscscale if (interactive || verbose) { dsky = sky * (1/mscscale - 1) - msczero printf (" %s: SCALE = %.8g, OFFSET(@%.8g) = %.8g\n", in, mscscale, sky, dsky) } if (update) { if (interactive) { if (accept) { hedit (in, "msczero", msczero, add+, del-, show-, verify-, update+) hedit (in, "mscscale", mscscale, add+, del-, show-, verify-, update+) } } else { hedit (in, "msczero", msczero, add+, del-, show-, verify-, update+) hedit (in, "mscscale", mscscale, add+, del-, show-, verify-, update+) } } } fd1 = ""; delete (images, verify-) fd2 = ""; delete (refstats, verify-) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscimatch.par������������������������������������������������������������0000664�0000000�0000000�00000001112�13321663143�0017224�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,List of images coords,f,a,,,,File of coordinates bpm,s,h,"BPM",,,List of bad pixel masks measured,f,h,"",,,Measurment file scale,b,h,yes,,,Determine scale? zero,b,h,no,,,Determine zero offset? box1,i,h,21,1,,Inner box size for statistics box2,i,h,51,1,,Outer box size for statistics lower,r,h,1.,,,Lower limit for good data upper,r,h,INDEF,,,Upper limit for good data niterate,i,h,3,0,,Number of sigma clipping iterations sigma,r,h,3.,0.,,Sigma clipping factor interactive,b,h,no,,,Interactive? verbose,b,h,yes,,,Verbose? accept,b,q,yes,,,Accept scaling and update images? ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscjoin.cl���������������������������������������������������������������0000664�0000000�0000000�00000003766�13321663143�0016553�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCJOIN -- Join a split MEF file into an MEF file. # This routine uses the extension name stored by MSCSPLIT. procedure mscjoin (input) string input {prompt="List of input root names"} string output = "" {prompt="List of output MEF names"} bool delete = no {prompt="Delete input images after joining?"} bool verbose = no {prompt="Verbose?"} struct *fd1, *fd2 begin file inlist, extlist, in, out, inext, extver int index struct extname # Temporary files. inlist = mktemp ("tmp$iraf") extlist = mktemp ("tmp$iraf") # Expand input and output lists. Allow missing or short output list. sections (input, option="fullname", > extlist) sections (output, option="fullname") | joinlines (extlist, "STDIN", output=inlist, delim=" ", missing="", maxchars=161, shortest-, verbose-) delete (extlist, verify-) # Join each input. fd1 = inlist while (fscan (fd1, in, out) != EOF) { # If no output rootname is given use the input name. if (nscan() == 1) out = in # Check for the existance of the input and output. if (!imaccess (in//"_0") || !imaccess (in//"_1")) { printf ("WARNING: Can't access %s_0 or %s_1\n", in, in) next } if (imaccess (out//"[0]")) { printf ("WARNING: Output already exists (%s)\n", out) next } # Copy the primary HDU. imcopy (in//"_0[0]", out, verbose=verbose) # Join the extensions. for (index = 1;; index+=1) { inext = in // "_" // index if (!imaccess (inext)) break hselect (inext, "extnm", yes) | scan (extname) if (extname == "") extname = "im" // index hselect (inext, "extvr", yes) | scan (extver) if (nscan() == 0) imcopy (inext, out//"["//extname//",append,inherit]", verbose=verbose) else imcopy (inext, out//"["//extname//","//extver//",append,inherit]", verbose=verbose) hedit (out//"["//extname//"]", "extnm,extvr", add-, del+, verify-, update+, show-) } if (delete) imdelete (in//"_*", verify-) } fd1 = ""; delete (inlist, verify-) end ����������mscred-5.05-2018.07.09/src/mscmedian.cl�������������������������������������������������������������0000664�0000000�0000000�00000002624�13321663143�0017041�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCMEDIAN -- Mosiac MEDIAN with outtype option. procedure mscmedian () begin file jlist, in, out int xwin, ywin jlist = mktemp ("tmp$iraf") joinlists (input, output, output=jlist, delim=" ", shortest+) xwin = xwindow ywin = ywindow msctmp1.xwindow = xwin msctmp1.ywindow = ywin msctmp1.zloreject = zloreject msctmp1.zhireject = zhireject msctmp1.boundary = "reflect" msctmp1.verbose = no msctmp1.fmedian = fmedian msctmp1.hmin = hmin msctmp1.hmax = hmax msctmp1.zmin = zmin msctmp1.zmax = zmax msctmp1.unmap = yes fd = jlist while (fscan (fd, in, out) != EOF) { if (outtype == "median") { if (verbose) { if (fmedian) printf ("fmedian %s %s %d %d\n", in, out, xwin, ywin) else printf ("median %s %s %d %d\n", in, out, xwin, ywin) } msccmd ("msctmp1 $input $output", in, out, extname="", alist=no, flist=yes, verbose=no, exec=yes) } else { if (verbose) { if (fmedian) printf ("fmedian %s %s %d %d\n", in, out, xwin, ywin) else printf ("median %s %s %d %d\n", in, out, xwin, ywin) } msccmd ("msctmp1 $input $output", in, out, extname="", alist=no, flist=yes, verbose=no, exec=yes) if (verbose) printf ("imarith %s - %s %s\n", in, out, out) mscarith (in, "-", out, out, extname="", title="", divzero=0., hparams="", pixtype="", calctype="", verbose=no, noact=no) } } fd = ""; delete (jlist, verify-) end ������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscmedian.par������������������������������������������������������������0000664�0000000�0000000�00000001311�13321663143�0017215�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# Parameters for the MSCMEDIAN task input,f,a,,,,Input mosaic images output,f,a,,,,Output mosaic images xwindow,i,a,,,,X window size of median filter ywindow,i,a,,,,Y window size of median filter outtype,s,h,"median","median|difference",,Output type (median|difference) zloreject,r,h,INDEF,,,Lowside pixel value cutoff zhireject,r,h,INDEF,,,High side pixel value cutoff verbose,b,h,yes,,,"Print messages about actions taken by the task # Fast median" fmedian,b,h,yes,,,Use fast median algorithm? hmin,i,h,-32768,,,Minimum histogram bin hmax,i,h,32767,,,Maximum histogram bin zmin,r,h,INDEF,,,Pixel value corresponding to hmin zmax,r,h,INDEF,,,"Pixel value corresponding to hmax " fd,*struct,h,"" mode,s,h,'ql' �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscnimage.cl�������������������������������������������������������������0000664�0000000�0000000�00000026074�13321663143�0017051�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure mscimage begin file in, out, ref, pl, image, trimsec, outsec, plsec file inlists, extlist, pllist, coord, db, wcsref, outtemp, pltemp int nc, nl, cmin, cmax, lmin, lmax, nimage, nimages, nxblk, nyblk real rval, xmin, xmax, ymin, ymax, crpix1, crpix2 string extname, str cache mscextensions, mscgmask # Temporary files. inlists = mktemp ("tmp$iraf") extlist = mktemp ("tmp$iraf") pllist = mktemp ("tmp$iraf") coord = mktemp ("tmp$iraf") db = mktemp ("tmp$iraf") # Temporary images. outtemp = mktemp ("tmp") wcsref = mktemp ("tmp") pltemp = mktemp ("tmp") # Expand input MEF lists. joinlists (input, output, output=inlists, delim=" ", short+, type="image") # Process each input MEF file. fd_in = inlists while (fscan (fd_in, in, out) != EOF) { # Check for an existing output image. if (imaccess (out)) { printf ("Warning: Image already exists (%s)\n", out) next } # Set output pl file rootname. if (pixmask) { pl = out nc = strlen (pl) if (nc > 5 && substr (pl, nc-4, nc) == ".fits") pl = substr (pl, 1, nc-5) else if (nc > 4 && substr (out, nc-3, nc) == ".imh") pl = substr (pl, 1, nc-4) pl = pl // "_bpm" if (format == "image" && imaccess (pl)) { printf ("Warning: Mask already exists (%s)\n", pl) next } } else pl = "" # Expand extensions and check for data. mscextensions (in, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) nimages = mscextensions.nimages nimage = 0 if (nimages < 1) { printf ("WARNING: No input image data found in `%s'.\n", in) delete (extlist, verify=no) next } # Create WCS template. This is created only once per MEF file. if (!imaccess(wcsref)) { ref = reference mscwtemplate ("@"//extlist, wcsref, wcssource=wcssource, reference=ref, ra=ra, dec=dec, scale=scale, rotation=rotation, projection="",verbose=verbose) } # Create output mosaic. fd_ext = extlist while (fscan (fd_ext, image) != EOF) { # Set output MEF format. if (nimages > 1) { nimage = nimage + 1 hselect (image, "extname", yes) | scan (extname) if (nscan() == 0) extname = "im"+nimage printf ("%s[%s,append]\n", outtemp, extname) | scan (outsec) printf ("%s%s\n", pl, extname) | scan (plsec) } else { extname = "" outsec = outtemp plsec = pl } # Check for existing pixel mask before we actually do anything. if (pixmask && imaccess (plsec)) { delete (coord, verify=no) delete (db, verify=no) printf ("Warning: Mask already exists (%s)\n", plsec) next } if (verbose) printf ("Resampling %s ...\n", image) # Trim data. hselect (image, "naxis1,naxis2", yes) | scan (nc, nl) cmin = 1+ntrim; cmax = nc-ntrim lmin = 1+ntrim; lmax = nl-ntrim printf ("[%d:%d,%d:%d]\n", cmin, cmax, lmin, lmax) | scan (trimsec) # Determine grid points and mapping of extn into the mosaic. nc = cmax - cmin + 1 nl = lmax - lmin + 1 xmin = (nc - 1.) / (nx - 1.) ymin = (nl - 1.) / (ny - 1.) for (ymax=1; ymax<=nl+1; ymax=ymax+ymin) for (xmax=1; xmax<=nc+1; xmax=xmax+xmin) print (xmax, ymax, xmax, ymax, >> coord) mscctran (coord, db, image//trimsec, "logical", "world", columns="1 2", units="", formats="%.4H %.3h", min_sigdigit=10, verbose=no) delete (coord, verify-) wcsctran (db, coord, wcsref, inwcs="world", outwcs="logical", columns="1 2", units="hours native", formats="", min_sigdigit=10, verbose=no) delete (db, verify-) # Determine the output limits. xmax = 0.; xmin = 1.; ymax = 0.; ymin = 1. fd_coord = coord while (fscan (fd_coord, x, y) != EOF) { if (nscan() < 2) next if (xmax < xmin) { xmin = x; xmax = x; ymin = y; ymax = y } else { xmin = min (x, xmin); xmax = max (x, xmax) ymin = min (y, ymin); ymax = max (y, ymax) } } fd_coord = "" cmin = nint (xmin - 1.5) cmax = nint (xmax + 1.5) lmin = nint (ymin - 1.5) lmax = nint (ymax + 1.5) # Compute transformation for extension. geomap (coord, db, cmin, cmax, lmin, lmax, transforms="", results="", fitgeometry=fitgeometry, function="chebyshev", xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, yyorder=yyorder, yxterms=yxterms, reject=INDEF, calctype="double", verbose=no, interactive=interactive, graphics="stdgraph", cursor="") # Transform extension into output. if (nxblock == INDEF) nxblk = cmax - cmin + 3 else nxblk = nxblock if (nyblock == INDEF) nyblk = lmax - lmin + 3 else nyblk = nyblock geotran (image//trimsec, outsec, db, coord, geometry="geometric", xin=INDEF, yin=INDEF, xshift=INDEF, yshift=INDEF, xout=INDEF, yout=INDEF, xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF, xmin=cmin, xmax=cmax, ymin=lmin, ymax=lmax, xsample=10., ysample=10., xscale=1., yscale=1., ncols=INDEF, nlines=INDEF, interpolant=interpolant, boundary="constant", constant=constant, fluxconserve=fluxconserve, nxblock=nxblk, nyblock=nyblk, verbose=no) # Set WCS. wcscopy (outsec, wcsref, verbose-) xmin = 0.; ymin = 0. hselect (outsec, "crpix1,crpix2", yes) | scan (xmin, ymin) xmin = xmin - cmin + 1 ymin = ymin - lmin + 1 if (nimage == 1) { crpix1 = xmin crpix2 = ymin } else { crpix1 = max (crpix1, xmin) crpix2 = max (crpix2, ymin) } hedit (outsec, "crpix1", xmin, add+, verify-, show-, update+) hedit (outsec, "crpix2", ymin, add+, verify-, show-, update+) # Set output mask. if (pixmask) { printf ("%s%s\n", pl, extname) | scan (plsec) mscgmask (image//trimsec, pltemp//".pl", "BPM", mval=10000) geotran (pltemp, plsec//".fits", db, coord, geometry="geometric", xin=INDEF, yin=INDEF, xshift=INDEF, yshift=INDEF, xout=INDEF, yout=INDEF, xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF, xmin=cmin, xmax=cmax, ymin=lmin, ymax=lmax, xsample=10., ysample=10., interpolant=minterpolant, boundary="constant", constant=20000., fluxconserve=no, nxblock=nxblk, nyblock=nyblk, verbose=no) imdelete (pltemp, verify-) # Convert values to mask with 1=bad pixel, 2=out of bounds. imexpr ("abs(a) < 1 ? 0 : int (abs(a) / 10010 + 1)", plsec//".pl", plsec//".fits", dims="auto", intype="auto", outtype="int", refim="auto", rangecheck=no, verbose=no) imdelete (plsec//".fits", verify-) # Set WCS of mask and enter mask name in output image. hedit (outsec, "BPM", plsec//".pl", add+, show-, verify-, update+) wcscopy (plsec, outsec, verbose-) print (plsec, >> pllist) } else hedit (outsec, "BPM", del+, add-, show-, verify-, update+) delete (coord, verify=no) delete (db, verify=no) } fd_ext = ""; delete (extlist, verify=no) # Create the final output. if (nimages > 1 && format == "image") { # Stack multiple pieces into a single image. if (verbose) printf ("Creating image %s ...\n", out) mscextensions (outtemp, output="file", index="", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) # Make masks. if (pixmask) { combine ("@"//pllist, pltemp//".pl", headers="", bpmasks=pl, rejmasks="", nrejmasks="", expmasks="", sigmas="", imcmb="", ccdtype="", amps=no, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="wcs", masktype="none", maskvalue=0., blank=0., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=.99, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., > "dev$null") imdelete (pltemp, verify-) combine ("@"//extlist, out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigmas="", imcmb="", ccdtype="", amps=no, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="wcs", masktype="badvalue", maskvalue=2, blank=0., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., > "dev$null") hedit (out, "BPM", pl, add+, verify-, show-, update+) hedit (pl, "IMCMB???,PROCID??", add-, del+, update+, verify-, show-) } else { combine ("@"//extlist, out, headers="", bpmasks="", rejmasks="", nrejmasks="", expmasks="", sigmas="", imcmb="", ccdtype="", amps=no, subsets=no, delete=no, combine="average", reject="none", project=no, outtype="real", outlimits="", offsets="wcs", masktype="none", maskvalue=2, blank=0., scale="none", zero="none", weight="none", statsec="", lthreshold=INDEF, hthreshold=INDEF, nlow=1, nhigh=1, nkeep=1, mclip=yes, lsigma=3., hsigma=3., rdnoise="0.", gain="1.", snoise="0.", sigscale=0.1, pclip=-0.5, grow=0., > "dev$null") } # Fix up header. hselect ("@"//extlist, "gain", yes) | average (data_value=0.) | scan (rval) hedit (out, "gain", rval, add+, del-, update+, verify-, show-) hselect ("@"//extlist, "rdnoise", yes) | average (data_value=0.) | scan (rval) hedit (out, "rdnoise", rval, add+, del-, update+, verify-, show-) hedit (out, "IMCMB???,PROCID??", add-, del+, update+, verify-, show-) hedit (out, "NEXTEND,DETSEC,CCDSEC,AMPSEC,IMAGEID,DATASEC,TRIMSEC,BIASSEC", add-, del+, update+, verify-, show-) imdelete (outtemp, verify-) if (access (pllist)) { imdelete ("@"//pllist, verify-) delete (pllist, verify-) } delete (extlist, verify=no) } else if (nimages > 1) { # Set MEF output. imrename (outtemp, out, verbose-) mscextensions (out, output="file", index="", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) fd_ext = extlist while (fscan (fd_ext, image) != EOF) { hselect (image, "naxis1,naxis2,crpix1,crpix2", yes) | scan (nc, nl, xmin, ymin) cmin = nint (crpix1 - xmin + 1) lmin = nint (crpix2 - ymin + 1) cmax = nc + cmin - 1 lmax = nl + lmin - 1 printf ("[%d:%d,%d:%d]\n", cmin, cmax, lmin, lmax) | scan (str) hedit (image, "DETSEC", str, add+, verify-, show-, update+) hedit (image, "DTM1_1", 1., add+, verify-, show-, update+) hedit (image, "DTM2_2", 1., add+, verify-, show-, update+) cmin = cmin - 1 lmin = lmin - 1 hedit (image, "DTV1", cmin, add+, verify-, show-, update+) hedit (image, "DTV2", lmin, add+, verify-, show-, update+) hedit (image, "CCDSUM,CCDSEC,AMPSEC,ATM1_1,ATM2_2,ATV1,ATV2", del+, add-, verify-, show-, update+) } fd_ext = ""; delete (extlist, verify-) } else { # If just a single input image produce a single output. imrename (outsec, out, verbose-) } if (access (pllist)) delete (pllist, verify-) } fd_in = ""; delete (inlists, verify=no) # Delete all remaining temporary files. if (imaccess(wcsref)) imdelete (wcsref, verify-) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscnimage.par������������������������������������������������������������0000664�0000000�0000000�00000003222�13321663143�0017223�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,"List of input mosaic exposures" output,s,a,,,,"List of output images" format,s,h,"image","|image|mef|",,"Output format (image|mef)" pixmask,b,h,yes,,,"Create pixel mask?" verbose,b,h,)_.verbose,,,"Verbose output? # Output WCS parameters" wcssource,s,h,"image","|image|parameters|",,"Output WCS source (image|parameters)" reference,f,h,"",,,"Reference image" ra,r,h,INDEF,0,24,"RA of tangent point (hours)" dec,r,h,INDEF,-90,90,"DEC of tangent point (degrees)" scale,r,h,INDEF,,,"Scale (arcsec/pixel)" rotation,r,h,INDEF,-360,360,"Rotation of DEC from N to E (degrees) # Resampling parmeters" blank,r,h,0,,,Blank value interpolant,s,h,"linear",,,"Interpolant for data" minterpolant,s,h,"linear",,,"Interpolant for mask" boundary,s,h,"reflect","nearest|constant|reflect|wrap",,"Boundary extension" constant,r,h,0,,,"Constant boundary extension value" fluxconserve,b,h,no,,,"Preserve flux per unit area?" ntrim,i,h,8,0,,"Edge trim in each extension" nxblock,i,h,INDEF,,,"X dimension of working block size in pixels" nyblock,i,h,INDEF,,,"Y dimension of working block size in pixels # Geometric mapping parameters" interactive,b,h,no,,,"Fit mapping interactively?" nx,i,h,10,,,"Number of x grid points" ny,i,h,20,,,"Number of y grid points" fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general,,"Fitting geometry" xxorder,i,h,4,2,,"Order of x fit in x" xyorder,i,h,4,2,,"Order of x fit in y" xxterms,s,h,"half",,,"X fit cross terms type" yxorder,i,h,4,2,,"Order of y fit in x" yyorder,i,h,4,2,,"Order of y fit in y" yxterms,s,h,"half",,,"Y fit cross terms type " fd_in,*struct,h,"",,, fd_ext,*struct,h,"",,, fd_coord,*struct,h,"",,, mode,s,h,"ql",,, ������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscoimage.cl�������������������������������������������������������������0000664�0000000�0000000�00000014264�13321663143�0017050�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������procedure mscimage begin file in, out, pl, ref, image file inlist, outlist, extlist, wcs, coord, db, pltemp, outsec int nc, nl, cmin, cmax, lmin, lmax real rval, xmin, xmax, ymin, ymax cache sections, mscextensions, mscgmask inlist = mktemp ("tmp$iraf") outlist = mktemp ("tmp$iraf") extlist = mktemp ("tmp$iraf") coord = mktemp ("tmp$iraf") db = mktemp ("tmp$iraf") pltemp = mktemp ("tmp") # Expand lists. sections (input, option="fullname", > inlist) sections (output, option="fullname", > outlist) ref = reference if (verbose && ref != "") printf ("Using `%s' for the WCS reference\n", ref) fd_in = inlist fd_out = outlist while (fscan (fd_in, in) != EOF) { if (fscan (fd_out, out) == EOF) break pl = out nc = strlen (pl) if (nc > 5 && substr (pl, nc-4, nc) == ".fits") pl = substr (pl, 1, nc-5) else if (nc > 4 && substr (out, nc-3, nc) == ".imh") pl = substr (pl, 1, nc-4) pl = pl // "_bpm.fits" if (ref == "") { if (verbose) printf ("Using `%s' for the WCS reference\n", in) ref = out } if (imaccess (out)) { printf ("Warning: Image already exists (%s)\n", out) next } # Expand extensions. mscextensions (in, output="file", index="0-", extname="", extver="", lindex=no, lname=yes, lver=no, ikparams="", > extlist) if (mscextensions.nimages < 1) { printf ("WARNING: No input image data found in `%s'.\n", in) delete (extlist, verify=no) next } # Create template output image. if (verbose) printf ("Creating empty output mosaic %s ...\n", out) msctemplate ("@"//extlist, out, reference=ref, blank=blank, border=0, projection="", pixtype="real") if (pixmask) { msctemplate ("@"//extlist, pl, reference=ref, blank=10000., border=0, projection="", pixtype="short") hedit (out, "bpm", pl, add+, del-, update+, verify-, show-) } else hedit (out, "bpm", add-, del+, update+, verify-, show-) hselect ("@"//extlist, "gain", yes) | average (data_value=0.) |\ scan (rval) hedit (out, "gain", rval, add+, del-, update+, verify-, show-) hselect ("@"//extlist, "rdnoise", yes) | average (data_value=0.) |\ scan (rval) hedit (out, "rdnoise", rval, add+, del-, update+, verify-, show-) hedit (out, "nextend,detsec,ccdsec,ampsec,imageid,datasec,trimsec,biassec", add-, del+, update+, verify-, show-) # Create output mosaic. fd_ext = extlist while (fscan (fd_ext, image) != EOF) { if (verbose) printf ("Mapping %s to %s ...\n", image, out) # Trim data. hselect (image, "naxis1,naxis2", yes) | scan (nc, nl) cmin = 1+ntrim; cmax = nc-ntrim lmin = 1+ntrim; lmax = nl-ntrim printf ("%s[%d:%d,%d:%d]\n", image, cmin, cmax, lmin, lmax) | scan (image) # Determine grid points and mapping of extn into the mosaic. nc = cmax - cmin + 1 nl = lmax - lmin + 1 xmin = (nc - 1.) / (nx - 1.) ymin = (nl - 1.) / (ny - 1.) for (ymax=1; ymax<=nl+1; ymax=ymax+ymin) for (xmax=1; xmax<=nc+1; xmax=xmax+xmin) print (xmax, ymax, xmax, ymax, >> coord) mscctran (coord, db, image, "logical", "world", columns="1 2", units="", formats="%.3H %.2h", min_sigdigit=9, verbose=no) delete (coord, verify-) wcsctran (db, coord, out, inwcs="world", outwcs="logical", columns="1 2", units="hours native", formats="", min_sigdigit=9, verbose=no) delete (db, verify-) xmax = 0.; xmin = 1.; ymax = 0.; ymin = 1. fd_coord = coord while (fscan (fd_coord, x, y) != EOF) { if (nscan() < 2) next if (xmax < xmin) { xmin = x; xmax = x; ymin = y; ymax = y } else { xmin = min (x, xmin); xmax = max (x, xmax) ymin = min (y, ymin); ymax = max (y, ymax) } } fd_coord = "" hselect (out, "naxis1,naxis2", yes) | scan (nc, nl) cmin = max (1, nint (xmin - 1.5)) cmax = min (nc, nint (xmax + 1.5)) lmin = max (1, nint (ymin - 1.5)) lmax = min (nl, nint (ymax + 1.5)) # Compute transformation for extension. geomap (coord, db, cmin, cmax, lmin, lmax, transforms="", results="", fitgeometry=fitgeometry, function="polynomial", xxorder=xxorder, xyorder=xyorder, xxterms=xxterms, yxorder=yxorder, yyorder=yyorder, yxterms=yxterms, reject=INDEF, calctype="double", verbose=no, interactive=interactive, graphics="stdgraph", cursor="") # Transform extension into output mosaic. # cmin = cmin + ntrim # cmax = cmax - ntrim # lmin = lmin + ntrim # lmax = lmax - ntrim printf ("%s[%d:%d,%d:%d]\n", out, cmin, cmax, lmin, lmax) | scan (outsec) geotran (image, outsec, db, coord, geometry="geometric", xin=INDEF, yin=INDEF, xshift=INDEF, yshift=INDEF, xout=INDEF, yout=INDEF, xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF, xmin=cmin, xmax=cmax, ymin=lmin, ymax=lmax, xsample=10., ysample=10., xscale=1., yscale=1., ncols=INDEF, nlines=INDEF, interpolant=interpolant, boundary=boundary, constant=constant, fluxconserve=fluxconserve, nxblock=nxblock, nyblock=nyblock, verbose=no) if (pixmask) { mscgmask (image, pltemp, "BPM", mval=10000) printf ("%s[%d:%d,%d:%d]\n", pl, cmin, cmax, lmin, lmax) | scan (outsec) geotran (pltemp, outsec, db, coord, geometry="geometric", xin=INDEF, yin=INDEF, xshift=INDEF, yshift=INDEF, xout=INDEF, yout=INDEF, xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF, xmin=cmin, xmax=cmax, ymin=lmin, ymax=lmax, xsample=10., ysample=10., interpolant=minterpolant, boundary="constant", constant=10000., fluxconserve=no, nxblock=nxblock, nyblock=nyblock, verbose=no) imdelete (pltemp, verify-) } delete (coord, verify=no) delete (db, verify=no) } fd_ext = ""; delete (extlist, verify=no) if (pixmask) { pltemp = pl pl = out nc = strlen (pl) if (nc > 5 && substr (pl, nc-4, nc) == ".fits") pl = substr (pl, 1, nc-5) else if (nc > 4 && substr (out, nc-3, nc) == ".imh") pl = substr (pl, 1, nc-4) pl = pl // "_bpm.pl" #imcopy (pltemp, pl, verbose-) imfunc (pltemp, pl, function="abs", verbose-) imdelete (pltemp, verify-) hedit (out, "bpm", pl, add+, del-, update+, verify-, show-) } } fd_out = ""; delete (outlist, verify=no) fd_in = ""; delete (inlist, verify=no) end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscoimage.par������������������������������������������������������������0000664�0000000�0000000�00000002452�13321663143�0017230�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������input,s,a,,,,"List of input mosaic exposures" output,s,a,,,,"List of output images" reference,f,h,"",,,"Reference image" pixmask,b,h,yes,,,"Create pixel mask?" verbose,b,h,)_.verbose,,,"Verbose output? # Resampling parmeters" blank,r,h,0,,,Blank value interpolant,s,h,"linear",,,"Interpolant for data" minterpolant,s,h,"linear",,,"Interpolant for mask" boundary,s,h,"reflect","nearest|constant|reflect|wrap",,"Boundary extension" constant,r,h,0,,,"Constant boundary extension value" fluxconserve,b,h,no,,,"Preserve flux per unit area?" ntrim,i,h,7,0,,"Edge trim in each extension" nxblock,i,h,2048,,,"X dimension of working block size in pixels" nyblock,i,h,1024,,,"Y dimension of working block size in pixels # Geometric mapping parameters" interactive,b,h,no,,,"Fit mapping interactively?" nx,i,h,10,,,"Number of x grid points" ny,i,h,20,,,"Number of y grid points" fitgeometry,s,h,"general",|shift|xyscale|rotate|rscale|rxyscale|general,,"Fitting geometry" xxorder,i,h,4,2,,"Order of x fit in x" xyorder,i,h,4,2,,"Order of x fit in y" xxterms,s,h,"half",,,"X fit cross terms type" yxorder,i,h,4,2,,"Order of y fit in x" yyorder,i,h,4,2,,"Order of y fit in y" yxterms,s,h,"half",,,"Y fit cross terms type " fd_in,*struct,h,"",,, fd_out,*struct,h,"",,, fd_ext,*struct,h,"",,, fd_coord,*struct,h,"",,, mode,s,h,"ql",,, ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscpipeline/�������������������������������������������������������������0000775�0000000�0000000�00000000000�13321663143�0017065�5����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscpipeline/caldb.cl�����������������������������������������������������0000664�0000000�0000000�00000017306�13321663143�0020461�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# PIPEPARS -- Set up pipeline reduction parameters. # # This tasks sets all the parameters used for pipeline processing. procedure caldb (input) file input {prompt="Mosaic exposure"} file caldb = "caldb$" {prompt="Calibration database"} string date = "!DATE-OBS" {prompt="Date"} struct *fd begin string dateid #{prompt="Date identification string"} string instrument #{prompt="Instrument"} string telescope #{prompt="Telescope"} string filter #{prompt="Filter"} file parfile #{prompt="Parameter file"} file wcs #{prompt="WCS database"} file xtalkfile #{prompt="Crosstalk file"} file bpm #{prompt="Instrument bad pixel mask"} file zero #{prompt="Zero level calibration"} file dark #{prompt="Dark count calibration"} file flat #{prompt="Flat field calibration"} file pupil #{prompt="Pupil template calibration"} file phot #{prompt="Photometry calibration"} file procrecipe #{prompt="Processing recipe"} file stackrecipe #{prompt="Stack recipe\n"} string in, db, dt, im, men, dir, val file file1, file2 file temp int year, month, day struct str temp = mktemp ("tmp$iraf") # Set task parameters. in = input db = caldb dt = date # Trim any ".fits extension. day = strlen (in) if (substr (in, day-4, day) == ".fits") in = substr (in, 1, day-5) # Use first extension for header keywords. im = in // "[1]" # Set date. if (substr (dt, 1, 1) == "!") hselect (im, substr(dt,2,1000), yes) | scan (dt) if (stridx (dt, "/") > 0) { if (fscanf (dt, "%2d/%2d/%2d", day, month, year) != 3) error (1, "Syntax error in date ("//dt//")") year = 1900 + year } else { if (fscanf (dt, "%4d-%2d-%2d", year, month, day) != 3) error (1, "Syntax error in date ("//dt//")") } printf ("%04d%02d%02d\n", year, month, day) | scan (val) dateid = val # Get instrument. men = db // "instruments.men" hselect (im, "detector", yes) | scan (str) match (str, men, stop-) | scan (val) instrument = val db = db // instrument // "/" # Get telescope. men = db // "telescopes.men" hselect (im, "telescope", yes) | scan (str) match (str, men, stop-) | scan (val) telescope = val db = db // telescope // "/" # Get filter. men = db // "filters.men" hselect (im, "filter", yes) | scan (str) match (str, men, stop-) | scan (val) filter = val db = db // filter // "/" # Set parameters. parfile = "" dir = db // "pars" // "/" file1 = dir // dateid files (dir//"[0-9]*", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (parfile == "") parfile = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (parfile == "") error (1, "No parameter file found") cl (< parfile) # Set WCS database. wcs = "" dir = db // "wcs" // "/" file1 = dir // dateid files (dir//"[0-9]*", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (wcs == "") wcs = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) mscsetwcs.database = wcs # Set cross talk. xtalkfile = "" if (ccdproc.xtalkcor) { dir = db // "xtalk" // "/" file1 = dir // dateid files (dir//"[0-9]*", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (xtalkfile == "") xtalkfile = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (xtalkfile == "") error (1, "No cross-talk file found") ccdproc.xtalkfile = xtalkfile } # Set BPM. bpm = "" if (ccdproc.fixpix) { dir = db // "bpm" // "/" file1 = dir // dateid files (dir//"[0-9]*", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (bpm == "") bpm = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (bpm == "") error (1, "No bad pixel file found") ccdproc.fixfile = bpm } # Set zero level calibration. zero = "" if (ccdproc.zerocor) { dir = db // "zero" // "/" file1 = dir // dateid // ".fits" files (dir//"[0-9]*.fits", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (zero == "") zero = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (zero == "") error (1, "No zero level calibration found") ccdproc.zero = zero } # Set dark count calibration. dark = "" if (ccdproc.darkcor) { dir = db // "dark" // "/" file1 = dir // dateid // ".fits" files (dir//"[0-9]*.fits", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (dark == "") dark = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (dark == "") error (1, "No dark count calibration found") ccdproc.dark = dark } # Set flat field calibration. flat = "" if (ccdproc.flatcor) { dir = db // "flat" // "/" file1 = dir // dateid // ".fits" files (dir//"[0-9]*.fits", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (flat == "") flat = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (flat == "") error (1, "No flat field calibration found") ccdproc.flat = flat } # Set pupil template. pupil = "" dir = db // "pupil" // "/" if (access (dir)) { file1 = dir // dateid // ".fits" files (dir//"[0-9]*.fits", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (pupil == "") pupil = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (pupil == "") error (1, "No pupil template found") rmpupil.template = pupil } # Set photometry configuration file. phot = "" dir = db // "photcal" // "/" if (access (dir)) { file1 = dir // dateid files (dir//"[0-9]*", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (phot == "") phot = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) if (phot == "") error (1, "No photometry configuration found") mscqphot.photconf = phot } # Set processing recipe. procrecipe = "" dir = db // "recipes" // "/" file1 = dir // dateid // ".cl" files (dir//"[0-9]*.cl", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (procrecipe == "") procrecipe = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) pipeline.procrecipe = procrecipe # Set stack recipe. stackrecipe = "" dir = db // "stackrecipes" // "/" file1 = dir // dateid // ".cl" files (dir//"[0-9]*.cl", sort+, > temp) fd = temp while (fscan (fd, file2) != EOF) { if (stackrecipe == "") stackrecipe = file2 if (file1 < file2) break } fd = ""; delete (temp, verify-) pipeline.stackrecipe = stackrecipe if (logfile != "") { printf ("Calibration database = %s -> %s\n", caldb, osfn(caldb), >> logfile) printf ("Target date = %s\n", dateid, >> logfile) printf ("\n", >> logfile) if (parfile != "") printf ("Parameter file = %s\n", parfile, >> logfile) if (wcs != "") printf ("Astrometry file = %s\n", wcs, >> logfile) if (xtalkfile != "") printf ("Crosstalk file = %s\n", xtalkfile, >> logfile) if (bpm != "") printf ("Instrument bad pixel mask = %s\n", bpm, >> logfile) if (zero != "") printf ("Zero level calibration = %s\n", zero, >> logfile) if (dark != "") printf ("Dark count calibration = %s\n", dark, >> logfile) if (flat != "") printf ("Flat field calibration = %s\n", flat, >> logfile) if (pupil != "") printf ("Pupil template calibration = %s\n", pupil, >> logfile) if (phot != "") printf ("Photometry calibration = %s\n", phot, >> logfile) if (procrecipe != "") printf ("Processing recipe = %s\n", procrecipe, >> logfile) if (stackrecipe != "") printf ("Stack recipe = %s\n", stackrecipe, >> logfile) } end ��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscpipeline/mscpipeline.cl�����������������������������������������������0000664�0000000�0000000�00000000600�13321663143�0021711�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������#{ MSCPIPELINE -- Mosaic CCD Reduction Pipeline Package package mscpipeline task pipeline = mscpipeline$pipeline.cl task caldb = mscpipeline$caldb.cl task pipestep = mscpipeline$pipestep.cl task $procrecipe = mscpipeline$procrecipe.cl task $stackrecipe = mscpipeline$stackrecipe.cl struct *fd1, *fd2 struct *fdstack if (access (pipeuser)) cl (< pipeuser) else ; clbye() ��������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscpipeline/mscpipeline.par����������������������������������������������0000664�0000000�0000000�00000000311�13321663143�0022074�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# MSCPIPELINE package parameter file pipeuser,s,h,"",,,Local user definition script pipelog,s,h,"",,,Pipeline log file logfile,s,h,"",,,Logfile plotfile,s,h,"",,,Plotfile version,s,h,"V3.1: May 1999" �����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscpipeline/pipeline.cl��������������������������������������������������0000664�0000000�0000000�00000005422�13321663143�0021215�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# PIPELINE - Run pipeline on a set of images. procedure pipeline (input) string input {prompt="List of input Mosaic files"} file caldb = "" {prompt="Calibration database"} string date = "!DATE-OBS" {prompt="Calibration date\n"} file procrecipe {prompt="Processing recipe"} file stackrecipe {prompt="Stack recipe\n"} struct *fd begin file inpt, inlist, in, curdir file inlist1, groups, temp int len struct str # Set current directory and pipeline log with full pathname. pathnames (".") | scan (curdir) pathnames (pipelog) | scan (temp) pipelog = temp # Expand input list. inpt = input inlist = mktemp ("tmp$iraf") inlist1 = mktemp ("tmp$iraf") sections (inpt, option="fullname", > inlist) # Run single exposure recipes. fd = inlist while (fscan (fd, in) != EOF) { # Trim any ".fits extension. len = strlen (in) if (substr (in, len-4, len) == ".fits") in = substr (in, 1, len-5) # Check working directory and image. cd (curdir) if (!access (in)) { if (!imaccess (in//"[0]")) { xlog ("*1*", "TIME", "error", in, "pipeline", "WARNING: File not found", output=pipelog) next } mkdir (in) imrename (in, in, verbose-) } cd (in) if (!imaccess (in//"[0]")) { xlog ("*1*", "TIME", "error", in, "pipeline", "WARNING: File not found", output=pipelog) next } # Add image to list of available images for stack processing. printf ("%s/%s[1]\n", in, in, >> inlist1) # Check for completed processing. if (access (pipelog)) { xlog ("done", in, "pipeline", output="STDOUT") | scan (str) match (str, pipelog, stop-) | count ("STDIN") | scan (i) if (i > 0) next } xlog ("*1*", "TIME", "run ", in, "pipeline", output=pipelog) # Set processing parameters and recipe. logfile = in // ".html" plotfile = in // ".mc" set stdvdm = (plotfile) caldb.input = in caldb.caldb = caldb caldb.date = date pipestep ("caldb", in, "", "CALDB") # Run the recipe. if (access (procrecipe)) { printf ("redefine $procrecipe = %s; procrecipe %s\n", procrecipe, in) | cl xlog ("*1*", "TIME", "done", in, "pipeline", output=pipelog) } else printf ("WARNING: No recipe found for %s\n", in) } fd = "" cd (curdir) # # Run stack recipe. # if (access (inlist1) && access (stackrecipe)) { # redefine $stackrecipe = (stackrecipe) # # groups = mktemp ("tmp$iraf") # # # Group using the first extension header. # ccdgroups ("@"//inlist1, groups, list=groups) # # # Process each group. # fd = groups # while (fscan (fd, in) != EOF) # stackrecipe ("@"//in) # fd = "" # # delete ("@"//groups, verify-) # delete (groups, verify-) # } if (access (inlist1)) delete (inlist1, verify-) delete (inlist, verify-) end ����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/mscpipeline/pipestep.cl��������������������������������������������������0000664�0000000�0000000�00000002602�13321663143�0021236�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������# PIPESTEP - Run pipeline step. procedure pipestep (command, input, imkey, logkey) string command {prompt="Command"} file input {prompt="Input filename"} string imkey {prompt="Image header keyword"} string logkey {prompt="Logfile keyword"} begin file in, temp string cmd, ikey, lkey, str1 struct str2 cmd = command in = input ikey = imkey lkey = logkey temp = mktemp ("tmp$iraf") # Check if step has been done. if (in != "" && ikey != "") { hselect (in//"[0]", ikey, yes) | scan (str1, str2) if (nscan() != 0) return } # Initialize logfile. if (logfile != "") { if (!access (logfile)) xlog ("

", output=logfile)
	}
		
	# Log start of command.
	if (lkey != "") {
	    xlog ("

", lkey//":", in, "TIME", "

",
		output=logfile)
	    lpar (cmd) | cmdstr (cmd, hidden+, > temp)
	    xlog ("@"//temp, output=logfile)
	    xlog ("\n", output=logfile)
	    delete (temp, verify-)
	}

	xlog ("*1*", "TIME", "run ", in, cmd, output=pipelog)
	dpar (cmd) |
	    xlog ("*2*", "TIME", "pars", in, cmd, "@STDIN", output=pipelog)

	# Run command.
	printf ("%s (mode='h', >> \"%s\")\n", cmd, logfile) | cl
	if (in != "" && ikey != "") {
	    xlog ("TIME", cmd, output="STDOUT") | scan (str2)
	    hedit (input//"[0]", ikey, str2, add+, verify-, show-, update+)
	}

	# Log end of command.
	xlog ("*1*", "TIME", "done", in, cmd, output=pipelog)
end
mscred-5.05-2018.07.09/src/mscpixarea.cl000066400000000000000000000033271332166314300172360ustar00rootroot00000000000000# MSCPIXAREA -- Compute/correct pixel area factors.

procedure mscpixarea (input, output)

string	input			{prompt="List of input MEF files"}
string	output			{prompt="List of output MEF files"}
string	outtype = "multiply"	{prompt="Output type",
				 enum="area|multiply|divide"}

real	norm = INDEF		{prompt="Area normalization"}
bool	verbose = no		{prompt="Verbose output?"}

struct	*fd1

begin
	file	inlist, outlist, extlist
	string	in, out, ext
	int	nin

	cache sections, mscextensions

	inlist = mktemp ("tmp$iraf")
	outlist = mktemp ("tmp$iraf")
	extlist = mktemp ("tmp$iraf")

	sections (input, option="fullname", >> extlist)
	nin = sections.nimages
	sections (output, option="fullname", >> outlist)
	if (sections.nimages != nin)
	    error (1, "Input and output lists don't match")

	joinlines (extlist, outlist, output=inlist, delim=" ",
	    maxchars=161, verbose-)
	delete (extlist, verify-)
	delete (outlist, verify-)

	if (verbose) {
	    printf ("MSCPIXAREA:  "); time
	}

	fd1 = inlist
	while (fscan (fd1, in, out) != EOF) {
	    if (imaccess (out//"[0]")) {
		printf ("WARNING: Output already exists (%s)\n", out)
		next
	    }

	    if (verbose)
		printf ("  %s: output=%s, outtype=%s\n", in, out, outtype)

	    # Input list of extensions.
	    mscextensions (in, output="file", index="1-", extname="", extver="",
		lindex+, lname-, lver-, ikparams="", > extlist)
	    nin = mscextensions.nimages

	    # Output list.
	    for (i=1; i<=nin; i+=1)
		printf ("%s[append,inherit]\n", out, >> outlist)

	    # Create output.
	    imcopy (in//"[0]", out, verbose-)
	    pixarea ("@"//extlist, "@"//outlist, outtype=outtype, norm=norm)

	    delete (extlist, verify-)
	    delete (outlist, verify-)
	}
	fd1 = ""; delete (inlist, verify-)
end
mscred-5.05-2018.07.09/src/mscpmask.par000066400000000000000000000000641332166314300170770ustar00rootroot00000000000000input,f,a,,,,Input image
output,f,a,,,,Output image
mscred-5.05-2018.07.09/src/mscppars.par000066400000000000000000000004261332166314300171130ustar00rootroot00000000000000# PHOTPARS Parameter File

weighting,s,h,constant,"|constant|cone|gauss|",,Photometric weighting scheme for wphot
apertures,s,h,"3.",,,List of aperture radii in scale units
zmag,r,h,0.,,,Zero point of magnitude scale
mkapert,b,h,no,,,Draw apertures on the display
mode,s,h,'ql'
mscred-5.05-2018.07.09/src/mscpupil.cl000066400000000000000000000067631332166314300167450ustar00rootroot00000000000000# MSCPUPIL -- Fit and subtract the pupil image.

procedure mscpupil (input, output)

begin
	file	inlist, outlist, list, in, out
	string	inext
	int	nimages

	cache	sections, mscextensions
	inlist = mktemp ("tmp$iraf")
	outlist = mktemp ("tmp$iraf")
	list = mktemp ("tmp$iraf")

	# Get input query parameters.  Expand operand and result lists.
	sections (input, option="fullname", > inlist); 
	nimages = sections.nimages
	sections (output, option="fullname", > outlist)

	# Check for correct lists.
	if (nimages != sections.nimages && sections.nimages != 0) {
	    delete (inlist, verify-)
	    delete (outlist, verify-)
	    error (1, "Input and output lists don't match")
	}

	joinlines (inlist, outlist, output=list, delim=" ", missing="",
	    maxchars=161, shortest-, verbose-)
	delete (inlist, verify-)
	delete (outlist, verify-)

	if (verbose)
	    printf ("MSCPUPIL:\n")

	out = ""
	fd = list
	while (fscan (fd, in, out) != EOF) {
	    if (verbose) {
		if (out != "")
		    printf (" %s -> %s:\n", in, out)
		else
		    printf (" %s:\n", in)
	    }
	    mscextensions (in, output="list", index="0-",
		extname="", extver="", lindex=no, lname=yes,
		lver=no, ikparams="") | scan (inext)
	    if (mscextensions.nimages == 0) {
	    printf ("WARNING: File not found or contains no extensions (%s)\n",
		    in)
		next
	    }
	    mscextensions (in, output="file", index="0-",
		extname="", extver="", lindex=no, lname=yes,
		lver=no, ikparams="")
	    mscextensions (in, output="file", index="0-",
		extname="", extver="", lindex=no, lname=yes,
		lver=no, ikparams="", > inlist)
	    nimages = mscextensions.nimages

	    if (out == "") {
		pupilfit ("@"//inlist, "", masks=masks, lmedian=lmedian,
		    type=type, xc=xc, yc=yc, rin=rin, drin=drin, rout=rout,
		    drout=drout, funcin=funcin, orderin=orderin,
		    funcout=funcout, orderout=orderout,
		    rfunction=rfunction, rorder=rorder,
		    sfunction="chebyshev", sorder=1, niterate=niterate,
		    lreject=lreject, hreject=hreject, datamin=datamin,
		    datamax=datamax, verbose=verbose)
	    } else if (in == out) {
		pupilfit ("@"//inlist, "@"//inlist, masks=masks,
		    lmedian=lmedian, type=type, xc=xc, yc=yc, rin=rin,
		    drin=drin, rout=rout, drout=drout, funcin=funcin,
		    orderin=orderin, funcout=funcout, orderout=orderout,
		    rfunction=rfunction, rorder=rorder,
		    sfunction="chebyshev", sorder=1, niterate=niterate,
		    lreject=lreject, hreject=hreject, datamin=datamin,
		    datamax=datamax, verbose=verbose)
	    } else {
		if (imaccess (out//"[0]")) {
		    printf ("WARNING: Output %s already exists\n", out)
		    delete (inlist, verify-)
		    next
		}
		if (in != inext) {
		    for (i=1; i<=nimages; i+=1) {
			if (type == "mask")
			    print (out//"[append,inherit,type=mask]",
			        >> outlist)
			else
			    print (out//"[append,inherit]", >> outlist)
		    }
		    imcopy (in//"[0]", out, verbose-)
		} else {
		    if (type == "mask")
			print (out//"[append,inherit,type=mask]", >> outlist)
		    else
			print (out, > outlist)
		}
		pupilfit ("@"//inlist, "@"//outlist, masks=masks,
		    lmedian=lmedian, type=type, xc=xc, yc=yc, rin=rin,
		    drin=drin, rout=rout, drout=drout, funcin=funcin,
		    orderin=orderin, funcout=funcout, orderout=orderout,
		    rfunction=rfunction, rorder=rorder,
		    sfunction="chebyshev", sorder=1, niterate=niterate,
		    lreject=lreject, hreject=hreject, datamin=datamin,
		    datamax=datamax, verbose=verbose)
		delete (outlist, verify-)
	    }
	    delete (inlist, verify-)
	}
	fd = ""; delete (list, verify-)
end
mscred-5.05-2018.07.09/src/mscpupil.par000066400000000000000000000025111332166314300171140ustar00rootroot00000000000000input,s,a,,,,List of input images
output,s,a,,,,List of output images
masks,s,h,"BPM",,,List of masks
type,s,h,"difference","data|fit|difference|ratio|mask",,Output type
lmedian,b,h,no,,,Subtract line-by-line median?
xc,r,h,27.,,,Pattern center offset (pixels)
yc,r,h,9.,,,Pattern center offset (pixels)
rin,r,h,300.,0.,,Radius of inner background ring (pixels)
drin,r,h,20.,1.,,Width of inner background ring (pixels)
rout,r,h,1500.,0.,,Radius of outer background ring (pixels)
drout,r,h,20.,1.,,Width of outer background ring (pixels)
funcin,s,h,"chebyshev","chebyshev|legendre|spline1|spline3",,Inner azimuthal background fitting function
orderin,i,h,2,1,,Inner azimuthal background fitting order
funcout,s,h,"spline3","chebyshev|legendre|spline1|spline3",,Outer azimuthal background fitting function
orderout,i,h,2,1,,Outer azimuthal background fitting order
rfunction,s,h,"spline3","chebyshev|legendre|spline1|spline3",,Radial profile fitting function
rorder,i,h,40,1,,Radial profile fitting order
abin,r,h,0.,0.,,Azimuthal bin (deg)
astep,r,h,0.,0.,,Azimuthal step (deg)
niterate,i,h,3,0,,Number of rejection iterations
lreject,r,h,3.,0.,,Low rejection rms factor
hreject,r,h,3.,0.,,High rejection rms factor
datamin,r,h,INDEF,,,Minimum good data value
datamax,r,h,INDEF,,,Maximum good data value
verbose,b,h,yes,,,Print information?
fd,*struct,h
mscred-5.05-2018.07.09/src/mscqphot.cl000066400000000000000000000210621332166314300167340ustar00rootroot00000000000000# MSCQPHOT -- Quick photometric calibration from list of stars.

procedure mscqphot (input, stars, obsfiles, photconf)

string	input			{prompt="List of input mosaic files"}
string	stars			{prompt="List of star datafiles"}
string	obsfiles		{prompt="List of observation files"}
file	photconf = ""		{prompt="Photometry configuration file"}
real	scale = 0.26		{prompt="Scale in arcsec/pixel"}
string	apertures = "1,3,5"	{prompt="List of photometry apertures(arcsec)"}
string	imag = "-10 -4"		{prompt="Instrumental magnitude range"}
string	cmag1 = "15 20"		{prompt="Catalog magnitude 1 range"}
string	cmag2 = "15 20"		{prompt="Catalog magnitude 2 range"}
string	plotfile = ""		{prompt="Output metacode file"}
bool	update = yes		{prompt="Update image?"}
bool	verbose = yes		{prompt="Verbose?"}

struct	*fd1, *fd2, *fd3

begin
	file	in, star, photcf, im
	file	inlist, extlist
	file	coords, catalog, phot, apfile, aplog, applot
	file	imsets, obsfile, fitpar, lfile, temp
	string	name, filter
	int	nc, nl, nstars, nextn
	real	c, l, otime, airmass, mag, emag, mag1, mag2, seeing, eseeing
	real	imagmin, imagmax, mag1min, mag1max, mag2min, mag2max
	struct	str, photfunc

	inlist = mktemp ("tmp$iraf")
	extlist = mktemp ("tmp$iraf")
	coords = mktemp ("tmp$iraf")
	catalog = mktemp ("tmp$iraf")
	phot = mktemp ("tmp$iraf")
	apfile = mktemp ("tmp$iraf")
	aplog = mktemp ("tmp$iraf")
	applot = ""
	imsets = mktemp ("tmp$iraf")
	fitpar = mktemp ("tmp$iraf")
	lfile = mktemp ("tmp$iraf")
	temp = mktemp ("tmp$iraf")

	# Expand lists and check for number.
	sections (input, option="fullname", > inlist)
	nc = sections.nimages
	sections (stars, option="fullname") |
	joinlines (inlist, "STDIN", output=extlist, delim=" ", missing="",
	    maxch=181, shortest-, verbose-)
	delete (inlist, verify-)
	if (nc != sections.nimages && sections.nimages != 1) {
	    delete (extlist, verify-)
	    error (1, "Input list and star list do not match")
	}
	sections (obsfiles, option="fullname") |
	joinlines (extlist, "STDIN", output=inlist, delim=" ", missing="",
	    maxch=181, shortest-, verbose-)
	delete (extlist, verify-)
	if (nc != sections.nimages && sections.nimages != 1) {
	    delete (inlist, verify-)
	    error (1, "Input list and observation file list do not match")
	}

	# Get parameters and do some checking.
	photcf = photconf
	if (!access (photcf))
	    error (1,
		"Photometry configurations file not found ("//photcf//")")
	if (fscan (imag, imagmin, imagmax) != 2)
	    error (1, "Bad syntax in instrumental magnitude range")
	mag = imagmin
	imagmin = min (mag, imagmax)
	imagmax = max (mag, imagmax)
	if (fscan (cmag1, mag1min, mag1max) != 2)
	    error (1, "Bad syntax in catalog magnitude 1 range")
	mag = mag1min
	mag1min = min (mag, mag1max)
	mag1max = max (mag, mag1max)
	if (fscan (cmag2, mag2min, mag2max) != 2)
	    error (1, "Bad syntax in catalog magnitude 1 range")
	mag = mag2min
	mag2min = min (mag, mag2max)
	mag2max = max (mag, mag2max)

	if (plotfile != "")
	    set stdvdm = (plotfile)

	if (verbose) {
	    time | scan (str)
	    printf ("MSCQPHOT: %s\n", str)
	}

	fd1 = inlist
	while (fscan (fd1, in, star, obsfile) != EOF) {
	    i = strlen (in)
	    if (substr (in,i-4,i) == ".fits")
		in = substr (in,1,i-5)

	    if (verbose)
		printf ("  %s:\n", in)

	    mscextensions (in, output="file", index="1-", extname="", extver="",
		lindex-, lname+, lver-, ikparams="", > extlist)
	    nextn = mscextensions.nimages

	    fd2 = extlist
	    while (fscan (fd2, im) != EOF) {
		mscctran (star, temp, im, "world", "logical", columns="1 2",
		    units="hours native", formats="", min_sig=7, verbose=no)

		hselect (im, "extname,naxis1,naxis2", yes) |
		    scan (name,nc, nl)
		printf ("%s : %s\n", name, im, >> imsets)

		nstars = 0
		fd3 = temp
		while (fscan (fd3, c, l, mag1, mag2) != EOF) {
		    if (c < 1 || c > nc || l < 1 || l > nl)
			next
		    if (mag1 < mag1min || mag1 > mag1max)
			next
		    if (mag2 < mag2min || mag2 > mag2max)
			next
		    nstars = nstars + 1
		    printf ("%.2f %.2f %.2f %.2f\n",
			c, l, mag1, mag2, >> coords)
		    printf ("%s-%d %.2f %.2f %.2f %.2f\n",
			name, nstars, c, l, mag1, mag2, >> catalog)
		}
		fd3 = ""; delete (temp, verify-)

		if (verbose)
		    printf ("    Do photometry on %d objects in %s\n",
			nstars, im)
		phot (im, "", coords=coords, output="STDOUT", plotfile="",
		    datapars="mscdpars", centerpars="msccpars",
		    fitskypars="mscspars", photpars="mscppars",
		    interactive=no, radplots=no, verify=no, update=no,
		    verbose=no, graphics="stdgraph", display="stdimage",
		    icommands="", gcommands="",
		    scale=scale, apertures=apertures, >> phot)

		delete (coords, verify-)
	    }
	    fd2 = ""; delete (extlist, verify-)

	    if (!access (phot)) {
		delete (coords, verify-)
		delete (catalog, verify-)
		next
	    }

	    txdump (phot, "IFILTER", "yes", headers=no) | scan (filter)

	    if (verbose)
		printf ("    Compute aperture corrections\n")
	    mkapfile (phot, 3, apfile, smallap=1, largeap=0, magfile="",
		logfile=aplog, plotfile=applot, obsparams="",
		obscolumns="2 3 4 5", append=no, maglim=0.1, nparams=3,
		swings=1.2, pwings=0.1, pgauss=0.5, rgescale=0.9,
		xwings=0., interactive=no, verify=no, gcommands="",
		graphics="stdgraph")
	    if (nextn > 4) {
		i = nextn - 2
		printf ("%d-%d\n", 3, i) | scan (str)
	    } else if (nextn > 2) {
		i = nextn - 1
		printf ("%d-%d\n", 2, i) | scan (str)
	    } else
		printf ("%d-%d\n", 1, nextn) | scan (str)
	    match ("    "//in, aplog, stop-, print+, meta+) |
		sort ("STDIN", column=2, numeric+, ignore+, reverse-) |
		fields ("STDIN", 2, lines=str, quit-, print-) |
		average ("STDIN") | scan (seeing, eseeing)
	    seeing = 2 * seeing
	    eseeing = 2* eseeing
	    if (verbose) {
		fd2 = apfile
		while (fscan (fd2, name, str) != EOF) {
		    if (nscan() < 2)
			next
		    if (name == "#")
			next
		    printf ("      %s %s\n", name, str)
		}
		fd2 = ""
	    }

	    if (access (obsfile))
		delete (obsfile, verify-)
	    mkobsfile (phot, filter, obsfile, imsets=imsets,
		obsparams="", obscolumns="2 3 4 5", minmagerr=0.001,
		shifts="", apercors=apfile, aperture=1, tolerance=5.,
		allfilters=no, verify=no, verbose=no)
	    delete ("f"//obsfile//".dat", verify-)

	    rename (obsfile, temp, field="all")
	    fd2 = temp
	    fd3 = catalog
	    while (fscan (fd2,name,filter,otime,airmass,c,l,mag,emag) != EOF) {
		if (nscan() < 8)
		    next
		if (fscan (fd3, name, c, l, mag1, mag2) == EOF)
		    break
		if (mag < imagmin || mag > imagmax)
		    next
	    printf ("%-12s %-12s %6.1f %6.1f %6.3f %6.3f %6.3f %6.3f %6.3f\n",
		    name, in, c, l, airmass, mag, emag, mag1, mag2,
		    >> obsfile)
	    }
	    fd2 = ""; delete (temp, verify-)
	    fd3 = ""

	    if (verbose)
		printf ("    Fit photometric zero point\n")
	    if (plotfile == "")
		fitparams (obsfile, "", photcf, fitpar,
		    weighting="uniform", addscatter=yes,
		    tolerance=3.0000000000000E-5, maxiter=15, nreject=3,
		    low_reject=2., high_reject=2., grow=0., interactive=no,
		    logfile=lfile, log_unmatche=no, log_fit=yes,
		    log_results=no, catdir="", graphics="stdvdm", cursor="")
	    else {
		printf ("h\nq\n", > temp)
		fitparams (obsfile, "", photcf, fitpar,
		    weighting="uniform", addscatter=yes,
		    tolerance=3.0000000000000E-5, maxiter=15, nreject=3,
		    low_reject=2., high_reject=2., grow=0., interactive=yes,
		    logfile=lfile, log_unmatche=no, log_fit=yes,
		    log_results=no, catdir="", graphics="stdvdm",
		    cursor=temp, < "dev$null", > "dev$null")
		delete (temp, verify-)
	    }

	    match ("PHOTFUNC", photcf, stop-, print+, meta+) |
		scan (name, name, photfunc)
	    match ("photzero", photcf, stop-, print+, meta+) |
		scan (name, name, name, mag1)
	    match ("photcor", lfile, stop-, print+, meta+, > temp)
		tail (temp, nl=1) | scan (name, mag, emag)
	    delete (temp, verify-)

	    if (verbose) {
		printf ("      SEEING   = %.3g (%.3g)\n", seeing, eseeing)
		printf ("      PHOTFUNC = %s\n", photfunc)
		printf ("      PHOTZERO = %g\n", mag1)
		printf ("      PHOTCOR  = %.3g (%.3g)\n", mag, emag)
	    }

	    if (update) {
		printf ("Seeing (arcsec) +-%.3g\n", eseeing) | scan (str)
		addkey (in//"[0]", "SEEING", seeing, str, type="c")
		addkey (in//"[0]", "PHOTFUNC", photfunc, "", type="c")
		addkey (in//"[0]", "PHOTZERO", mag1,
		    "Expected zero point magnitude", type="r")
		printf ("Zeropoint correction +-%.3g\n", emag) | scan (str)
		addkey (in//"[0]", "PHOTCOR", mag, str, type="r")
	    }

	    delete (catalog, verify-)
	    delete (phot, verify-)
	    delete (apfile, verify-)
	    delete (aplog, verify-)
	    #delete (applot, verify-)
	    delete (fitpar, verify-)
	    delete (lfile, verify-)
	}
	fd1 = ""; delete (inlist, verify-)
end
mscred-5.05-2018.07.09/src/mscrfits.cl000066400000000000000000000013471332166314300167340ustar00rootroot00000000000000# MSCRFITS -- Read Mosaic FITS files from tape.

procedure mscrfits (input, output)

string	input		{prompt="Input tape"}
string	output		{prompt="Output file(s)"}
string	tapefiles = "1-"{prompt="Tape file list"}
bool	listonly = no	{prompt="List only?"}
bool	shortlist = yes	{prompt="Short listing?"}
bool	longlist = no	{prompt="Long listing?"}
int	offset = 0	{prompt="Offset for numbering of output disk filenames"}
bool	original = yes	{prompt="Restore original file name?"}

begin
	string	out

	if (listonly)
	    out = ""
	else
	    out = output

	mscred.fitscopy (input, out, listonly=listonly, shortlist=shortlist,
	    longlist=longlist, extn="fits", offset=offset, original=original,
	    intape=yes, outtape=no, tapefiles=tapefiles)
end
mscred-5.05-2018.07.09/src/mscselect.cl000066400000000000000000000007131332166314300170600ustar00rootroot00000000000000# MSCSELECT -- Image header selection on multiextension Mosaic files.

procedure mcsselect (images, fields)

string	images			{prompt="images for selection"}
string	fields			{prompt="fields to be extracted"}
string	expr = "yes"		{prompt="boolean selection expression"}
string	extnames = ""		{prompt="extension names"}

begin
	struct	cmd

	printf ('"hselect $input %s "%s""\n', fields, expr) | scan (cmd)
	msccmd (cmd, images, extname=extnames, verbose=no)
end
mscred-5.05-2018.07.09/src/mscsetwcs.cl000066400000000000000000000051421332166314300171120ustar00rootroot00000000000000# MSCSETWCS -- Set the Mosaic WCS from a database and RA/Dec header keywords.
#
# If no database is specified (a value of "") then only the CRVAL are updated.

procedure mscsetwcs (images, database)

string	images			{prompt="Mosaic images"}
file	database = ""		{prompt="WCS database"}
string	ra = "ra"		{prompt="Right ascension keyword (hours)"}
string	dec = "dec"		{prompt="Declination keyword (degrees)"}
string	equinox = "equinox"	{prompt="Epoch keyword (years)"}
real	ra_offset = 0.		{prompt="RA offset (arcsec)"}
real	dec_offset = 0.		{prompt="Dec offset (arcsec)"}

struct	*extlist

begin
	file	db, inlist, image, logf
	string	ims, extname, str
	real	raval, decval, eqval
	bool	verbose
	struct	wcsastrm

	cache mscextensions

	ims = images
	db = database
	if (logfile == "") {
	    logf = "dev$null"
	    verbose = no
	} else {
	    logf = logfile
	    verbose = yes
	}

	raval = 0.
	decval = 0.

	inlist = mktemp ("tmp$iraf")
	mscextensions (ims, output="file", index="0-", extname="",
	    extver="", lindex=no, lname=yes, lver=no, ikparams="", > inlist)

	extlist = inlist
	while (fscan (extlist, image) != EOF) {
	    if (db != "") {
		match ("WCSASTRM", db, stop-) | scan (str, str, str, wcsastrm)
		if (nscan() > 3)
		    hedit (image, "WCSASTRM", wcsastrm, add+,
			del-, verify-, show-, update+)

		extname = ""
		hselect (image, "extname", yes) | scan (extname)
		if (extname == "")
		    match ("begin", db, stop-) | scan (extname, extname)
		ccsetwcs (image, db, extname, xref=INDEF, yref=INDEF,
		    xmag=INDEF, ymag=INDEF, xrotation=INDEF, yrotation=INDEF,
		    lngref=INDEF, latref=INDEF, lngunits="", latunits="",
		    transpose=no, projection="tan", coosystem="j2000",
		    update=yes, verbose=verbose) |
			match ("hours", "STDIN", stop+) |
			match ("Updating", "STDIN", stop+, >> logf)
		hedit (image, "WCSSOL", add-, del+, verify-, show-, update+)
	    }

	    hselect (image, ra//","//dec//","//equinox, yes) |
		translit ("STDIN", '"', delete+, collapse-) |
		scan (raval, decval, eqval)
	    if (nscan() < 3)
		eqval = 2000.
	    if (nscan() >= 2) {
		if (eqval != 2000.) {
		    printf ("%g %g\n", raval, decval) |
		    precess ("STDIN", eqval, 2000.) |
		    scan (raval, decval)
		}
		decval = decval + dec_offset / 3600.
		raval = raval * 15. + ra_offset / 3600. /
		    cos (decval/57.29577851) 
		hedit (image, "crval1", raval, add+, del-, update+,
		    show-, verify-)
		hedit (image, "crval2", decval, add+, del-, update+,
		    show-, verify-)
		if (verbose)
	    printf ("    Reference point: %.2H %.1h 2000.0 (hours degrees)\n",
			raval, decval, >> logf)
	    }
	}
	extlist = ""; delete (inlist, verify=no)
end
mscred-5.05-2018.07.09/src/mscshutcor.cl000066400000000000000000000072651332166314300173010ustar00rootroot00000000000000# MSCSHUTCOR - Calculate the shutter correction for a mosaic detector given
# a sequence of overscan corrected flats of varying durations.  The
# shutter correction is the intercept on a plot of exposure duration
# versus exposure level.  Notion courtesy Phil Massey.
#
# This is a revision on the OBSUTIL.SHUTCOR task that works with mosaic
# MEF files.  Note that this version will also work with simple images.
# When there are multiple extensions the photometric measurements are
# averaged to obtain a mean value over all the extensions.  This takes
# care of different gains in the extensions provided the relative gains
# are the same in all exposures.

procedure mscshutcor (images)

string	images			{prompt="Overscan corrected images"}
string	extnames = ""		{prompt="Extension names"}
string	section	= ""		{prompt="Image section for statistics"}
string	center	= "mode"	{prompt="Central statistical measure",
				    enum="mean|midpt|mode"}
int	nclip = 3		{prompt="Number of clipping iterations"}
real	lsigma = 4		{prompt="Lower clipping sigma factor"}
real	usigma = 4		{prompt="Upper clipping sigma factor"}
string	exposure = "exptime"	{prompt="Header keyword for the exposure time"}
bool	verbose	= yes		{prompt="Verbose output?"}

string	*list

begin
	string	limages, img, im1, imglist, statlist, explist, tmplist
	int	nims
	real	exp, avg, shutcorr, shutcorr_err
	real	slope, slope_err, intercept, intercept_err
	int	nstat, nexp, junk
	struct	tmp

	cache sections

	limages = images

	imglist = mktemp ("tmp$tmp")
	statlist = mktemp ("tmp$tmp")
	explist = mktemp ("tmp$tmp")
	tmplist = mktemp ("tmp$tmp")

	sections (limages, option="fullname", > imglist)
	nims = 0
	list = imglist
	while (fscan (list, img, exp, tmp) != EOF) {
	    mscextensions (img//section, output="file", index="0-",
		extname=extnames, extver="", lindex=no, lname=yes,
		lver=no, ikparams="", > tmplist)
	    im1 = ""
	    head (tmplist, nlines=1) | scan (im1)
	    if (im1 == "") {
		delete (tmplist, ver-, >& "dev$null")
		next
	    }

	    tmp = ""
	    hselect (im1, exposure//",overscan", yes) | scan (exp, tmp)
	    if (tmp == "") {
		printf ("%s is not overscan corrected!\n", img)
		delete (imglist, ver-, >& "dev$null")
		delete (tmplist, ver-, >& "dev$null")
		return
	    }
	    if (exp <= 0) {
		printf ("%s has zero exposure time!\n", img)
		delete (imglist, ver-, >& "dev$null")
		delete (tmplist, ver-, >& "dev$null")
		return
	    }
	    tmp = ""
	    hselect (im1, "flatcor", yes) | scan (tmp)
	    if (tmp != "")
		printf ("%s is flat fielded\n", img)
	    imstatistics ("@"//tmplist, fields=center,
		lower=INDEF, upper=INDEF, nclip=nclip, lsigma=lsigma,
		usigma=usigma, binwidth=0.1, format-) |
		average | scan (avg)
	    printf ("%g	%g\n", exp, avg, >> statlist)
	    nims = nims + 1
	    delete (tmplist, ver-, >& "dev$null")
	}
	list = ""; delete (imglist, verify-)

	if (!access (statlist))
	    error (1, "No images selected\n")
	else if (nims < 4)
	    error (1, "Not enough images\n")

	polyfit (statlist, 1, weighting="uniform", verbose=verbose,
	    listdata-, > tmplist)
	delete (statlist, verify-)

	list = tmplist
	junk = fscan (list, intercept, slope)
	junk = fscan (list, intercept_err, slope_err)
	list = ""

	shutcorr = intercept / slope
	shutcorr_err = abs (shutcorr) *
	    sqrt ((intercept_err/intercept)**2 + (slope_err/slope)**2)

	if (verbose)
	    printf ("\n")

	printf ("Shutter correction = %.3f +/- %.3f seconds\n",
	    shutcorr, shutcorr_err)

	if (verbose) {
	    printf ("\nInformation about the %s versus %s fit:\n\n",
		center, exposure)
	    printf ("       intercept        slope     (and errors)\n")
	    printf ("!sed 's+^+    +' %s\n", osfn(tmplist)) | cl
	    printf ("\n")
	}

	delete (tmplist, ver-, >& "dev$null")
end
mscred-5.05-2018.07.09/src/mscskysub.par000066400000000000000000000020601332166314300173020ustar00rootroot00000000000000# IMSURFIT

input,f,a,,,,Input images to be fit
output,f,a,,,,Output images
xorder,i,a,2,1,,Order of function in x
yorder,i,a,2,1,,Order of function in y
type_output,s,h,'residual',,,'Type of output (fit,residual,response,clean)'
function,s,h,'leg',,,'Function to be fit (legendre,chebyshev,spline3)'
cross_terms,b,h,y,,,Include cross-terms for polynomials?
xmedian,i,h,100,1,,X length of median box
ymedian,i,h,100,1,,Y length of median box
median_percent,r,h,50.,,,Minimum fraction of pixels in median box
lower,r,h,0.0,0.0,,Lower limit for residuals
upper,r,h,0.0,0.0,,Upper limit for residuals
ngrow,i,h,0,0,,Radius of region growing circle
niter,i,h,0,0,,Maximum number of rejection cycles
regions,s,h,'mask',,, 'Good regions (all,rows,columns,border,sections,circle,invcircle,mask)'
rows,s,h,'*',,,Rows to be fit
columns,s,h,'*',,,Columns to be fit
border,s,h,'50',,,Width of border to be fit
sections,s,h,,,,File name for sections list
circle,s,h,,,,Circle specifications
mask,s,h,"BPM",,,Mask
div_min,r,h,INDEF,,,Division minimum for response output
mode,s,h,'ql'
mscred-5.05-2018.07.09/src/mscspars.par000066400000000000000000000016221332166314300171150ustar00rootroot00000000000000# SKY FITTING PARAMETERS

salgorithm,s,h,"centroid","|median|mode|centroid|gauss|crosscor|ofilter|histplot|radplot|constant|file|mean|",,Sky fitting algorithm
annulus,r,h,5.0,,,Inner radius of sky annulus in scale units
dannulus,r,h,5.0,,,Width of sky annulus in scale units
skyvalue,r,h,0.0,,,User sky value
smaxiter,i,h,10,,,Maximum number of sky fitting iterations
sloclip,r,h,0.0,,,Lower clipping factor in percent
shiclip,r,h,0.0,,,Upper clipping factor in percent
snreject,i,h,50,,,Maximum number of sky fitting rejection iterations
sloreject,r,h,3.0,,,Lower K-sigma rejection limit in sky sigma
shireject,r,h,3.0,,,Upper K-sigma rejection limit in sky sigma
khist,r,h,3.0,,,Half width of histogram in sky sigma
binsize,r,h,0.10,,,Binsize of histogram in sky sigma
smooth,b,h,no,,,Boxcar smooth the histogram
rgrow,r,h,0.0,,,Region growing radius in scale units
mksky,b,h,no,,,Mark sky annuli on the display
mscred-5.05-2018.07.09/src/mscsplit.cl000066400000000000000000000050171332166314300167360ustar00rootroot00000000000000# MSCSPLIT -- Split an MEF file into separate images.
# This routine stores the extension name for use with MSCJOIN.

procedure mscsplit (input)

string	input			{prompt="List of input MEF files"}
string	output = ""		{prompt="List of output root names"}
string	mefext = ".fits"	{prompt="MEF filename extension"}
bool	delete = no		{prompt="Delete MEF file after splitting?"}
bool	verbose = no		{prompt="Verbose?"}

struct	*fd1, *fd2

begin
	file	inlist, extlist, in, out, inext, outext
	int	index, extver
	struct	extname	

	# Temporary files.
	inlist = mktemp ("tmp$iraf")
	extlist = mktemp ("tmp$iraf")

	# Expand input and output lists.  Allow missing or short output list.
	sections (input, option="fullname", > extlist)
	sections (output, option="fullname") | joinlines (extlist, "STDIN",
	    output=inlist, delim=" ", missing="", maxchars=161,
	    shortest-, verbose-)
	delete (extlist, verify-)

	# Split each input.
	fd1 = inlist
	while (fscan (fd1, in, out) != EOF) {
	    # If no output rootname is given use the input name.
	    if (nscan() == 1)
		out = in

	    # Strip the mefext if present.
	    index = strlen (out) - strlen (mefext) + 1
	    if (substr (out, index, 1000) == mefext)
		out = substr (out, 1, index-1)

	    # Check for the existance of the input and output.
	    if (!imaccess (in//"[0]")) {
		printf ("WARNING: Can't access input (%s)\n", in)
		next
	    }
	    if (imaccess (out//"_1")) {
		printf ("WARNING: Output already exists (%s_*)\n", out)
		next
	    }

	    # Expand the extensions.
	    mscextensions (in, output="file", index="", extname="", extver="",
		lindex=no, lname=yes, lver=no, ikparams="", > extlist)
	    if (mscextensions.nimages == 0) {
		printf ("WARNING: No extensions found (%s)\n", in)
		delete (extlist, verify-)
		next
	    }

	    # Copy the primary HDU.
	    imcopy (in//"[0]", out//"_0", verbose=verbose)

	    # Split the extensions.
	    index = 0
	    fd2 = extlist
	    while (fscan (fd2, inext) != EOF) {
		index = index + 1
		outext = out // "_" // index
		imcopy (inext, outext, verbose=verbose)

		# Set the extname/extver so that output images can be
		# joined later.
		hselect (inext, "extname", yes) | scan (extname)
		if (extname != "")
		    hedit (outext, "extnm", extname, add+,
			del-, verify-, show-, update+)
		hselect (inext, "extver", yes) | scan (extver)
		if (nscan() == 1)
		    hedit (outext, "extvr", extver, add+,
			del-, verify-, show-, update+)
	    }
	    fd2 = ""; delete (extlist, verify-)

	    if (delete)
		imdelete (in, verify-)
	}
	fd1 = ""; delete (inlist, verify-)
end
mscred-5.05-2018.07.09/src/mscstack.cl000066400000000000000000000013161332166314300167060ustar00rootroot00000000000000# MSCSTACK -- Stack dithered images.

procedure mscstack

begin
	combine (input, output, headers=headers, bpmasks=bpmasks,
	    rejmasks=rejmasks, nrejmasks=nrejmasks, expmasks=expmasks,
	    sigmas=sigmas, imcmb="$I", ccdtype="", amps=no, subsets=no,
	    delete=no, combine=combine, reject=reject, project=no,
	    outtype="real", outlimits="", offsets="wcs", masktype=masktype,
	    maskvalue=maskvalue, blank=blank, scale=scale, zero=zero,
	    weight=weight, statsec=statsec, lthreshold=lthreshold,
	    hthreshold=hthreshold, nlow=nlow, nhigh=nhigh, nkeep=nkeep,
	    mclip=mclip, lsigma=lsigma, hsigma=hsigma, rdnoise=rdnoise,
	    gain=gain, snoise=snoise, sigscale=sigscale, pclip=pclip,
	    grow=grow)

end
mscred-5.05-2018.07.09/src/mscstack.par000066400000000000000000000031361332166314300170740ustar00rootroot00000000000000input,s,a,,,,"List of images to combine"
output,s,a,,,,"Output image"
headers,s,h,"",,,List of header files (optional)
bpmasks,s,h,"",,,List of bad pixel masks (optional)
rejmasks,s,h,"",,,List of rejection masks (optional)
nrejmasks,s,h,"",,,List of number rejected masks (optional)
expmasks,s,h,"",,,List of exposure masks (optional)
sigmas,s,h,"",,,"List of sigma images (optional)
"
combine,s,h,"median",average|median,,"Type of combine operation (median|average)"
reject,s,h,"none",none|minmax|ccdclip|crreject|sigclip|avsigclip|pclip,,"Type of rejection"
masktype,s,h,"none",,,"Mask type"
maskvalue,r,h,0.,,,"Mask value"
blank,r,h,0.,,,"Value if there are no pixels
"
scale,s,h,"none",,,"Image scaling"
zero,s,h,"none",,,"Image zero point offset"
weight,s,h,"none",,,"Image weights"
statsec,s,h,"",,,"Image section for computing statistics
"
lthreshold,r,h,1.,,,"Lower threshold"
hthreshold,r,h,INDEF,,,"Upper threshold"
nlow,i,h,1,0,,"minmax: Number of low pixels to reject"
nhigh,i,h,1,0,,"minmax: Number of high pixels to reject"
nkeep,i,h,1,,,"Minimum to keep (pos) or maximum to reject (neg)"
mclip,b,h,yes,,,"Use median in sigma clipping algorithms?"
lsigma,r,h,3.,0.,,"Lower sigma clipping factor"
hsigma,r,h,3.,0.,,"Upper sigma clipping factor"
rdnoise,s,h,"0.",,,"ccdclip: CCD readout noise (electrons)"
gain,s,h,"1.",,,"ccdclip: CCD gain (electrons/DN)"
snoise,s,h,"0.",,,"ccdclip: Sensitivity noise (fraction)"
sigscale,r,h,0.1,0.,,"Tolerance for sigma clipping scaling corrections"
pclip,r,h,-0.5,,,"pclip: Percentile clipping parameter"
grow,r,h,0.,0.,,"Radius (pixels) for neighbor rejection"
mode,s,h,"ql",,,
mscred-5.05-2018.07.09/src/mscstat.cl000066400000000000000000000047251332166314300165630ustar00rootroot00000000000000# MSCSTAT -- Image statistcs on multiextension Mosaic files.

procedure mcsstat (images)

string	images		{prompt="Images"}
string	extname = ""	{prompt="Extension name selection\n"}

bool	usemask = no	{prompt="Use mask in BPM keyword?"}
bool	gmode = no	{prompt="Global mode statistics?"}
string	fields = "image,npix,mean,stddev,min,max" {prompt="Fields to be printed"}
real	lower = INDEF	{prompt="Lower cutoff for pixel values"}
real	upper = INDEF	{prompt="Upper cutoff for pixel values"}
int	nclip = 0	{prompt="Number of clipping iterations"}
real	lsigma = 3.	{prompt="Lower clipping factor in sigma"}
real	usigma = 3.	{prompt="Upper clipping factor in sigma"}
real	binwidth = 0.1	{prompt="Bin width of histogram in sigma"}
bool	format = yes	{prompt="Format output and print column labels?\n"}

struct	*fd1, *fd2

begin
	int	i, nmode
	real	bmode[20], cmode
	file	image, mask, extn
	file	list1, list2
	bool	fmt

	list1 = mktemp ("tmp$iraf")
	list2 = mktemp ("tmp$iraf")

	sections (images, option="fullname", > list1)
	fd1 = list1

	if (gmode) {
	    while (fscan (fd1, image) != EOF) {
		printf ("%s ", image)

		mscextensions (image, output="file", index="0-",
		    extname=extname, extver="", lindex=no, lname=yes,
		    lver=no, ikparams="", >> list2)

		cmode = 0.0
		nmode = 0
		fd2 = list2
		while (fscan (fd2, extn) != EOF) {
		    nmode = nmode+1
		    if (usemask)
		        hselect (extn, "BPM", yes) | scan (mask)
		    else
		        mask = ""
		    mimstat (extn, imasks=mask, omasks="", fields="mode",
		        lower=lower, upper=upper, nclip=nclip, lsigma=lsigma,
			usigma=usigma, binwidth=binwidth, format=no) |
			scan(bmode[nmode])
		    cmode = cmode + bmode[nmode]
		}
		fd2 = ""; delete (list2, verify-)

		cmode = cmode / nmode
		printf ("%10.3f", cmode)
		for (i=1; i<=nmode; i+=1)
		    printf (" %6.3f", bmode[i]/cmode)
		printf ("\n")
	    }

	} else {
	    fmt = format
	    while (fscan (fd1, image) != EOF) {
		mscextensions (image, output="file", index="0-",
		    extname=extname, extver="", lindex=no, lname=yes,
		    lver=no, ikparams="", >> list2)

		fd2 = list2
		while (fscan (fd2, extn) != EOF) {
		    if (usemask)
		        hselect (extn, "BPM", yes) | scan (mask)
		    else
		        mask = ""
		    mimstat (extn, imasks=mask, omasks="", fields=fields,
		        lower=lower, upper=upper, nclip=nclip, lsigma=lsigma,
			usigma=usigma, binwidth=binwidth, format=fmt)
		    fmt = no
		}
		fd2 = ""; delete (list2, verify-)
	    }
	}

	fd1 = ""; delete (list1, verify-)
end
mscred-5.05-2018.07.09/src/msctemplate.par000066400000000000000000000003541332166314300176010ustar00rootroot00000000000000input,s,a,,,,List of input images
output,f,a,,,,Output template image
reference,f,h,,,,Reference image
blank,r,h,0,,,Blank value
border,i,h,0,0,,Border size
projection,s,h,"",,,WCS projection
pixtype,s,h,"real","short|real",,Pixel type
mscred-5.05-2018.07.09/src/msctmp1.cl000066400000000000000000000005521332166314300164630ustar00rootroot00000000000000if (fmedian)
    fmedian (input, output, xwindow, ywindow, zloreject=zloreject,
	zhireject=zhireject, boundary=boundary, constant=constant,
	verbose=verbose, hmin=hmin, hmax=hmax, zmin=zmin, zmax=zmax, unmap=yes)
else
    median (input, output, xwindow, ywindow, zloreject=zloreject,
	zhireject=zhireject, boundary=boundary, constant=constant,
	verbose=verbose)
mscred-5.05-2018.07.09/src/msctmp1.par000066400000000000000000000013741332166314300166520ustar00rootroot00000000000000# Parameters for the MSCTMP1 task

input,f,a,,,,Input images to be filtered
output,f,a,,,,Output images
xwindow,i,h,,,,X window size of median filter
ywindow,i,h,,,,Y window size of median filter
zloreject,r,h,INDEF,,,Lowside pixel value cutoff
zhireject,r,h,INDEF,,,High side pixel value cutoff
boundary,s,h,'nearest',,,'Boundary (constant,nearest,reflect,wrap)'
constant,r,h,0,,,Constant for boundary extension
verbose,b,h,yes,,,Print messages about actions taken by the task

fmedian,b,h,yes,,,Use fast median algorithm?
hmin,i,h,-32768,,,Minimum histogram bin
hmax,i,h,32767,,,Maximum histogram bin
zmin,r,h,INDEF,,,Pixel value corresponding to hmin
zmax,r,h,INDEF,,,Pixel value corresponding to hmax
unmap,b,h,yes,,,Unmap the digitized values ?
mode,s,h,'ql'
mscred-5.05-2018.07.09/src/msctools/000077500000000000000000000000001332166314300164205ustar00rootroot00000000000000mscred-5.05-2018.07.09/src/msctools/corner.dat000066400000000000000000000013601332166314300204020ustar00rootroot00000000000000amp111 2048    1 amp113    1    1 dec
amp111 2048 4096 amp113    1 4096 dec
amp113 2048    1 amp211    1    1 dec
amp113 2048 4096 amp211    1 4096 dec
amp211 2048    1 amp213    1    1 dec
amp211 2048 4096 amp213    1 4096 dec
amp322 2048    1 amp324    1    1 dec
amp322 2048 4096 amp324    1 4096 dec
amp324 2048    1 amp422    1    1 dec
amp324 2048 4096 amp422    1 4096 dec
amp422 2048    1 amp424    1    1 dec
amp422 2048 4096 amp424    1 4096 dec
amp111    1 4096 amp322    1    1 ra
amp111 2048 4096 amp322 2048    1 ra
amp113    1 4096 amp324    1    1 ra
amp113 2048 4096 amp324 2048    1 ra
amp211    1 4096 amp422    1    1 ra
amp211 2048 4096 amp422 2048    1 ra
amp213    1 4096 amp424    1    1 ra
amp213 2048 4096 amp424 2048    1 ra
mscred-5.05-2018.07.09/src/msctools/cwcs.cl000066400000000000000000000024711332166314300177030ustar00rootroot00000000000000# CWCS -- Modify coordinates with a shift, scale, and rotation.

procedure cwcs (input, output, image, rashift, decshift, scale, rotation)

file	input		{prompt="Input coordinates"}
file	output		{prompt="Output coordinates"}
file	image		{prompt="Image with WCS"}
real	rashift = 0.	{prompt="RA shift (arcsec)"}
real	decshift = 0.	{prompt="DEC shift (arcsec)"}
real	scale = 1.	{prompt="Scale"}
real	rotation = 0.	{prompt="Rotation (deg)"}

struct	*fd

begin
	file	in, out, im, temp
	real	ras, decs, scl, rot, cost, sint, x1, x2, y1, y2
	struct	str

	temp = mktemp ("tmp$iraf")

	# Get query parameters.
	in = input
	out = output
	im = image
	ras = rashift
	decs = decshift
	scl = scale
	rot = rotation

	cost = scl * cos (rot * 3.14159 / 180.)
	sint = scl * sin (rot * 3.14159 / 180.)

	mscctran (in, temp, im, "world", "astrometry", columns="1 2",
	    units="hours native", formats="", min_sigdigit=9, verbose=no)

	fd = temp
	while (fscan (fd, x1, y1, str) != EOF) {
	    x2 = x1 * cost + y1 * sint - ras
	    y2 = -x1 * sint + y1 * cost - decs
	    printf ("%g %g %s\n", x2, y2, str, >> out)
	}
	fd = ""; delete (temp, verify-)

	rename (out, temp, field="all")
	mscctran (temp, out, im, "astrometry", "world", columns="1 2",
	    units="native native", formats="%.2H %.h", min_sigdigit=9,
	    verbose=no)

	delete (temp, verify-)
end
mscred-5.05-2018.07.09/src/msctools/fmtastrom.cl000066400000000000000000000066631332166314300207670ustar00rootroot00000000000000# FMTASTROM -- Format data for KTM from WCS of astrometry images.

procedure fmtastrom (input)

string	input			{prompt="List of mosaic exposures"}
string	field			{prompt="Astrometry field"}
string	author			{prompt="Author of astrometry solution"}
string	date			{prompt="Date of solution"}

struct	*fd

begin
	file	in, inlist
	struct	obsid, filter, extname, telescop, value
	string	key

	inlist = mktemp ("tmp$iraf")

	imextensions (input, output="file", index="1-", extname="",
	    extver="", lindex+, lname-, lver-, ikparams="", > inlist)

	fd = inlist
	while (fscan (fd, in) != EOF) {
	    hselect (in, "obsid", yes) | scan (obsid)
	    hselect (in, "filter", yes) | scan (filter)
	    #hselect (in, "extname", yes) | scan (extname)
	    hselect (in, "imageid", yes) | scan (extname)
	    extname = "ccd" // extname
	    telescop = substr (obsid, 1, stridx(".",obsid)-1)
	    print (filter) |
		translit ("STDIN", "^0-9a-zA-Z\n", "_", delete-, collapse-) |
		scan (value)
	    printf ("%s,%s,%s\n", telescop, value, extname) | scan (key)

	    printf ("set WCSASTRM(%s) \\\n          {%s (%s %s) by %s %s}\n",
		key, obsid, field, filter, author, date)
	    hselect (in, "CTYPE1", yes) | scan (value)
	    printf ("set CTYPE1(%s) %s\n", key, value)
	    hselect (in, "CTYPE2", yes) | scan (value)
	    printf ("set CTYPE2(%s) %s\n", key, value)
	    hselect (in, "CRPIX1", yes) | scan (value)
	    printf ("set CRPIX1(%s) %s\n", key, value)
	    hselect (in, "CRPIX2", yes) | scan (value)
	    printf ("set CRPIX2(%s) %s\n", key, value)
	    hselect (in, "CD1_1", yes) | scan (value)
	    printf ("set CD1_1(%s) %s\n", key, value)
	    hselect (in, "CD2_2", yes) | scan (value)
	    printf ("set CD2_2(%s) %s\n", key, value)
	    hselect (in, "CD1_2", yes) | scan (value)
	    printf ("set CD1_2(%s) %s\n", key, value)
	    hselect (in, "CD2_1", yes) | scan (value)
	    printf ("set CD2_1(%s) %s\n", key, value)
	    hselect (in, "WAT0_001", yes) | scan (value)
	    printf ("set WAT01(%s) {%s}\n", key, value)
	    hselect (in, "WAT1_001", yes) | scan (value)
	    printf ("set WAT11(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT1_002", yes) | scan (value)
	    printf ("set WAT12(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT1_003", yes) | scan (value)
	    printf ("set WAT13(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT1_004", yes) | scan (value)
	    printf ("set WAT14(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT1_005", yes) | scan (value)
	    printf ("set WAT15(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT1_006", yes) | scan (value)
	    if (value != "")
		printf ("set WAT16(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT2_001", yes) | scan (value)
	    printf ("set WAT21(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT2_002", yes) | scan (value)
	    printf ("set WAT22(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT2_003", yes) | scan (value)
	    printf ("set WAT23(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT2_004", yes) | scan (value)
	    printf ("set WAT24(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT2_005", yes) | scan (value)
	    printf ("set WAT25(%s) \\\n          {%-68s}\n", key, value)
	    hselect (in, "WAT2_006", yes) | scan (value)
	    if (value != "")
		printf ("set WAT26(%s) \\\n          {%-68s}\n", key, value)

	    printf ("\n")
	}
	fd = ""; delete (inlist, verify-)
end
mscred-5.05-2018.07.09/src/msctools/gaps.cl000066400000000000000000000036621332166314300177010ustar00rootroot00000000000000procedure gaps (image)

string	image				{prompt="Image"}
file	results = "STDOUT"		{prompt="Results file"}
file	gaps = "msctools$gaps.dat"	{prompt="Gaps data file"}
real	pixscale = 0.259		{prompt="Pixel scale (arcsec/pixel)"}
real	mmscale = 0.015			{prompt="Physical scale (mm/pixel)"}
real	xrotation = 90.			{prompt="Rotation of ra axis from x"}
real	yrotation = 270.		{prompt="Rotation of dec axis from x"}
bool	verbose = yes			{prompt="Verbose?"}

struct	*fd

begin
	file	im, out
	string	name, ext1, ext2
	struct	time
	real	cx, sx, cy, sy
	real	x1, y1, x2, y2, ra1, dec1, ra2, dec2
	real	secgap, pixgap, mmgap

	im = image
	out = results
	cx = cos (xrotation * 3.14159 / 180.)
	sx = sin (xrotation * 3.14159 / 180.)
	cy = cos (yrotation * 3.14159 / 180.)
	sy = sin (yrotation * 3.14159 / 180.)

	if (verbose) {
	    name = envget ("userid")
	    time | scan (time)
	    printf ("Mosaic statistics prepared by %s on %s\n",
		name, time, >> out)
	    printf ("  Image = %s, pixel scale = %.4g, xrotation = %.4g, yrotation = %.4g\n",
		im, pixscale, xrotation, yrotation, >> out)
	}
	printf ("\n  Gaps:%44tarcsec  pixel     mm\n", >> out)

	fd = gaps
	while (fscan (fd, ext1, x1, y1, ext2, x2, y2) != EOF) {
	    print (x1, y1) |
	    mscctran ("STDIN", "STDOUT", im//"["//ext1//"]", yes,
		xcolumn=1, ycolumn=2, lngformat="", latformat="",
		min_sigdigit=7) | scan (ra1, dec1)
	    print (x2, y2) |
	    mscctran ("STDIN", "STDOUT", im//"["//ext2//"]", yes,
		xcolumn=1, ycolumn=2, lngformat="", latformat="",
		min_sigdigit=7) | scan (ra2, dec2)
	    ra1 = 3600. * 15. * (ra2-ra1) * cos ((dec1+dec2)*3.14159/360.)
	    dec1 = 3600. * (dec2-dec1)
	    ra2 = ra1 * cx + dec1 * sy
	    dec2 = -ra1 * sx + dec1 * cy
	    secgap = max (abs (ra2), abs (dec2))
	    pixgap = secgap / pixscale
	    mmgap = secgap / pixscale * mmscale
	    printf ("  %s[%d,%d] - %s[%d,%d]: %44t%6.1f %6.1f %6.2f\n",
		ext1, x1, y1, ext2, x2, y2, secgap, pixgap, mmgap, >> out)
	}
	fd = ""
end
mscred-5.05-2018.07.09/src/msctools/gaps.dat000066400000000000000000000005241332166314300200450ustar00rootroot00000000000000amp111 2048 2048 amp113    1 2048
amp113 2048 2048 amp211    1 2048
amp211 2048 2048 amp213    1 2048
amp322 2048 2048 amp324    1 2048
amp324 2048 2048 amp422    1 2048
amp422 2048 2048 amp424    1 2048
amp111 1024 4096 amp322 1024    1
amp113 1024 4096 amp324 1024    1
amp211 1024 4096 amp422 1024    1
amp213 1024 4096 amp424 1024    1
mscred-5.05-2018.07.09/src/msctools/imatch.cl000066400000000000000000000027241332166314300202120ustar00rootroot00000000000000real	x1, y1, scale, zero

if (access ("stars.dat"))
    delete ("stars.dat", verify-)
else ;
starlist ("stars.dat", 20, "", "", interactive=no, spatial="uniform", xmin=1.,
xmax=512., ymin=1., ymax=512., xcenter=INDEF, ycenter=INDEF,
core_radius=30., base=0., sseed=1, luminosity="powlaw", minmag=-7.,
maxmag=0., mzero=-4., power=0.6, alpha=0.74, beta=0.04, delta=0.294,
mstar=1.28, lseed=1, nssample=100, sorder=10, nlsample=100, lorder=10,
rbinsize=10., mbinsize=0.5, graphics="stdgraph", cursor="")

i = 0
list="imatch.dat"
while (fscan (list, s1, x, y) != EOF) {
    i = i + 1

    if (i == 1) {
	x1 = x
	y1 = y
    }
    scale = x * x1
    zero = y1 - y
    printf ("%s %8.2f %8.1f %8.2f %8.1f\n", s1, x, y, scale, zero) |
	tee ("logfile")
    if (imaccess (s1) == YES)
	imdelete (s1, verify-)
    z = 1 / x
    mkobjects (s1, output="", title="", ncols=512, nlines=512, header="",
    background=y, objects="stars.dat", xoffset=0., yoffset=0.,
    star="moffat", radius=1., beta=2.5, ar=1., pa=0., distance=1.,
    exptime=z, magzero=8., gain=1., rdnoise=1., poisson=yes, seed=i,
    comments=yes)
}
list = ""

if (access ("stars1.dat"))
    delete ("stars1.dat", verify-)
else ;
mscctran ("stars.dat", "stars1.dat", "test1", "logical", "world",
columns="1 2", units="", formats="%H %h", min_sigdigit=7, verbose=no)

mscimatch ("test*", "stars1.dat", no, scale=yes, zero=yes, box1=9, box2=13,
lower=INDEF, upper=INDEF, niterate=3, sigma=3., interactive=no,
verbose=no) | tee ("logfile")
mscred-5.05-2018.07.09/src/msctools/imatch.dat000066400000000000000000000001701332166314300203550ustar00rootroot00000000000000test1	1	100
test2	1.1	100
test3	0.9	100
test4	1	110
test5	1.1	110
test6	0.9	110
test7	1	 90
test8	1.1	 90
test9	0.9	 90
mscred-5.05-2018.07.09/src/msctools/mkbpm.cl000066400000000000000000000041341332166314300200500ustar00rootroot00000000000000# MKBPM -- Make bad pixel masks.

procedure mkbpm (input, output, template)

file	input			{prompt="Input mosaic flat field ratio"}
file	output			{prompt="Output bad pixel mask"}
file	template		{prompt="Template raw mosaic exposure"}

bool	display			{prompt="Display result?", mode="q"}

struct	*fd

begin
	file	in, bpm, tmplt, extlist, tempa, tempb, tempc, tempd
	string	extname, trimsec
	int	naxis1, naxis2

	# Temporary files.
	tempa = mktemp ("temp")
	tempb = mktemp ("temp")
	tempc = mktemp ("temp")
	tempd = mktemp ("temp") // ".pl"

	# Query parameters.
	flat = input
	out = output

	# Create output file (really a directory of pl files)
	mkdir (out)

	# Expand template.
	imextensions (template, output="file", index="1-", extname="",
	    extver="", lindex+, lname-, lver-, ikparams="", > extlist)
	fd = extlist
	while (fscan (fd, tmplt) != EOF) {
	    hselect (tmplt, "extname,naxis1,naxis2,trimsec", yes) |
		scan (extname, naxis1, naxis2, trimsec)

	    in = flat // "[" // extname // "]"
	    bpm= out // "/bpm_" // extname // ".pl"
	    printf ("mkbpm: %s -> %s\n", in, bpm)

	    imsurfit (in, tempb, 2, 2)
	    imexpr ("abs(a)", tempa, tempb, verbose-)
	    imdelete (tempb, verify-)
	    boxcar (tempa, tempb, 3, 2)
	    boxcar (tempa, tempc, 1, 9)
	    imexpr ("(abs(a)>1 || abs(b)>1 || abs(c)>0.5) ? 1 : 0", tempd,
		tempa, tempb, tempc, verbose-)
	    imdelete (tempa, verify-)
	    imdelete (tempb, verify-)
	    imdelete (tempc, verify-)

	    hselect (tmplt, "naxis1,naxis2,trimsec", yes) |
		scan (naxis1, naxis2, trimsec)
	    mkpattern (tempa, output="", pattern="constant", option="replace",
		v1=0., v2=1., size=1, title="", pixtype="short", ndim=2,
		ncols=naxis1, nlines=naxis2, header=tmplt)
	    imcopy (tempd, tempa//trimsec, verbose=no)
	    imdelete (tempd, verify=no)
	    imcopy (tempa, bpm, verbose=no)
	    imdelete (tempa, verify=no)
	    hedit (bpm, "obstype", "mask", verify-, show-, update+)

	    if (display) {
		display (in, 1)
		display (in, 2, bpdisplay="overlay", overlay=bpm)
		printf ("Entering IMEXAM (quit with 'q')...\n") 
		imexamine
	    }
	}
	fd = ""; delete (extlist, verify=no)
end
mscred-5.05-2018.07.09/src/msctools/mkbpmNEW.cl000066400000000000000000000036641332166314300204310ustar00rootroot00000000000000if (imaccess ("median"))
    imdel median
if (imaccess ("absresid"))
    imdel median

list = "list"
while (fscan (list, s1, s2) != EOF) {
display (s1, 2, > "dev$null")
#median (s1, "median", 9, 5, zloreject=INDEF, zhireject=INDEF,
#    boundary="reflect", constant=0., verbose=no)
#display median 1 > "dev$null"
#imexpr ("abs(a-b)", "absresid", s1, "median")
#display absresid 1 > "dev$null"
#boxcar ("absresid", "absresid", 1, 20, boundary="reflect")
#display absresid 1 > "dev$null"
#imstat ("absresid", fields="midpt,stddev", lower=INDEF, upper=INDEF, format-) |
#    scan (x, y)
#z = x + 10 * y
#imstat ("absresid", fields="midpt,stddev", lower=INDEF, upper=z, format-) |
#    scan (x, y)
#z = x + 8 * y
#printf ("a > %g ? 1 : 0\n", z) | scan (line)
#if (access (s2))
#    imdel (s2)
#imexpr (line, s2, "absresid")
#display (s1, 1, overlay=s2, > "dev$null")
#crgrow (s2, s2, radius=1.5, inval=INDEF, outval=INDEF)
#convolve (s2, s2, "", "0.5 1 0.5", "1",
#    bilinear=yes, radsym=no, boundary="nearest", constant=0., row_delimite=";")
#convolve (s2, s2, "", "1", "0.5 0.5 0 0 0 1 0 0 0 0.5 0.5",
#    bilinear=yes, radsym=no, boundary="nearest", constant=0., row_delimite=";")
#display (s1, 1, overlay=s2, > "dev$null")
#convolve (s2, s2, "", "1", "0.5 0.5 0 0 0 1 0 0 0 0.5 0.5",
#    bilinear=yes, radsym=no, boundary="nearest", constant=0., row_delimite=";")
#display (s1, 1, overlay=s2, > "dev$null")
#convolve (s2, s2, "", "1", "0.5 0.5 0 0 0 1 0 0 0 0.5 0.5",
#    bilinear=yes, radsym=no, boundary="nearest", constant=0., row_delimite=";")
#display (s1, 1, overlay=s2, > "dev$null")
imedit (s2, "", cursor="", logfile="", display=yes, autodisplay=yes,
    autosurface=no, aperture="square", radius=1., search=0., buffer=1.,
    width=2., xorder=2, yorder=2, value=0., sigma=INDEF, angh=-33., angv=25.,
    command="display $image 1 erase=$erase fill=no order=0 >& dev$null",
    graphics="stdgraph", default="b", fixpix=no)
#imdel median,absresid
}
list = ""
mscred-5.05-2018.07.09/src/msctools/mkccd.cl000066400000000000000000000110521332166314300200200ustar00rootroot00000000000000# MKCCD -- Make a CCD image from a template image.

procedure mkccd (image, template)

string	image			{prompt="Image name"}
file	template		{prompt="Template image"}
int	xsize = 100		{prompt="X size"}
int	ysize = 200		{prompt="Y size"}
int	noverscan = 32		{prompt="Overscan columns (-=left, +=right)"}
int	xoffset = 0		{prompt="X offset in template"}
int	yoffset = 0		{prompt="Y offset in template"}
int	xccdoffset = 0		{prompt="X offset in CCD"}
int	yccdoffset = 0		{prompt="Y offset in CCD"}
int	xdither = 0		{prompt="X dither"}
int	ydither = 0		{prompt="Y dither"}

real	bias = 500.		{prompt="Bias level"}
real	flat = 1.		{prompt="Flat response"}

string	imageid = "1"		{prompt="Image ID"}
string	ccdname	= "ccd1"	{prompt="CCD name"}
string	ampname = "amp1"	{prompt="Amplifier name"}

bool	verbose = yes		{prompt="Verbose?"}

begin
	file	im, tim
	int	x1, x2, y1, y2
	real	ltv1
	string	ccdsec, datasec, biassec

	im = image
	tim = template

	# Data section.
	if (noverscan < 0) {
	    x1 = 1 - noverscan ; x2 = xsize - noverscan
	} else {
	    x1 = 1; x2 = xsize
	}
	printf ("[%d:%d,%d:%d]\n", x1, x2, 1, ysize) | scan (datasec)

	# Bias section.
	if (noverscan < 0) {
	    x1 = 1; x2 = -noverscan
	} else {
	    x1 = 1 + xsize; x2 = xsize + noverscan
	}
	printf ("[%d:%d,%d:%d]\n", x1, x2, 1, ysize) | scan (biassec)
	    
	# Make image.
	if (tim == "zero") {
	    x1 = xsize + abs (noverscan)
	    y1 = ysize
	    mkpattern (im, output="", pattern="constant", option="replace",
		v1=0., v2=1., size=1, title="", pixtype="ushort", ndim=2,
		ncols=x1, nlines=y1, header="")
	} else if (tim == "flat") {
	    x1 = xsize + abs (noverscan)
	    y1 = ysize
	    mkpattern (im, output="", pattern="constant", option="replace",
	        v1=0., v2=1., size=1, title="", pixtype="ushort", ndim=2,
		ncols=x1, nlines=y1, header="")
	    mkpattern (im//datasec, output="", pattern="constant",
	        option="replace", v1=1000., v2=1., size=1)
	} else {
	    x1 = 1 + abs(noverscan) + xoffset + xdither
	    x2 = xsize + abs(noverscan) + xoffset + xdither
	    y1 = 1 + yoffset + ydither
	    y2 = ysize + yoffset + ydither
	    if (noverscan < 0)
		x1 = x1 + noverscan
	    else
		x2 = x2 + noverscan
	    printf ("[%d:%d,%d:%d]\n", x1, x2, y1, y2) | scan (ccdsec)

	    imcopy (tim//ccdsec, im, verbose=verbose)
	    mkpattern (im//biassec, output="", pattern="constant",
	        option="replace", v1=0., v2=1., size=1)
	}

	# Apply response.
	mkpattern (im//datasec, output="", pattern="constant",
	    option="multiply", v1=flat, v2=1., size=1, title="",
	    pixtype="ushort", ndim=2, ncols=x1, nlines=y1, header="")

	# Add bias.
	mkpattern (im, output="", pattern="constant", option="add",
	    v1=bias, v2=1., size=1, title="", pixtype="ushort", ndim=2,
	    ncols=x1, nlines=y1, header="")

	# Adjust header.

	# OBSTYPE
	if (tim == "zero")
	    hedit (im, "obstype", "zero", add+, addonly-, verify-, update+,
		show=verbose)
	else if (tim == "flat")
	    hedit (im, "obstype", "flat", add+, addonly-, verify-, update+,
		show=verbose)
	else
	    hedit (im, "obstype", "object", add+, addonly-, verify-, update+,
		show=verbose)

	# DATASEC, TRIMSEC, BIASSEC
	hedit (im, "datasec", datasec, add+, addonly-, verify-, update+,
	    show=verbose)
	hedit (im, "trimsec", datasec, add+, addonly-, verify-, update+,
	    show=verbose)
	hedit (im, "biassec", biassec, add+, addonly-, verify-, update+,
	    show=verbose)

	# CCDSEC and LTV
	x1 = 1 + xccdoffset; x2 = xsize + xccdoffset
	y1 = 1 + yccdoffset; y2 = ysize + yccdoffset
	printf ("[%d:%d,%d:%d]\n", x1, x2, y1, y2) | scan (ccdsec)
	hedit (im, "ccdsec", ccdsec, add+, addonly-, verify-, update+,
	    show=verbose)
	x1 = -xccdoffset + max (0, -noverscan)
	y1 = -yccdoffset
	hedit (im, "ltv1", x1, add+, addonly-, verify-, update+, show=verbose)
	hedit (im, "ltv2", y1, add+, addonly-, verify-, update+, show=verbose)

	# DETSEC
	x1 = 1 + xoffset; x2 = xsize + xoffset
	y1 = 1 + yoffset; y2 = ysize + yoffset
	printf ("[%d:%d,%d:%d]\n", x1, x2, y1, y2) | scan (ccdsec)
	hedit (im, "detsec", ccdsec, add+, addonly-, verify-, update+,
	    show=verbose)
	hedit (im, "dtv1", xoffset, add+, addo-, verify-, update+, show=verbose)
	hedit (im, "dtv2", yoffset, add+, addo-, verify-, update+, show=verbose)
	hedit (im, "dtm1_1", 1., add+, addonly-, verify-, update+, show=verbose)
	hedit (im, "dtm2_2", 1., add+, addonly-, verify-, update+, show=verbose)

	# IMAGEID, CCDNAME, and AMPNAME
	hedit (im, "imageid", imageid, add+, verify-, update+, show=verbose)
	hedit (im, "ccdname", ccdname, add+, verify-, update+, show=verbose)
	hedit (im, "ampname", ampname, add+, verify-, update+, show=verbose)
end
mscred-5.05-2018.07.09/src/msctools/mkmef.cl000066400000000000000000000036631332166314300200470ustar00rootroot00000000000000# Create an MEF file from a dump of the headers.
# Input header listsing is "hdrs" and output MEF is "mef".

procedure mkmef (mef, hdrs)

file	mef			{prompt="MEF file to create"}
file	hdrs			{prompt="Input header listings"} 
file	global = ""	{prompt="Global header (optional)\n\n# MKPATTERN"}
string	pattern = "constant"	{prompt="Data pattern"}
real	v1 = 0.			{prompt="Data value 1"}
real	v2 = 1.			{prompt="Data value 2"}
int	size = 1		{prompt="Pattern size"}

begin
	file	in, out, tmp
	int	ncols, nlines
	struct	newline

	out = mef
	in = hdrs
	tmp = mktemp ("tmp$iraf")

	# Delete if already exists.
	if (imaccess (out//"[0]"))
	    imdelete (out, verify-)

	# Create global header.
	printf ("Creating global header...\n")
	mkpattern (out, output="", pattern="constant",
	    option="multiply", v1=0., v2=1., size=1, title="", pixtype="real",
	    ndim=0, ncols=512, nlines=512, header=global)

	# Create extensions.
	list = in
	line = ""
	while (fscan (list, newline) != EOF) {
	    if (substr(newline,1,13) == "No bad pixels") {
		if (access (tmp)) {
		    printf ("Creating extension...%d x %d\n", ncols, nlines)
		    mkpattern (out//"[dummy,append,inherit]", output="",
			pattern=pattern, option="multiply", v1=v1, v2=v2,
			size=size, title="", pixtype="real", ndim=2,
			ncols=ncols, nlines=nlines, header=tmp)
		    delete (tmp, verify-)
		}

		# Get next extensions size.
		line = substr(line, stridx("[",line)+1,1000)
		line = substr(line, stridx("[",line)+1,1000)
		print (line) | scanf ("%d,%d", ncols, nlines)
	    } else if (line != "")
		print (line, >> tmp)
	    line = newline
	}
	if (line != "")
	    print (line, >> tmp)
	if (access (tmp)) {
	    printf ("Creating extension...%d x %d\n", ncols, nlines)
	    mkpattern (out//"[dummy,append,inherit]", output="",
		pattern=pattern, option="multiply", v1=v1, v2=v2,
		size=size, title="", pixtype="real", ndim=2, ncols=ncols,
		nlines=nlines, header=tmp)
	    delete (tmp, verify-)
	}
	list = ""
end

mscred-5.05-2018.07.09/src/msctools/mkmosaic.cl000066400000000000000000000035431332166314300205500ustar00rootroot00000000000000procedure mkmosaic (mosaic, template)

string	mosaic			{prompt="Mosaic filename"}
file	template		{prompt="Template image"}
int	xsize = 100		{prompt="CCD size"}
int	ysize = 200		{prompt="CCD size"}
int	nxccd = 4		{prompt="Number of CCDs in X"}
int	nyccd = 2		{prompt="Number of CCDs in Y"}
int	namp = 1		{prompt="Number of amps per CCD"}
int	gap = 5			{prompt="Gap width"}
int	noverscan = 32		{prompt="Overscan columns (-=left, +=right)"}
int	xdither = 0		{prompt="X dither"}
int	ydither = 0		{prompt="Y dither"}

int	seed = 1		{prompt="Random number seed"}
real	bias = 500.		{prompt="Bias levels"}

bool	verbose = yes		{prompt="Verbose?"}

begin
	file	mim, tim, im
	int	i, j, k, l
	int	xs, ys, xoffset, yoffset, xccdoffset, yccdoffset, noscan
	real	rand1, rand2

	mim = mosaic
	tim = template
	xs = xsize / namp
	ys = ysize
	xccdoffset = 0
	yccdoffset = 0

	k = 0
	for (j=1; j<=nyccd; j+=1) {
	    xoffset = -(xs + gap)
	    yoffset = (j - 1) * (ys + gap) 
	    for (i=1; i<=namp*nxccd; i+=1) {
		k = k + 1
		l = (k + 1) / namp
		printf ("%s[im%d,append]\n", mim, k) | scan (im)
	
		if (namp == 1) {
		    xoffset = xoffset + xs + gap
		    noscan = noverscan * (2 * mod (j, 2) - 1)
		} else if (mod(i,namp) == 1) {
		    xoffset = xoffset + xs + gap
		    xccdoffset = 0
		    noscan = noverscan
		} else {
		    xoffset = xoffset + xs
		    xccdoffset = xs
		    noscan = -noverscan
		}

		urand (k, 2, ndigits=4, scale=2.0, seed=seed) |
		    fields ("STDIN", "1-2", lines=k) | scan (rand1, rand2)
		rand1 = bias * (1 + 0.2 * (rand1 - 1.))
		rand2 = 1 + 0.2 * (rand2 - 1.)
		mkccd (im, tim, xsize=xs, ysize=ys,
		    xoffset=xoffset, yoffset=yoffset,
		    xccdoffset=xccdoffset, yccdoffset=yccdoffset,
		    xdither=xdither, ydither=ydither,
		    noverscan=noscan, bias=rand1, flat=rand2,
		    imageid=k, ccdname="ccd"//l, ampname="amp"//k,
		    verbose=verbose)
		flpr
	    }
	}
end
mscred-5.05-2018.07.09/src/msctools/mquant.cl000066400000000000000000000033531332166314300202510ustar00rootroot00000000000000# Scale Mosaic images and convert to USHORT.

procedure mquant (images)

string	images		{prompt="List of Mosaic images"}
real	bscale = 0.2	{prompt="FITS bscale parameter to use"}
real	bzero = 500.	{prompt="FITS bzero parameter to use"}
bool	preserve = no	{prompt="Preserve data values?"}
bool	verbose = yes	{prompt="Verbose progress information"}

struct	*infd, *outfd

begin
	file	inlist, extlist, input, output	
	string	names

	inlist = mktemp ("tmp$iraf")
	extlist = mktemp ("tmp$iraf")
	output = mktemp ("mquant")

	files (images, sort=no, > inlist)
	infd = inlist
	while (fscan (infd, input) != EOF) {
	    imextensions (input, output="file", index="", extname="",
		extver="", lindex=yes, lname=no, lver=no, ikparams="", >extlist)
	    imcopy (input//"[0]", output, verbose=verbose)
	    outfd = extlist
	    if (preserve) {
		while (fscan (outfd, ext) != EOF)
		    imexpr ("max(-32768.,min(32757.,(a-"//bzero//")/"//bscale//"))",
			output//"[append,inherit]", ext, intype="auto",
			outtype="short", dims="auto", refim="auto",
			verbose=verbose)
	    } else {
		while (fscan (outfd, ext) != EOF)
		    imexpr ("max(0.,min(65535.,(a-"//bzero//")/"//bscale//"))",
			output//"[append,inherit]", ext, intype="auto",
			outtype="ushort", dims="auto", refim="auto",
			verbose=verbose)
	    }
	    outfd = ""; delete (extlist, verify-)
	    if (preserve) {
		imextensions (output, output="list", index="", extname="",
		    extver="", lindex=yes, lname=no, lver=no, ikparams="") |
		    scan (names)
		hedit (names, "bzero", bzero, add+, update+, verify-,
		    show=verbose)
		hedit (names, "bscale", bscale, add+, update+, verify-,
		    show=verbose)
	    }
	    imdelete (input, verify-)
	    imrename (output, input)
	}
	infd = ""; delete (inlist, verify-)
end
mscred-5.05-2018.07.09/src/msctools/msctools.cl000066400000000000000000000004741332166314300206100ustar00rootroot00000000000000#{ MSCTOOLS -- MSCRED tools package

package msctools

#task	gaps		= "msctools$gaps.cl"
#task	offsets		= "msctools$offsets.cl"
#task	stats		= "msctools$stats.cl"
task	fmtastrom	= "msctools$fmtastrom.cl"
task	mkbpm		= "msctools$mkbpm.cl"
task	pl2msc		= "msctools$pl2msc.cl"
task	mkmef		= "msctools$mkmef.cl"

clbye()
mscred-5.05-2018.07.09/src/msctools/offsets.cl000066400000000000000000000044151332166314300204150ustar00rootroot00000000000000procedure offsets (image)

string	image				{prompt="Image"}
file	results = "STDOUT"		{prompt="Results file"}
file	offsets = "msctools$offsets.dat"	{prompt="Offsets data file"}
real	pixscale = 0.259		{prompt="Pixel scale (arcsec/pixel)"}
real	xrotation = 90.			{prompt="Rotation of ra axis from x"}
real	yrotation = 270.		{prompt="Rotation of dec axis from x"}
bool	verbose = yes			{prompt="Verbose?"}

struct	*fd

begin
	file	im, out, temp
	string	name, ext1, ext2
	struct	time
	int	nc, nl, c1, c2, l1, l2
	real	cx, sx, cy, sy
	real	x1, y1, x2, y2, dx, dy, ra1, dec1, ra2, dec2

	im = image
	out = results
	temp = mktemp ("tmp$iraf")
	cx = cos (xrotation * 3.14159 / 180.)
	sx = sin (xrotation * 3.14159 / 180.)
	cy = cos (yrotation * 3.14159 / 180.)
	sy = sin (yrotation * 3.14159 / 180.)

	if (verbose) {
	    name = envget ("userid")
	    time | scan (time)
	    printf ("Mosaic statistics prepared by %s on %s\n", name, time, >> out)
	    printf ("  Image = %s, pixel scale = %.4g, xrotation = %.4g, yrotation = %.4g\n",
		im, pixscale, xrotation, yrotation, >> out)
	}
	printf ("\n  Offsets:%44t pixel  pixel detsec\n", >> out)

	dx = 100000
	dy = 100000
	fd = offsets
	while (fscan (fd, ext1, x1, y1, ext2, x2, y2, nc, nl) != EOF) {
	    print (x1, y1) |
	    mscctran ("STDIN", "STDOUT", im//"["//ext1//"]", yes,
		xcolumn=1, ycolumn=2, lngformat="", latformat="",
		min_sigdigit=7) | scan (ra1, dec1)
	    print (x2, y2) |
	    mscctran ("STDIN", "STDOUT", im//"["//ext2//"]", yes,
		xcolumn=1, ycolumn=2, lngformat="", latformat="",
		min_sigdigit=7) | scan (ra2, dec2)
	    ra1 = 3600. * 15. * (ra1-ra2) * cos ((dec1+dec2)*3.14159/360.)
	    dec1 = 3600. * (dec1-dec2)
	    ra2 = (ra1 * cx + dec1 * sy) / pixscale
	    dec2 = (-ra1 * sx + dec1 * cy) / pixscale
	    print (ext1, " ", x1, y1, ext2, " ", x2, y2, nc, nl,
		ra2, dec2, >> temp)
	    dx = min (dx, ra2)
	    dy = min (dy, dec2)
	}
	
	fd = temp
	while (fscan (fd, ext1, x1, y1, ext2, x2, y2, nc, nl, ra2, dec2)!=EOF) {
	    ra2 = abs (ra2 - dx)
	    dec2 = abs (dec2 - dy)
	    c1 = 1 + nint (ra2)
	    c2 = c1 + nc - 1
	    l1 = 1 + nint (dec2)
	    l2 = l1 + nl - 1
	    printf ("  %s[%d,%d] - %s[%d,%d]: %44t%6.1f %6.1f [%d:%d,%d:%d]\n",
		ext1, x1, y1, ext2, x2, y2, ra2, dec2, c1, c2, l1, l2, >> out)
	}
	fd = ""; delete (temp, verify-)
end
mscred-5.05-2018.07.09/src/msctools/offsets.dat000066400000000000000000000004601332166314300205630ustar00rootroot00000000000000amp111 1024 2048 amp422 1 1 2048 4096
amp113 1024 2048 amp422 1 1 2048 4096
amp211 1024 2048 amp422 1 1 2048 4096
amp213 1024 2048 amp422 1 1 2048 4096
amp322 1024 2048 amp422 1 1 2048 4096
amp324 1024 2048 amp422 1 1 2048 4096
amp422 1024 2048 amp422 1 1 2048 4096
amp424 1024 2048 amp422 1 1 2048 4096
mscred-5.05-2018.07.09/src/msctools/pixctran.cl000066400000000000000000000015531332166314300205740ustar00rootroot00000000000000# PIXCTRAN -- Convert world coordinates to pixel coordinates.
# The input is a list of world coordinates and the output is a list
# of pixel coordinates limited to the image region.

procedure pixctran (input, output, image)

file	input		{prompt="Input coordinate file"}
file	output		{prompt="Output coordinate file"}
file	image		{prompt="Input image"}
bool	wcssol = yes	{prompt="Use WCS plate solution?"}

struct	*fd

begin
	file	in, out, im, temp
	real	nc, nl, xpos, ypos

	in = input
	out = output
	im = image
	temp = mktemp ("tmp$iraf")

	mscctran (in, temp, im, no, xcolumn=1, ycolumn=2, min_sigdigit=9,
	    wcssol=wcssol)

	hselect (im, "naxis1,naxis2", yes) | scan (nc, nl)

	fd = temp
	while (fscan (fd, xpos, ypos) != EOF) {
	    if (xpos < 0.5 || xpos > nc+0.5 || ypos < 0.5 || ypos > nl+0.5)
		next
	    print (xpos, ypos, >> out)
	}

	delete (temp, verify-)
end
mscred-5.05-2018.07.09/src/msctools/pl2msc.cl000066400000000000000000000014211332166314300201360ustar00rootroot00000000000000# PL2MSC --  Convert a pixel list directory to a mosaic MEF format.

procedure pl2msc (input, output)

file	input			{prompt="Input pixel list directory"}
file	output			{prompt="Output mosaic filename"}
bool	trim=yes		{prompt="Trim data"}
bool	verbose=yes		{prompt="Verbose?"}

struct	*fd

begin
	string	in, out, extname, trimsec
	file	pllist

	in = input // "/"
	out = output
	pllist = mktemp ("tmp$iraf")

	hselect (in // "flat*.pl", "$I,extname,trimsec", yes, > pllist)
	if (!access (pllist))
	    error (1, "Input data not found")

	fd = pllist
	while (fscan (fd, in, extname, trimsec) != EOF) {  
	    if (!trim)
		trimsec = ""
	    else if (nscan() == 2)
		trimsec = ""

	    imcopy (in//trimsec, out//"["//extname//"]", verbose=verbose)
	}
	fd = ""; delete (pllist, verify-)
end
mscred-5.05-2018.07.09/src/msctools/stats.cl000066400000000000000000000075301332166314300201030ustar00rootroot00000000000000procedure stats (image, wcs)

string	image				{prompt="Image"}
file	wcs = "ccddb$mosaic/wcs.dat"	{prompt="WCS database"}
file	results = "STDOUT"		{prompt="Output statistics file"}
bool	xystat = no			{prompt="Separate X and Y statistics?"}
file	gaps = "msctools$gaps.dat"	{prompt="Gap data file"}
file	offsets = "msctools$offsets.dat"	{prompt="Offsets data file"}
real	mmscale = 0.015			{prompt="Pixel scale (mm/pixel)"}
bool	verbose = yes			{prompt="Verbose?"}

struct	*fd1, *fd2

begin
	string	name
	struct	time
	file	im, in, out, temp1, temp2
	int	n
	real	val, pixscale, rot, xrot, yrot
	real	mean, sigma, meanx, sigmax, meany, sigmay

	im = image
	in = wcs
	out = results
	temp1 = mktemp ("tmp$iraf")
	temp2 = mktemp ("tmp$iraf")

	if (verbose) {
	    name = envget ("userid")
	    time | scan (time)
	    printf ("Mosaic statistics prepared by %s on %s\n",
		name, time, >> out)
	    printf ("  WCS database = %s, Image = %s\n", in, im, >> out)
	}
	printf ("\n  WCS statistics:\n", >> out)

	match ("mag", in, stop-, print-, meta-) |
	fields ("STDIN", "2", lines="1-9999", quit-, print-) |
	average ("new_sample") | scan (pixscale, sigma)
	printf ("  Pixel scale (arcsec/pixel):%34t%6.4f (%6.4f)",
	    pixscale, sigma, >> out)
	if (xystat) {
	    match ("xmag", in, stop-, print-, meta-) |
	    fields ("STDIN", "2", lines="1-9999", quit-, print-) |
	    average ("new_sample") | scan (meanx, sigmax)
	    match ("ymag", in, stop-, print-, meta-) |
	    fields ("STDIN", "2", lines="1-9999", quit-, print-) |
	    average ("new_sample") | scan (meany, sigmay)
	    printf (" %6.4f (%6.4f) %6.4f (%6.4f)",
		meanx, sigmax, meany, sigmay, >> out)
	}
	printf ("\n", >> out)

	match ("xrotation", in, stop-, print-, meta-) |
	fields ("STDIN", "2", lines="1-9999", quit-, print-, > temp1)
	xrot = 0
	n = 0
	fd1 = temp1
	while (fscan (fd1, val) != EOF) {
	    if (n == 0)
		rot = val
	    else if (val - rot < -180.)
		val = val + 360.
	    else if (val - rot > 180.)
		val = val - 360.
	    xrot = xrot + val
	    n = n + 1
	}
	fd1 = ""; delete (temp1, verify-)
	xrot = xrot / n

	match ("yrotation", in, stop-, print-, meta-) |
	fields ("STDIN", "2", lines="1-9999", quit-, print-, > temp1)
	yrot = 0
	n = 0
	fd1 = temp1
	while (fscan (fd1, val) != EOF) {
	    if (n == 0)
		rot = val
	    else if (val - rot < -180.)
		val = val + 360.
	    else if (val - rot > 180.)
		val = val - 360.
	    yrot = yrot + val
	    n = n + 1
	}
	fd1 = ""; delete (temp1, verify-)
	yrot = yrot / n

	rot = xrot
	while (rot - yrot < -90.)
	    rot = rot + 180.
	while (rot - yrot > 90.)
	    rot = rot - 180.
	rot = (rot + yrot) / 2.

	printf ("  Field rotation (degrees):%34t%6.2f", rot, >> out)
	if (xystat)
	    printf (" %6.2f %6.2f", xrot, yrot, >> out)
	printf ("\n", >> out)

	match ("begin", in, stop-, print-, meta-) |
	fields ("STDIN", "2", lines="1-9999", quit-, print-, > temp1)
	match ("rotation", in, stop-, print-, meta-) |
	fields ("STDIN", "2", lines="1-9999", quit-, print-, > temp2)

	fd1 = temp1
	fd2 = temp2
	while (fscan (fd1, name) != EOF) {
	    n = fscan (fd2, meanx)
	    n = fscan (fd2, meany)
	    meanx = meanx - rot
	    meany = meany - rot
	    while (meanx < -90.)
		meanx = meanx + 180.
	    while (meanx > 90.)
		meanx = meanx - 180.
	    while (meany < -90.)
		meany = meany + 180.
	    while (meany > 90.)
		meany = meany - 180.
	    mean = (meanx + meany) / 2.
	    if (xystat)
		printf ("  CCD rotation %s (degrees):%34t%6.2f %6.2f %6.2f\n",
		    name, mean, meanx, meany, >> out)
	    else
		printf ("  CCD rotation %s (degrees):%34t%6.2f\n",
		    name, mean, >> out)
	}
	fd1 = ""; fd2 = ""; delete (temp1//","//temp2, verify-)

	gaps (im, results=out, gaps=gaps, pixscale=pixscale, mmscale=mmscale,
	    xrotation=xrot, yrotation=yrot, verbose=no)

	offsets (im, results=out, offsets=offsets, pixscale=pixscale,
	    xrotation=xrot, yrotation=yrot, verbose=no)

	type ("msctools$stats.dat", >> out)
end
mscred-5.05-2018.07.09/src/msctools/stats.dat000066400000000000000000000020351332166314300202500ustar00rootroot00000000000000
  NOTES:
    1.  These statistics are computed from the master WCS solutions for
	the CCDs in the Mosaic.  These solutions map pixels to celestial
	coordinates and include the optical and sky projection effects.
    2.  The field rotation is a clockwise angle of the declination axis from
	the image column axis.  For example an angle of 270 means that
	declination increases to the left in an unflipped display.
    3.  The CCD rotation is a relative rotation from the mean field
	rotation.
    4.  The gaps are computed from the distance on the sky of the indicated
	pixels as shown in the arcsec column.  The pixel gap is computed
	from the arc second distance using the mean pixel scale.  The
	millimeter gap is derived from the pixel gap using the average
	pixel size.  Because this is derived from the sky the gap is not
	precisely the true physical gap.
    5.  The offsets are derived from the sky distance between the
	center of each CCD and the indicated reference point.  The
	sky distance is converted to pixels using the mean pixel scale.
mscred-5.05-2018.07.09/src/msctools/testpatfit.cl000066400000000000000000000101031332166314300211220ustar00rootroot00000000000000procedure testpatfit ()

string	weights = '"" weights'
string	bkgs = '"" 0 500 sky'
string	bkgpats = '"" 0 0.1 zero'
string	bkgwts = '"" 0 0.1 zero'
string	masks = 'objmask ""'
string	patmasks = 'patmask ""'
string	outtypes = 'none fit diff pfit pdiff sfit sdiff'
file	logfile = ""
bool	verbose = yes

begin
	file	im, tmp
	string	outtype, bkg, bkgpat, bkgwt, weight, mask, patmask
	struct	aouttypes, abkgs, abkgpats, abkgwts, aweights, amasks, apatmasks

	tmp = mktemp ("tmp")

	# Make data.

	im = "galfield"
	if (!imaccess(im)) {
	    gallist (tmp, 1000, interactive=no, spatial="uniform", xmin=1.,
		xmax=512., ymin=1., ymax=512., xcenter=INDEF,
		ycenter=INDEF, core_radius=50., base=0., sseed=1,
		luminosity="powlaw", minmag=-7., maxmag=0.,
		mzero=15., power=0.45, alpha=-1.24, mstar=-21.41,
		lseed=1, egalmix=0.4, ar=0.7, eradius=10., sradius=1.,
		absorption=1.2, z=0.05, sfile="", nssample=100, sorder=10,
		lfile="", nlsample=100, lorder=10, rbinsize=10.,
		mbinsize=0.5, dbinsize=0.5, ebinsize=0.1, pbinsize=20.,
		graphics="stdgraph", cursor="")

	    starlist (tmp, 100, "", "", interactive=no, spatial="uniform",
		xmin=1., xmax=512., ymin=1., ymax=512., xcenter=INDEF,
		ycenter=INDEF, core_radius=30., base=0., sseed=2,
		luminosity="powlaw", minmag=-7., maxmag=0., mzero=-4.,
		power=0.6, alpha=0.74, beta=0.04, delta=0.294, mstar=1.28,
		lseed=2, nssample=100, sorder=10, nlsample=100, lorder=10,
		rbinsize=10., mbinsize=0.5, graphics="stdgraph", cursor="")

	    mkobjects (im, output="", ncols=512, nlines=512,
		title="Example artificial galaxy field",
		header="", background=0.,
		objects=tmp, xoffset=0., yoffset=0., star="moffat",
		radius=1.0, beta=2.5, ar=1., distance=1.,
		exptime=1., magzero=5.5, gain=5., rdnoise=0., poisson=no,
		seed=3, comments=no)

	    delete (tmp, verify=no)
	}

	im = "objmask"
	if (!imaccess(im))
	    imcopy ("galfield", im//".pl", verbose-)

	im = "sky"
	if (!imaccess(im))
	    mkpattern (im, output="", pattern="slope", option="replace",
		v1=490., v2=510., size=1, title="Sky", pixtype="real",
		ndim=2, ncols=512, nlines=512, n3=1, n4=1, n5=1, n6=1,
		n7=1, header="")

	im = "zero"
	if (!imaccess(im))
	    mkpattern (im, output="", pattern="constant", option="replace",
		v1=0., v2=1., size=1, title="", pixtype="real",
		ndim=2, ncols=512, nlines=512, n3=1, n4=1, n5=1, n6=1,
		n7=1, header="")

	im = "pattern"
	if (!imaccess(im)) {
	    if (imaccess("patmask"))
	        imdelete ("patmask", verify-)
	    imexpr ("sqrt((I)**2+(J)**2)<200?0 : 1", "patmask.pl",
	        dims="512,512", outtype="int", verbose-)
	    mkpattern (tmp, output="", pattern="square", option="replace",
		v1=1., v2=3., size=1, title="Sky", pixtype="real",
		ndim=2, ncols=512, nlines=512, n3=1, n4=1, n5=1, n6=1,
		n7=1, header="")
	    imexpr ("b==0?a : 0", im, tmp, "patmask", verbose-)
	    imdelete (tmp, verify-)
	}

	im = "weights"
	if (!imaccess(im))
	    imcopy ("pattern", im, verbose-)

	im = "noise"
	if (!imaccess(im))
	    mknoise (im, output="", title="", ncols=512, nlines=512,
	        header="", background=0., gain=1., rdnoise=10., poisson=no,
		seed=1, cosrays="", ncosrays=0, energy=30000., radius=0.5,
		ar=1., comments=yes)

	im = "test"
	if (!imaccess(im))
	    imexpr ("a+b+c+2*d", im, "galfield", "sky", "noise",
	        "pattern", verbose-)

	# Test various modes.
	if (access("logfile"))
	    delete ("logfile", verify-)
	abkgwts = bkgwts
	while (fscan (abkgwts, bkgwt, abkgwts) > 0) {
	abkgs = bkgs
	while (fscan (abkgs, bkg, abkgs) > 0) {
	abkgpats = bkgpats
	while (fscan (abkgpats, bkgpat, abkgpats) > 0) {
	aweights = weights
	while (fscan (aweights, weight, aweights) > 0) {
	apatmasks = patmasks
	while (fscan (apatmasks, patmask, apatmasks) > 0) {
	amasks = masks
	while (fscan (amasks, mask, amasks) > 0) {
	aouttypes = outtypes
	while (fscan (aouttypes, outtype, aouttypes) > 0) {
	    im = "testout"
	    if (imaccess(im))
		imdelete (im, verify-)
	    patfit ("test", im, "pattern", weight, background=bkg,
		bkgpattern=bkgpat, bkgweight=bkgwt, masks=mask,
		patmasks=patmask, extfit="", extout="", outtype=outtype,
		logfile=logfile, verbose=verbose)
	}
	}
	}
	}
	}
	}
	}
end
mscred-5.05-2018.07.09/src/msctools/wcsref.cl000066400000000000000000000020321332166314300202260ustar00rootroot00000000000000# WCSREF -- Create or modify a WCS reference image.

procedure wcsref (image, ra, dec, scale, rotation)

file	image			{prompt="Reference image"}
real	ra			{prompt="RA (hours)"}
real	dec			{prompt="DEC (degrees)"}
real	scale			{prompt="Scale (arcsec/pixel)"}
real	rotation = 90		{prompt="Rotation of DEC from N to E (degrees)"}

begin
	file	im
	real	crval1, crval2, cd11, cd22, rot

	# Get query parameters.
	im = image
	crval1 = ra
	crval2 = dec
	cd11 = -scale
	cd22 = -cd11
	rot = rotation

	# Make the template image if necessary.
	if (!imaccess (im))
	    mkpattern (im, output="", pattern="constant", option="replace",
		v1=0., v2=0., size=1, title="", pixtype="short", ndim=2,
		ncols=1, nlines=1, n3=1, n4=1, n5=1, n6=1, n7=1, header="")

	# Set the WCS.
	ccsetwcs (im, "", "", xref=INDEF, yref=INDEF, xmag=cd11, ymag=cd22,
	    xrotation=rot, yrotation=rot, lngref=crval1, latref=crval2,
	    lngunits="hours", latunits="degrees", transpose=no,
	    projection="tan", coosystem="j2000", update=yes,
	    pixsystem="physical", verbose=yes)
end
mscred-5.05-2018.07.09/src/msctools/xtcoeff.cl000066400000000000000000000301141332166314300203750ustar00rootroot00000000000000#From rhoads@noao.edu Mon Aug 30 11:58:43 1999
#Date: Mon, 30 Aug 99 11:58:40 MST
#From: rhoads@noao.edu (James Rhoads)
#To: jannuzi@noao.edu
#Subject: Instructions for crosstalk script
#Cc: dmac@as.arizona.edu, fvaldes@noao.edu, gjacoby@noao.edu,
#        tarmandroff@noao.edu
#
#Hi Buell, Dan, George, Taft, Frank:
#
#Most of you have expressed some interest in my crosstalk measurement
#script at some time.  The script will follow under separate cover.
#To use it, save it as "xtcoeff.cl" and get Iraf to recognize it using
# task xtcoeff = "xtcoeff.cl" .
#Remember as always that this was a quick hack; anybody who wants to
#improve on it is more than welcome.
#
#Here is the parameter list for the script, with some values for a run on
#Mosaic South data:
#
#cl> lpar xtcoeff
#        objin = "obj039.fits"   Input Mosaic image name
#         thug = 7               Chip causing ghosts
#       victim = 8               Chip where ghosts appear
#      (satmin = 20000)          Saturation minimum level in thug chip
#      (satmax = INDEF)          Saturation maximum level in thug chip
#     (mingood = -100)           Minimum good data value in victim chip
#       (xbox1 = 8)              initial filter and blkavg X size
#       (ybox1 = 8)              initial filter and blkavg Y size
#       (xbox2 = 25)             second filter X size
#       (ybox2 = 25)             second filter Y size
#     (verbose = no)             verbose output?
#        (coef = 1.3082177912399E-5) Returned crosstalk coefficient
#       (dcoef = 1.1942475451301E-6) Returned coefficient error estimate
#
#You will probably want to set mingood=-100 or so (any value that is a
#few sigma below the mode in all regions of your input image is fine).
#Leave [xy]box[12] alone; they're tuned for reasonably fast operation and
#have no other important effect.  "coef" and "dcoef" are output
#parameters; there's no need to fiddle with them on input.
#
#satmin and satmax determine the range of pixel values in the "thug" chip
#that get studied.  For the saturated pixels, take satmin to be perhaps a
#hundred or a thousand ADU below the saturation level, and satmax=INDEF.
#If you want to check that the crosstalk is really linear, try some other
#values of satmin and satmax (e.g. satmin=7000 satmax=9000) and see if
#the coefficients remain consistent within their quoted error bars.
#
#To characterize the crosstalk completely you need to run the script 56
#times, for all possible combinations of "thug" and "victim".  Really,
#eight times is enough if you believe that the effect is in the arcons
#and can only go between "paired" chips.  What I've done lately is to do
#56 runs and use the chip 1 vs. chips 3-8 coefficients and similar ones
#that ought to be zero to estimate the systematic errors in the
#coefficients.
#
#(I just write a dumb batch file called [e.g.] batch_xt to do them all,
#and [starting at a unix prompt] do  "script xtlog ; cl ; task xtcoeff =
#"xtcoeff.cl" ; cl < batch_xt ; logout ; exit" after which I examine the
#log in "xtlog".  Running all 56 possible chip pairs takes several hours.)
#
#Let me know how it goes, any of you that try it.
#							James.
#
#>From rhoads@noao.edu Mon Aug 30 12:02:07 1999
#Date: Mon, 30 Aug 99 12:02:04 MST
#From: rhoads@noao.edu (James Rhoads)
#To: bjannuzi@noao.edu, dmac@as.arizona.edu, fvaldes@noao.edu, gjacoby@noao.edu,
#        tarmandroff@noao.edu
#Subject: Here's the script

procedure xtcoeff( objin, thug, victim )
# purpose of this procedure is to characterize level of electronics
# ghosts in Mosaic images.  These ghosts are produced by some sort
# of crosstalk in ARCON readout electronics shared by pairs of chips.

string objin {prompt="Input Mosaic image name"}
int thug   {4,prompt="Chip causing ghosts"}
int victim {3,prompt="Chip where ghosts appear"}
real satmin {prompt="Saturation minimum level in thug chip"}
real satmax {INDEF,prompt="Saturation maximum level in thug chip"}
real mingood {prompt="Minimum good data value in victim chip"}
int xbox1=8  {prompt = "initial filter and blkavg X size"}
int ybox1=8  {prompt = "initial filter and blkavg Y size"}
int xbox2=25  {prompt = "second filter X size"}
int ybox2=25  {prompt = "second filter Y size"}
bool verbose  {no, prompt="verbose output?"}
real coef {prompt = "Returned crosstalk coefficient"}
real dcoef {prompt = "Returned coefficient error estimate"}

# Procedure:  First make an copy of "victim" with all saturated
#  pixels clobbered.
# Median smooth this image (excluding clobbered pixels) to make a sky frame.
# Subtract this from the victim image.
# Now clobber all pixels in the sky-subtracted victim image whose
#  corresponding pixels in the thug image have intensities outside
#  the interval (satmin, satmax).
# Generate image statistics of the unflagged pixels.
# Then get image statistics of the same set of pixels (more or less) in the
# thug image, and statistics of sky in the thug image.
# Finally, compute the crosstalk coefficient and the dominant term
# in its error estimate.

begin
  int lt, lv, nxpix, nypix
  real lsmin, lsmax, lmgood, flag, x1, x2, y1, y2, maxsky, maxthug
  real t_slev, t_glev, v_glev, v_grms, t_grms, t_srms
  real v_dglev, t_dglev, t_dslev
  int v_gnpix, t_gnpix, t_snpix
  string l_in, l_out, tmpsky, tmpskysmall

  l_in = objin
  lt = thug
  lv = victim
  lsmin = satmin
  lsmax = satmax
  lmgood = mingood
  flag = lmgood - abs(lmgood) - 100.
  l_out = mktemp( "xtcoef_im_" )

  tmpsky = mktemp("xtcoef_s1_")
  tmpskysmall = mktemp("xtcoef_s2_")

  if (lsmax == INDEF) {
     imstat( l_in//"["//str(lt)//"]", fields="max", lower=INDEF,
        upper=INDEF, format=no) | scan(maxthug)
     lsmax = 2.*abs(maxthug)
  }

  imexpr( "b>c && b& "dev$null" )
   }

  imstat( tmpskysmall, fields="max", lower=INDEF, upper=INDEF, 
    format=no) | scan(maxsky)
  lmgood = lmgood - maxsky
  flag = flag - maxsky - abs(lmgood)

  imexpr( "b>d && binfile)
#	inimglist = infile
#
## Loop through images
#	while (fscan(inimglist,img) != EOF) {
#
#	   imstat(img,fields="mean,stddev,npix,midpt,mode",
#		lower=lower,upper=upper,for-) | scan(mn,sig,npx,med,mod)
#
#	   m = 1
##	   if (verbose) print(img//" :")
#	   while (m <= maxiter)  {
#	   	if (verbose)
#	   	   print(img,": mean=",mn," rms=",sig," npix=",npx," median=",med,
#	   	      " mode=",mod)
#	   	ll = mn - (nsigrej*sig)
#	   	ul = mn + (nsigrej*sig)
#		if (lower != INDEF && ll < lower) ll = lower
#		if (upper != INDEF && ul > upper) ul = upper
#	   	imstat(img,fields="mean,stddev,npix,midpt,mode",
#	   	       lower=ll,upper=ul,for-) | scan(mn,sig,nx,med,mod)
#	   	if (nx == npx)
#	   		break
#	   	npx = nx
#	   	m = m + 1
#	   }
#
##	   if (print && !verbose) print (img//" :")
#	   if (print && !verbose) 
#	      print(img,": mean=",mn," rms=",sig," npix=",npx," median=",med,
#	   	      " mode=",mod)
#	   mean = mn
#	   sigma = sig
#	   median = med
#	   valmode = mod
#	   npix = npx
#
#	}
#
#	delete (infile,ver-)
#	inimglist = ""
#
#end
mscred-5.05-2018.07.09/src/msctoshort.cl000066400000000000000000000041111332166314300172770ustar00rootroot00000000000000# MSCTOSHORT -- Convert Mosaic data to scaled short.

procedure msctoshort (input, output)

string	input			{prompt="List of input Mosaic files"}
string	output			{prompt="List of output Mosaic files"}
real	maxbscale = INDEF	{prompt="Maximum BSCALE allowed\n"}

struct	*fd1, *fd2

begin
	file	inlist, extlist, temp1, temp2
	file	in, out, inextn, outextn
	int	nextn
	struct	extname

	inlist = mktemp ("tmp$iraf")
	extlist = mktemp ("tmp$iraf")
	temp1 = mktemp ("tmp") // ".fits"
	temp2 = mktemp ("tmp") // ".fits"

	# Query parameters.
	in = input
	out = output

	# Expand lists.
	sections (in, option="fullname", > extlist)
	nextn = sections.nimages
	sections (out, option="fullname") | joinlines (extlist, "STDIN",
	    output=inlist, delim=" ", missing="", maxch=181, shortest-,
	    verbose-)
	delete (extlist, verify-)
	if (sections.nimages > 0 && sections.nimages != nextn) {
	    delete (inlist, verify-)
	    error (1, "Input and output lists don't match")
	}

	fd1 = inlist
	while (fscan (fd1, in, out) != EOF) {
	    if (nscan() == 1)
		out = in
	    if (out == in)
		out = temp2
	    i = strlen (out)
	    if (i <= 5 || substr(out,i-4,i) != ".fits")
		out = out // ".fits"

	    imcopy (in//"[0]", out, verbose+)

	    mscextensions (in, output="file", index="1-", extname="", extver="",
		lindex-, lname+, lver-, ikparams="noinherit", > extlist)

	    fd2 = extlist
	    nextn = 0
	    while (fscan (fd2, inextn) != EOF) {
		nextn = nextn + 1
		printf ("%s[%d]\n", out, nextn) | scan (outextn)
		hselect (inextn, "extname", yes) | scan (extname)

		printf ("%s -> %s\n", inextn, outextn)
		toshort (inextn, temp1, bpmasks="", datamin=INDEF,
		    datamax=INDEF, maxbscale=maxbscale, logfile="")
		fxcopy (temp1, out, groups="", new-, verbose+)
		imdelete (temp1, verify-)
		hedit (outextn, "extname", extname,
		    add+, del-, verify-, show+, update+)
#		hedit (outextn, "inherit", "T",
#		    add+, del-, verify-, show+, update+)
	    }
	    fd2 = ""; delete (extlist, verify-)

	    if (out == temp2) {
		imdelete (in, verify-)
		imrename (out, in, verbose+)
	    }
	}
	fd1 = ""; delete (inlist, verify-)
end
mscred-5.05-2018.07.09/src/msctvmark.cl000066400000000000000000000027231332166314300171100ustar00rootroot00000000000000# MSCTVMARK -- Mark list of objects given in celestial coordinates.
#
# The mosaic geometry file is that produced by the last MSCDISPLAY.

procedure msctvmark (coords, frame)

file	coords		{prompt="List of coordinates"}
int	frame		{prompt="Display frame"}
file	output		{prompt="Output file of pixel coordinates and labels"}
string	fields = "1,2,3" {prompt="Fields for RA, DEC, and ID"}
string	wcs = "world"	{prompt="Coordinate type (logical|physical|world)",
			 enum="logical|physical|world"}
string	mark = "circle"	{prompt="Mark type",
			 enum="point|circle|rectangle|line|plus|cross|none"}
string	radii = "10"	{prompt="Radii of concentric circles"}
string	lengths = "0"	{prompt="Lengths and width of concentric rectangles"}
string	font = "raster"	{prompt="Default font"}
int	color = 204	{prompt="Gray level of marks to be drawn"}
bool	label = no	{prompt="Label the marked coordinates"}
int	nxoffset = 0	{prompt="X offset in display pixels of number"}
int	nyoffset = 0	{prompt="Y offset in display pixels of number"}
int	pointsize = 3	{prompt="Size of mark type point in display pixels"}
int	txsize = 1	{prompt="Size of text and numbers in font units"}

begin
	file	crd
	int	frm

	# Query parameters
	crd = coords
	frm = frame

	mscztvmark (crd, frm, "uparm$mscdisp"//frm, output=output,
	    fields=fields, wcs=wcs, mark=mark, radii=radii,
	    lengths=lengths, font=font, color=color, label=label,
	    nxoffset=nxoffset, nyoffset=nyoffset, pointsize=pointsize,
	    txsize=txsize)
end
mscred-5.05-2018.07.09/src/mscuniq.par000066400000000000000000000001201332166314300167310ustar00rootroot00000000000000input,s,a,,,,Input file of image names
output,s,a,,,,Output file of image names
mscred-5.05-2018.07.09/src/mscwcs.par000066400000000000000000000007501332166314300165620ustar00rootroot00000000000000images,s,a,,,,List of mosaic exposures
ra_shift,r,h,0.,,,RA shift (arc sec)
dec_shift,r,h,0.,,,Dec shift (arc sec)
ra_mag,r,h,1.,,,RA magnification
dec_mag,r,h,1.,,,Dec magnification
ra_rot,r,h,0.,,,RA rotation (deg)
dec_rot,r,h,0.,,,Dec rotation (deg)
forward,b,h,yes,,,Forward transformation?
ngrid,i,h,100,4,,Number of grid points
xxorder,i,h,3,2,,Order of xi fit in x
xyorder,i,h,3,2,,Order of xi fit in y
yxorder,i,h,3,2,,Order of eta fit in x
yyorder,i,h,3,2,,Order of eta fit in y
mscred-5.05-2018.07.09/src/mscwcs.x000066400000000000000000000176711332166314300162610ustar00rootroot00000000000000include	

define	WCS_NCT		4		# Number of transformations
define	LEN_MSCWCS	(3+WCS_NCT*3)

define	WCS_MW		Memi[$1]	# Image MWCS pointer
define	WCS_MWP		Memi[$1+1]	# Projection MWCS pointer

define	WCS_DIR		Memi[$1+$2*3]	# Direction of transformation
define	WCS_CT		Memi[$1+$2*3+1]	# Transformation
define	WCS_CTP		Memi[$1+$2*3+2]	# Projection transformation

define	WCS_TYPES	"|logical|physical|astrometry|world|"
define	L2P		12	# logical to physical
define	L2A		13	# logical to astrometry
define	L2W		14	# logical to world
define	P2L		21	# physical to logical
define	P2A		23	# physical to astrometry
define	P2W		24	# physical to world
define	A2L		31	# world to logical
define	A2P		32	# world to physical
define	A2W		34	# world to astrometry
define	W2L		41	# world to logical
define	W2P		42	# world to physical
define	W2A		43	# world to astrometry


# MSC_OPENIM -- Open Mosaic WCS.

pointer procedure msc_openim (im, wcs)

pointer	im		#I Image
pointer	wcs		#O WCS

pointer	sp, attrib, database, solution, mw

int	nscan()
pointer	ccsetwcs(), mw_openim()

errchk	ccsetwcs, mw_openim, msc_open

begin
	call smark (sp)
	call salloc (attrib, SZ_LINE, TY_CHAR)
	call salloc (database, SZ_FNAME, TY_CHAR)
	call salloc (solution, SZ_FNAME, TY_CHAR)

	iferr {
	    ifnoerr (call imgstr (im, "wcssol", Memc[attrib], SZ_LINE)) {
		call sscan (Memc[attrib])
		call gargwrd (Memc[database], SZ_FNAME)
		call gargwrd (Memc[solution], SZ_FNAME)
		if (nscan() != 2)
		    call error (1, "Invalid WCSSOL keyword")
		mw = ccsetwcs (im, Memc[database], Memc[solution])
	    } else
		mw = mw_openim (im)

	    call msc_open (mw, wcs)
	} then {
	    call msc_close (wcs)
	    call sfree (sp)
	    call erract (EA_ERROR)
	}

	call sfree (sp)
	return (WCS_MW(wcs))
end


# MSC_OPEN -- Open Mosaic WCS.

procedure msc_open (mw, wcs)

pointer	mw		#I MWCS pointer
pointer	wcs		#O WCS

int	axes[2]
double	r[2], w[2], cd[2,2]
pointer	sp, attrib, mwp

bool	streq()
pointer	mw_open()

data	axes/1,2/

begin
	call smark (sp)
	call salloc (attrib, SZ_LINE, TY_CHAR)

	iferr {
	    call calloc (wcs, LEN_MSCWCS, TY_STRUCT)

	    # Set projection MWCS for computing "astrometry" coordinates.
	    mwp = mw_open (NULL, 2)
	    call mw_gsystem (mw, Memc[attrib], SZ_LINE)
	    if (!streq (Memc[attrib], "physical")) {
		iferr {
		    call mw_newsystem (mwp, Memc[attrib], 2)
		    call mw_swtype (mwp, axes, 2, "tan", "")
		    call mw_gwattrs (mw, 1, "axtype", Memc[attrib], SZ_LINE)
		    call mw_swattrs (mwp, 1, "axtype", Memc[attrib])
		    call mw_gwattrs (mw, 2, "axtype", Memc[attrib], SZ_LINE)
		    call mw_swattrs (mwp, 2, "axtype", Memc[attrib])
		    call mw_gwtermd (mw, r, w, cd, 2)
		    r[1] = 0; r[2] = 0
		    cd[1,1] = 1; cd[1,2] = 0; cd[2,1] = 0; cd[2,2] = 1
		    call mw_swtermd (mwp, r, w, cd, 2)
		} then {
		    call erract (EA_WARN)
		    call mw_close (mwp)
		    mwp = mw_open (NULL, 2)
		}
	    }

	    WCS_MW(wcs) = mw
	    WCS_MWP(wcs) = mwp
	} then {
	    call msc_close (wcs)
	    call sfree (sp)
	    call erract (EA_ERROR)
	}

	call sfree (sp)
end


# MSC_CLOSE - Close Mosaic WCS.

procedure msc_close (wcs)

pointer	wcs		#I WCS

int	ct

begin
	if (wcs == NULL)
	    return

	do ct = 1, WCS_NCT {
	    if (WCS_CT(wcs,ct) != NULL)
		call mw_ctfree (WCS_CT(wcs,ct))
	    if (WCS_CTP(wcs,ct) != NULL)
		call mw_ctfree (WCS_CTP(wcs,ct))
	}
	if (WCS_MW(wcs) != NULL)
	    call mw_close (WCS_MW(wcs))
	if (WCS_MWP(wcs) != NULL)
	    call mw_close (WCS_MWP(wcs))
	call mfree (wcs, TY_STRUCT)
end


# MSC_SCTRAN -- Set up the coordinate transformation.
# The default is to copy the input coordinates to the output coordinates.
#
# Add new system "astrometry".

pointer procedure msc_sctran (wcs, ct,  system1, system2, ax)

pointer	wcs		#I WCS structure
int	ct		#I Coordinate system index
char	system1[ARB]	#I Input system
char	system2[ARB]	#I Output system
int	ax		#I Axes

char	sys1[10], sys2[10]
bool	streq()
int	strdic()
pointer	mw_sctran()

begin
	if (ct < 1 || ct > WCS_NCT)
	    call error (1, "Coordinate system index out of bounds")

	if (WCS_CT(wcs,ct) != NULL)
	    call mw_ctfree (WCS_CT(wcs,ct))
	if (WCS_CTP(wcs,ct) != NULL)
	    call mw_ctfree (WCS_CTP(wcs,ct))

	WCS_DIR(wcs,ct) = 10 * strdic (system1, sys1, 10, WCS_TYPES) +
	    strdic (system2, sys2, 10, WCS_TYPES)
	if (streq (sys1, "astrometry"))
	    call strcpy ("world", sys1, 10)
	if (streq (sys2, "astrometry"))
	    call strcpy ("world", sys2, 10)

	WCS_CT(wcs,ct) = mw_sctran (WCS_MW(wcs), sys1, sys2, ax)
	switch (WCS_DIR(wcs,ct)) {
	case L2A, P2A, W2A:
	    WCS_CTP(wcs,ct) = mw_sctran (WCS_MWP(wcs),"world","physical",ax)
	case A2L, A2P, A2W:
	    WCS_CTP(wcs,ct) = mw_sctran (WCS_MWP(wcs),"physical","world",ax)
	}
	return (WCS_CT(wcs,ct))
end


procedure msc_ctrand (wcs, ct, in, out, ndim)

pointer	wcs			#I WCS pointer
int	ct			#I Coordinate system index
double	in[ARB]			#I Input coordinate
double	out[ARB]		#O Output coordinate
int	ndim			#I Dimensionality of coordinate

begin
	if (ct < 1 || ct > WCS_NCT)
	    call error (1, "Coordinate system index out of bounds")

	if (ndim != 2)
	    call error (1, "MSC_CTRAND - WCS dimensionality not supported")

	call msc_c2trand (wcs, ct, in[1], in[2], out[1], out[2])
end


procedure msc_ctranr (wcs, ct, in, out, ndim)

pointer	wcs			#I WCS pointer
int	ct			#I Coordinate system index
real	in[ARB]			#I Input coordinate
real	out[ARB]		#O Output coordinate
int	ndim			#I Dimensionality of coordinate

begin
	if (ct < 1 || ct > WCS_NCT)
	    call error (1, "Coordinate system index out of bounds")

	if (ndim != 2)
	    call error (1, "MSC_CTRAND - WCS dimensionality not supported")

	call amovr (in, out, ndim)
	call msc_c2tranr (wcs, ct, in[1], in[2], out[1], out[2])
end

procedure msc_c2tranr (wcs, ct, x, y, xt, yt)

pointer	wcs			#I WCS pointer
int	ct			#I Coordinate system index
real	x, y                    #I initial position
real	xt, yt                  #O transformed position

double	dxt, dyt

begin
	if (ct < 1 || ct > WCS_NCT)
	    call error (1, "Coordinate system index out of bounds")

	call msc_c2trand (wcs, ct, double(x), double(y), dxt, dyt)
	xt = dxt
	yt = dyt
end


# MSC_C2TRAND -- Evaluate the coordinates using the full transformation.

procedure msc_c2trand (wcs, ct, x, y, xt, yt)

pointer	wcs			#I WCS pointer
int	ct			#I Coordinate system index
double  x, y                    #I initial position
double  xt, yt                  #O transformed position

double	x1, y1, x2, y2

begin
	if (ct < 1 || ct > WCS_NCT)
	    call error (1, "Coordinate system index out of bounds")

	x2 = x
	y2 = y

	switch (WCS_DIR(wcs,ct)) {
	case L2A, P2A:
	    call mw_c2trand (WCS_CT(wcs,ct), x2, y2, x1, y1)
	    call mw_c2trand (WCS_CTP(wcs,ct), x1, y1, xt, yt)
	    xt = xt * 3600.
	    yt = yt * 3600.
	case A2L, A2P:
	    x1 = x2 / 3600.
	    y1 = y2 / 3600.
	    call mw_c2trand (WCS_CTP(wcs,ct), x1, y1, x1, y1)
	    call mw_c2trand (WCS_CT(wcs,ct), x1, y1, xt, yt)
	case W2A:
	    call mw_c2trand (WCS_CTP(wcs,ct), x2, y2, xt, yt)
	    xt = xt * 3600.
	    yt = yt * 3600.
	case A2W:
	    x1 = x2 / 3600.
	    y1 = y2 / 3600.
	    call mw_c2trand (WCS_CTP(wcs,ct), x1, y1, xt, yt)
	default:
	    call mw_c2trand (WCS_CT(wcs,ct), x2, y2, xt, yt)
	}
end


int procedure msc_wcsstati (wcs, param)

pointer	wcs		#I WCS pointer
char	param[ARB]	#I Parameter

bool	streq()

begin
	if (streq (param, "mw"))
	    return (WCS_MW(wcs))
	else if (streq (param, "projection"))
	    return (WCS_MWP(wcs))
	else
	    call error (1, "msc_wcsstati: unknown parameter")
end


double procedure msc_wcsstatd (wcs, param)

pointer	wcs		#I WCS pointer
char	param[ARB]	#I Parameter

double	r[2], w[2], cd[2,2], scale
bool	streq()

begin
	if (streq (param, "scale")) {
	    call mw_gwtermd (WCS_MW(wcs), r, w, cd, 2)
	    scale = sqrt((cd[1,1]**2+cd[2,1]**2+cd[1,2]**2+cd[2,2]**2)/2.)
	    return (scale * 3600.)
	} else if (streq (param, "crpix1")) {
	    call mw_gwtermd (WCS_MW(wcs), r, w, cd, 2)
	    return (r[1])
	} else if (streq (param, "crpix2")) {
	    call mw_gwtermd (WCS_MW(wcs), r, w, cd, 2)
	    return (r[2])
	} else
	    call error (1, "msc_wcsstatd: unknown parameter")
end
mscred-5.05-2018.07.09/src/mscwfits.cl000066400000000000000000000007161332166314300167400ustar00rootroot00000000000000# MSCWFITS -- Write Mosaic FITS files to tape.

procedure mscwfits (input, output, newtape)

string	input		{prompt="Mosaic FITS files"}
string	output		{prompt="Output tape"}
bool	newtape		{prompt="Blank tape?"}
bool	shortlist = yes	{prompt="Short listing?"}
bool	longlist = no	{prompt="Long listing?"}

begin
	mscred.fitscopy (input, output, newtape, listonly=no,
	    shortlist=shortlist, longlist=longlist, intape=no, outtape=yes,
	    blocking_factor=10)
end
mscred-5.05-2018.07.09/src/mscwtemplate.par000066400000000000000000000007061332166314300177710ustar00rootroot00000000000000input,s,a,,,,List of input images
output,f,a,,,,Output WCS template image
wcssource,s,h,"image","|image|parameters|",,Output WCS source (image|parameters)
reference,f,h,"",,,Reference image
ra,r,h,INDEF,0,24,RA of tangent point (hours)
dec,r,h,INDEF,-90,90,DEC of tangent point (degrees)
scale,r,h,INDEF,,,Scale (arcsec/pixel)
rotation,r,h,INDEF,-360,360,Rotation of DEC from N to E (degrees)
projection,s,h,"",,,WCS projection
verbose,b,h,no,,,Verbose?
mscred-5.05-2018.07.09/src/mscxcor.par000066400000000000000000000016251332166314300167430ustar00rootroot00000000000000input,s,a,,,,List of input mosaic exposures
reference,s,a,,,,Reference image
coords,f,a,"",,,Region coordinates (world)
bootstrap,b,h,yes,,,Bootstrap registrations?
extnames,s,h,"",,,Extensions names to use for registration
override,b,h,no,,,Override previous registration
region,i,h,50,10,,Size of correlation region (pixels)
window,i,h,21,5,,Size of correlation window (pixels)
nregions,i,h,3,1,,Number of regions per overlap
cortype,s,h,"discrete","discrete|fourier|difference",,Correlation type
center,s,h,"centroid","none|centroid|sawtooth|parabolic",,Correlation peak centering type
box,i,h,7,3,,Correlation peak centering box size (pixels)
maxsigma,r,h,0.5,0.,,Maximum sigma in correlation shift sample (pixels)
verbose,b,h,)_.verbose,,,Print verbose information?
interactive,b,h,no,,,Interactive review of correlations?
graph,b,h,no,,,Graph correlation contours?
display,b,h,no,,,Display correlation regions?
mscred-5.05-2018.07.09/src/mscxreg.cl000066400000000000000000000055301332166314300165500ustar00rootroot00000000000000procedure mscxreg (input, output)

string	input		{prompt="Input data file"}
string	output		{prompt="Output data file"}

string	correlation = "discrete" {prompt="Cross-correlation function",
			enum="|discrete|fourier|difference|file|"}
int	window = 11	{prompt="Width of correlation window\n", min=3}

string	function = "centroid" {prompt="Correlation peak centering function",
			enum="|none|centroid|sawtooth|parabola|mark|"}
int	box = 5		{prompt="Box width for centering correlation peak\n",
			min=3}
real	xreject = 0.1	{prompt="Reject x shifts less than this value"}
real	yreject = 0.	{prompt="Reject y shifts less than this value\n"}

bool	verbose = no	{prompt="Verbose output?"}
bool	graph = no	{prompt="Graph correlations?"}
bool	display = no	{prompt="Display regions?"}
bool	interactive = no	{prompt="Interactive correlation fitting?"}
file	gcommands = "mscsrc$mscxreg.dat" {prompt="Graphics cursor commands"}
bool	accept = yes	{prompt="Accept shift?", mode="q"}

struct	*fd

begin
	file	temp
	string	in, ref, reg1, reg2, junk
	real	wx, wy, x1, y1, x2, y2, xlag, ylag, xshift, yshift
	bool	contour

	temp = mktemp ("tmp$iraf")

	if (verbose) {
	    printf ("MSCXREG:\n")
	    printf ("  correlation = %s, window = %d\n", correlation, window)
	    printf ("  function = %s, box = %d\n", function, box)
	}
	fd = input
	while (fscan (fd, wx, wy, in, x1, y1, reg1, ref, x2, y2, reg2) != EOF) {
	    if (nscan() != 10)
		next
	    contour = (interactive || graph)
	    if (display) {
		display (in//reg1, 1, zscale+, > "dev$null")
		display (ref//reg2, 2, zscale+, > "dev$null")
	    }
	    xlag = x1 - x2
	    ylag = y1 - y2
	    xreg (in, ref, reg2, temp, output="", databasefmt=no,
		append=yes, records="", coords="", xlag=xlag, ylag=ylag,
		dxlag=0, dylag=0, background="none", border=INDEF,
		loreject=INDEF, hireject=INDEF, apodize=0., filter="none",
		correlation=correlation, xwindow=window, ywindow=window,
		function=function, xcbox=box, ycbox=box,
		interactive=contour, verbose=no, gcommands=gcommands,
		> "dev$null")
	    type (temp) | scan (junk, xshift, yshift)
	    delete (temp, verify-)

	    if (abs (xlag) > 3. && abs (xshift) < xreject) {
		if (verbose) {
		    printf ("    Rejected because magnitude of x shift ")
		    printf ("is less than %g\n", xreject)
		}
		next
	    }
	    if (abs (ylag) > 3. && abs (yshift) < yreject) {
		if (verbose)
		    printf ("    Rejected because magnitude of y shift ")
		    printf ("is less than %g\n", yreject)
		next
	    }

	    xshift = xshift + xlag
	    yshift = yshift + ylag
	    x1 = x1 + xshift
	    y1 = y1 + yshift

	    if (verbose || interactive)
		printf ("  %s%s: x shift = %.2f, y shift = %.2f\n",
		    in, reg1, xshift, yshift)
	    if (interactive) {
		if (accept)
		    printf ("%s %g %g %g %g\n", in, wx, wy, x1, y1, >> output)
	    } else
		printf ("%s %g %g %g %g\n", in, wx, wy, x1, y1, >> output)
	}
	fd = ""
end
mscred-5.05-2018.07.09/src/msczero.cl000066400000000000000000000317031332166314300165630ustar00rootroot00000000000000# MSCZERO -- Display, measure coordinates, and adjust WCS zero point.

procedure msczero (input)

string	input			{prompt="List of mosaic exposures"}
string	extname = ""		{prompt="Extension name pattern"}
int	nframes = 2		{prompt="Number of frames to use"}
int	cbox = 11		{prompt="Centering box size (see imcntr)"}
bool	mark = yes		{prompt="Mark display?"}
file	logfile	= "default"	{prompt="Log file for measurements\n\n# MSCTVMARK Parameters"}

file	coords		{prompt="List of coordinates", mode="q"}
string	fields = "1,2,3" {prompt="Fields for RA, DEC, and ID"}
string	wcs = "world"	{prompt="Coordinate type (logical|physical|world)",
			 enum="logical|physical|world"}
string	catalog = "usnob1@noao"	{prompt="Catalog", mode="q"}
string	mtype = "circle" {prompt="Mark type",
			 enum="point|circle|rectangle|line|plus|cross|none"}
string	radii = "20"	{prompt="Radii of concentric circles", mode="q"}
int	color = 204	{prompt="Gray level of marks to be drawn", mode="q"}
bool	label = no	{prompt="Label the marked coordinates", mode="q"}
int	nxoffset = 20	{prompt="X offset in display pixels of number"}
int	nyoffset = 0	{prompt="Y offset in display pixels of number"}
int	pointsize = 3	{prompt="Size of mark type point in display pixels"}
int	txsize = 2	{prompt="Size of text and numbers in font units\n\n# Task query and internal parameters"}

string	ra		{prompt="RA (hours)", mode="q"}
string	dec		{prompt="DEC (degrees)", mode="q"}
string	id		{prompt="Identification", mode="q"}
real	mag		{prompt="Magnitude limit", mode="q"}
bool	update = yes	{prompt="Update WCS zero point?", mode="q"}
bool	updcoord = yes	{prompt="Update coordinate file?", mode="q"}

struct	*fd1, *fd2

begin
	bool	first, upd, cntr, markit, idquery, idlabel
	int	nim, frame, len, nlog, stat, nc, nl, nwcs, nwcs1, wcsver
	int	lineno, linemark
	int	tc1, tc2, tc3, tl1, tl2, tl3
	file	im, im1, wcsim1, crds
	file	mscdisp1, mscdisp2, wcsim, images, markcoord, sed, temp
	real	telra, teldec, crval1, crval2, dx, dy, dist, distmin
	real	wx, wy, wx1, wy1, ax, ay, r, d, c1, c2, l1, l2, cs, ls
	real	cmark, lmark
	string	key, junk, rastr, decstr, logf, id1, ramark, decmark, idmark
	string	imsec, imroot, trimsec, rad, cat, fmtra, fmtdec, fmtboth
	int	clr
	struct	cmd

	mscdisp1 = mktemp ("tmp$iraf")
	mscdisp2 = mktemp ("tmp$iraf")
	wcsim = mktemp ("tmp$iraf") // ".fits"
	images = mktemp ("tmp$iraf")
	markcoord = mktemp ("tmp$iraf")
	sed = mktemp ("tmp$iraf")
	temp = mktemp ("tmp$iraf")

	# Foreign command to edit coordinate list.
	task $msczsed = "$sed -f $(1) $(2) > $(3)"

	# Get task query parameters
	sections (input, option="fullname", > images)

	# Set default marking parameters.
	key = catalog.p_mode; catalog.p_mode = "h"; cat = catalog; catalog.p_mode = key
	key = radii.p_mode; radii.p_mode = "h"; rad = radii; radii.p_mode = key
	key = color.p_mode; color.p_mode = "h"; clr = color; color.p_mode = key

	# Set coordinate print format.
	if (wcs == "world") {
	    fmtra = "%.2H"; fmtdec = "%.1h"; fmtboth = "%.2H %.1h"
	} else {
	    fmtra = "%.2f"; fmtdec = "%.2f"; fmtboth = "%.2f %.2f"
	}

	# Initialize.
	nim = 0
	first = YES
	idquery = NO
	id1 = ""

	# Loop through list of images.
	fd1 = images
	while (fscan (fd1, im) != EOF) {
	    nim = nim + 1

	    # Strip ".fits".
	    len = strlen (im)
	    if (len > 5)
		if (substr (im, len-4, len) == ".fits")
		    im = substr (im, 1, len-5)

	    # Display image if needed.
	    frame = mod (nim - 1, nframes) + 1
	    mscdisplay (im, frame=frame, extname=extname, check+, select+)

	    # Make dummy WCS image for keeping modified WCS.
	    wcsver = 0
	    nwcs = 0
	    nwcs1 = 0
	    fd2 = "uparm$mscdisp" // frame
	    while (fscan (fd2, im1, c1, c2, l1, l2, nwcs1) != EOF) {
		if (nwcs1 > 0)
		    wcsver = 1
		nwcs = nwcs + 1
		printf ("%s[im%d]\n", wcsim, nwcs) | scan (wcsim1)
		printf ("%s %d %d %d %d %s %d\n",
		    wcsim1, c1, c2, l1, l2, im1, nwcs1, >> mscdisp1)

		# Merge any flip and trim.
		hselect (im1, "naxis1,naxis2", yes) | scan (nc, nl)
		imsec = "[*,*]"
		hselect (im1, "datasec", yes) | scan (imsec)
		hselect (im1, "trimsec", yes) | scan (imsec)
		trimsec = substr (imsec, 2, stridx(",",imsec)-1)
		if (fscanf (trimsec, "%d:%d", tc1, tc2) != 2) {
		    if (trimsec == "-*") {
			tc1 = nc
			tc2 = 1
		    } else {
			tc1 = 1
			tc2 = nc
		    }
		}
		tc3 = min (tc1, tc2)
		tc2 = max (tc1, tc2)
		tc1 = tc3
		trimsec = substr (imsec, stridx(",",imsec)+1,1000)
		if (fscanf (trimsec, "%d:%d", tl1, tl2) != 2) {
		    if (trimsec == "-*]") {
			tl1 = nl
			tl2 = 1
		    } else {
			tl1 = 1
			tl2 = nl
		    }
		}
		tl3 = min (tl1, tl2)
		tl2 = max (tl1, tl2)
		tl1 = tl3

		imsec = "[*,*]"
		sections (im1, option="section") | scan (imsec)
		trimsec = substr (imsec, 2, stridx(",",imsec)-1)
		if (trimsec == "-*") {
		    tc3 = tc1
		    tc1 = tc2
		    tc2 = tc3
		}
		trimsec = substr (imsec, stridx(",",imsec)+1,1000)
		if (trimsec == "-*]") {
		    tl3 = tl1
		    tl1 = tl2
		    tl2 = tl3
		}
		    
		# Extract a small piece for a WCS image.
		if (tc1 <= tc2)
		    tc3 = tc1 + 1
		else
		    tc3 = tc1 - 1
		if (tl1 <= tl2)
		    tl3 = tl1 + 1
		else
		    tl3 = tl1 - 1
		sections (im1, option="root") | scan (imroot)
		printf ("[%d:%d,%d:%d]\n", tc1, tc3, tl1, tl3) | scan (trimsec)
		imcopy (imroot//trimsec, wcsim1, verbose-)

		# Apply merged flip and trim to image name.
		if (tc1 != 1 || tc2 != nc || tl1 != 1 || tl2 != nl) {
		    printf ("[%d:%d,%d:%d]\n", tc1, tc2, tl1, tl2) |
			scan (trimsec)
		    im1 = imroot // trimsec
		}

		hselect (im1, "naxis1,naxis2", yes) | scan (nc, nl)
		printf ("%s %d %d %d %d %s %d %d %d\n",
		    wcsim1, c1, c2, l1, l2, im1, nc, nl, nwcs1, >> mscdisp2)
	    }

	    # Cursor loop.
	    dx = 0.; dy = 0.; nlog = 0 
	    while (fscan (imcur, wx, wy, nwcs, key, cmd) != EOF) {
		if (mod (nwcs, 100) == 0)
		    nwcs += 1

		# Initialize.
		cntr = NO
		markit = NO

		# Quit and/or change image.
		if (key == "n" || key == "p" || key == "q")
		    break

		# List keystrokes.
		if (key == "?") {
		    page ("mscsrc$msczero.key")
		    next
		}

		# Redisplay.
		if (key == "r") {
		    mscdisplay (im, frame=frame, extname=extname, check-)
		    if (access (markcoord))
			delete (markcoord, verify-)
		    next
		}

		# Toggle ID query.
		if (key == "i") {
		    idquery = (!idquery)
		    printf ("Coordinate ID query = %b\n", idquery)
		    next
		}

		# Mark coordinates.
		if (key == "m" || key == "u") {
		    if (access (markcoord))
			delete (markcoord, verify-)
		    if (access (sed) && access (crds)) {
			if (updcoord) {
			    printf ("updating %s ...\n", crds)
			    msczsed (sed, crds, temp)
			    delete (crds, verify-)
			    rename (temp, crds, field="all")
			}
		    }
		    if (access (sed))
			delete (sed, verify-)
		    if (key == "u") {
			cat = catalog
			crds = coords
			if (access (crds))
			    delete (crds, verify+)
			if (!access (crds)) {
			    mscgetcatalog (im, crds, magmin=0., magmax=mag,
				catalog=cat, rmin=0.)
			}
		    } else
			crds = coords
		    if (access (crds)) {
			rad = radii
			clr = color
			mscztvmark (crds, frame, mscdisp1, output=markcoord,
			    fields=fields, wcs=wcs, mark=mtype,
			    radii=rad, lengths="0", color=clr,
			    label=label, nxoffset=nxoffset,
			    nyoffset=nyoffset, pointsize=pointsize,
			    txsize=txsize)
		    } else
			printf ("WARNING: Coordinate list not found (%s)\n",
			    crds)

		    next
		}

		# Select marked object.
		if (key == "s" || key == "e") {
		    if (!access (markcoord)) {
			printf ("No coordinates marked\n")
			next
		    }

		    # Convert to detector coordinates if necessary.
		    if (wcsver == 1) {
			fd2 = mscdisp2
			while (fscan (fd2,wcsim1,c1,c2,l1,l2,im1,nc,nl,
			    nwcs1) != EOF) {
			    if (nwcs != nwcs1)
				next
			    cs = (c2 - c1) / (nc - 1)
			    ls = (l2 - l1) / (nl - 1)
			    wx = (wx - 1) * cs + c1
			    wy = (wy - 1) * ls + l1
			    break
			}
			fd2 = ""
		    }

		    distmin = 1E10
		    fd2 = markcoord
		    while (fscan (fd2,c1,l1,id1,rastr,decstr,lineno) != EOF) {
			dist = sqrt ((c1-wx)**2+(l1-wy)**2)
			if (dist < distmin) {
			    cmark = c1
			    lmark = l1
			    idmark = id1
			    ramark = rastr 
			    decmark = decstr
			    linemark = lineno
			    distmin = dist
			}
		    }
		    if (distmin < 1E10) {
			cmark = c1
			lmark = l1
			id1 = idmark
			ra = ramark
			dec = decmark
			printf ("Selected: %s %s %s\n",
			    ramark, decmark, idmark)
			first = no
		    } else
			id1 = ""

		    if (key == "s")
			next
		}

		# Set centroiding.
		if (key == "c" || key == "x" || key == "z")
		    cntr = YES

		# Select position for edit.
		if (key == "e") {
		    printf ("Select coordinate (c to centroid)\n")
		    if (fscan (imcur, wx, wy, nwcs, key, cmd) == EOF)
			error (1, "No cursor input")
		    if (mod (nwcs, 100) == 0)
			nwcs += 1
		    if (key == "c")
			cntr = YES
		    key = "e"
		}

		# Check log file.
		if (key == "w" || key == "x") {
		    if (fscan (logfile, logf) == 0)
			logf = "Coords." // im
		    if (logf == "default")
			logf = "Coords." // im
		    if (nlog == 0 && access (logf)) {
			printf ("Logfile exists - ")
			delete (logf, verify+)
		    }
		    nlog = nlog + 1
		}

		# Convert to individual extension coordinates.
		wx1 = -1
		wy1 = -1
		fd2 = mscdisp2
		while (fscan (fd2,wcsim1,c1,c2,l1,l2,im1,nc,nl,nwcs1) != EOF) {
		    if (wcsver == 1) {
			if (nwcs == nwcs1) {
			    wx1 = wx
			    wy1 = wy
			    break
			}
		    } else {
			if (wx<(c1-0.5)||wy<(l1-0.5)||wx>(c2+0.5)||wy>(l2+0.5))
			    next
			cs = (c2 - c1) / (nc - 1)
			ls = (l2 - l1) / (nl - 1)
			wx1 = (wx - c1) / cs + 1
			wy1 = (wy - l1) / ls + 1
			break
		    }
		}
		fd2 = ""

		if (wx1 < 0 || wy1 < 0) {
		    print ("Cursor position not in an image") 
		    next
		}

		# Centroid coordinate.
		if (cntr) {
		    imcntr (im1, wx1, wy1, cboxsize=cbox) |
			scan (junk,junk,wx1,junk,wy1)
		}

		# Convert to world coordinates.
		print (wx1, wy1) |
		mscctran ("STDIN", "STDOUT", wcsim1, "logical", "astrometry",
		    columns="1 2", units="", formats="",
		    min_sigdigit=9, verbose=no) | scan (ax, ay)
		print (ax, ay) |
		mscctran ("STDIN", "STDOUT", wcsim1, "astrometry", "world",
		    columns="1 2", units="", formats="", min_sigdigit=9,
		    verbose=no) | scan (wx, wy)

		# Print coordinate at cursor position with no centering.
		if (key == "\\040" || key == "c") {
		    printf (fmtboth//"\n", wx, wy)
		    if (key == "c")
			markit = mark

		# Write coordinate to logfile.
		} else if (key == "w" || key == "x") {
		    if (idquery) {
			id = id1
			id1 = id
		    }
		    printf ("Append to %s: "//fmtboth//" %s\n",
			logf, wx, wy, id1)
		    printf (fmtboth//" %s\n", wx, wy, id1, >> logf)
		    markit = mark

		# Edit coordinate in coordinate list.
		} else if (key == "e") {
		    if (id1 != "")
			printf ("%s: ", id1)
		    printf ("%s %s -> "//fmtboth//"\n", ramark, decmark, wx, wy)
		    printf ("%d,%ds/%s/"//fmtra//"/\n",
			linemark, linemark, ramark, wx, >> sed)
		    printf ("%d,%ds/%s/"//fmtdec//"/\n",
			linemark, linemark, decmark, wy, >> sed)
		    markit = mark

		# Adjust zero point.
		} else if (key == "z") {
		    printf (fmtboth//" %s\n", wx, wy, id1)
		    if (first) {
			printf (fmtra//"\n", wx) | scan (ra)
			printf (fmtdec//"\n", wy) | scan (dec)
			first = no
		    }
		    r = real (ra) * 15.
		    d = real (dec)
		    print (r, d) |
		    mscctran ("STDIN", "STDOUT", wcsim1, "world", "astrometry",
			columns="1 2", units="", formats="", min_sigdigit=9,
			verbose=no) | scan (wx1, wy1)
		    wx1 = wx1 - ax
		    wy1 = wy1 - ay
		    mscwcs (wcsim, ra_shift=wx1, dec_shift=wy1, ra_mag=1.,
			dec_mag=1., ra_rot=0., dec_rot=0., forward+)

		    # Cumulative shift.
		    dx = dx + wx1
		    dy = dy + wy1

		    wx = r
		    wy = d
		    markit = mark
		}

		# Mark on display.
		if (markit) {
		    if (id1 == "")
			idlabel = NO
		    else
			idlabel = YES
		    printf (fmtboth//" %s\n", wx, wy, id1) |
		    mscztvmark ("STDIN", frame, mscdisp1, output="",
			fields="1,2,3", wcs=wcs, mark=mtype,
			radii=rad, lengths="0", color=clr,
			label=idlabel, nxoffset=nxoffset,
			nyoffset=nyoffset, pointsize=pointsize,
			txsize=txsize)
		}

		# Cancel ID.
		id1 = ""
	    }

	    # Update if necessary.
	    if (dx != 0. && dy != 0.) {
		printf ("RA offset = %.2f arcsec", dx)
		printf (", DEC offset = %.2f arcsec\n", dy)
		if (update) {
		    printf ("updating %s ...\n", im)
		    mscwcs (im, ra_shift=dx, dec_shift=dy, ra_mag=1.,
			dec_mag=1., ra_rot=0., dec_rot=0., forward+)
		    printf ("done\n")
		}
		dx = 0.; dy = 0.
	    }
	    if (access (sed) && access (crds)) {
		if (updcoord) {
		    printf ("updating %s ...\n", crds)
		    msczsed (sed, crds, temp)
		    delete (crds, verify-)
		    rename (temp, crds, field="all")
		}
	    }

	    # Delete temporary files.
	    if (access (markcoord))
	        delete (markcoord, verify-)
	    if (access (sed))
		delete (sed, verify-)
	    imdelete (wcsim, verify-)
	    delete (mscdisp1, verify-)
	    delete (mscdisp2, verify-)

	    if (key == "q")
		break
	    if (key == "p") {
		if (nim == 1)
		    next
		fd1 = images
		for (len=1; len - print coordinate at cursor position
	c - center and print coordinate (*)
	e - edit the coordinate of a marked object from a coordinate list (*)
	i - Toggle queries for coordinate ID in 'w' and 'x'
	m - mark coordinates from a list of celestial coordinates
	r - redisplay
	s - select nearest marked object
	u - get and mark catalog coordinates MSCGETCATALOG
	w - write coordinate and ID at cursor position to log file (*)
	x - center and write coordinate and ID to log file (*)
	z - center, get new coordinate, set zero point offset (*)

	n - go to next mosaic exposure
	p - go to previous mosaic exposure
	q - quit

(*) The final coordinate will be marked on the display if the "mark" parameter
    is set.


e   The nearest coordinate from last marked coordinate list (marked with
    'm') is selected.  The cursor is used to define a new coordinate based on
    the current coordinate system.  This coordinate may be centroided if
    the 'c' key is used.  The coordinate list is updated, after a query,
    when that list or a new list is marked, when the image is changed, or
    when quiting.

m   A query is made for a coordinate filename.  If the file exists the
    coordinates are marked using MSCTVMARK.  You are queried for the
    radius of the circles to be drawn, the gray level (the color where
    red=204, green=205, blue=206, yellow=207, cyan=208, and magenta=209),
    and whether to draw labels.  Other marking parameters, such as the
    fields giving the RA, DEC, and ID, are part of the task parameters.

s   Select the nearest marked coordinate.  If no coordinates have been
    marked a warning is printed otherwise the RA, DEC, and ID are
    printed.  The selected coordinate becomes the default for the 'z'
    key and the selected ID becomes the default for the 'w' and 'x' keys
    when the ID query mode is enabled.

u   A query is made for a coordinate filename.  This is the file that will be
    created if it does not exist.  If an existing file is specified (such
    as that from a previous use of the 'u' key) you are asked if the
    file should be deleted.  If the file is not deleted then it is simply
    used to mark without getting new coordinates.  This useful for
    remarking after redisplaying or modifying the coordinate zero point.
    If the file is deleted or does not exist an internet catalog is
    accessed using MSCGETCATALOG with the queried magnitude limit.
    Finally the objects are marked with MSCTVMARK as described for the
    'm' key.  The labels are the magnitudes.

z   The position of the cursor is adjusted by centroiding and the coordinate
    based on the current coordinate system is determined and printed.  You
    are queried for a new RA and DEC with the default either being the
    estimated position (the first time), the last entered position, or the
    coordinate from the last select ('s') command.  The difference between
    the estimated and entered coordinates is used to adjust the zeropoint.
    All further coordinates derived or marked from a coordinate list will
    use the new zeropoint.  The zeropoint adjustments are done internally
    and do not change the data header until quiting or going to another
    image.
mscred-5.05-2018.07.09/src/mscztvmark.cl000066400000000000000000000135241332166314300173030ustar00rootroot00000000000000# MSCZTVMARK -- Mark list of objects given in celestial coordinates.
#
# The mosaic geometry file has lines with the image name, and pixel
# coordinates on the display corresponding to the image limits.
# An optional image may follow to use for the image sizes.  This feature
# is used by MSCZERO.

procedure mscztvmark (coords, frame, mscdisp)

file	coords		{prompt="List of coordinates"}
int	frame		{prompt="Display frame"}
file	mscdisp		{prompt="Mosaic geometry file"}
file	output		{prompt="Output file of pixel coordinates and labels"}
string	fields = "1,2,3" {prompt="Fields for RA, DEC, and ID"}
string	wcs = "world"	{prompt="Coordinate type (logical|physical|world)",
			 enum="logical|physical|world"}
string	mark = "circle"	{prompt="Mark type",
			 enum="point|circle|rectangle|line|plus|cross|none"}
string	radii = "10"	{prompt="Radii of concentric circles"}
string	lengths = "0"	{prompt="Lengths and width of concentric rectangles"}
string	font = "raster"	{prompt="Default font"}
int	color = 204	{prompt="Gray level of marks to be drawn"}
bool	label = no	{prompt="Label the marked coordinates"}
int	nxoffset = 0	{prompt="X offset in display pixels of number"}
int	nyoffset = 0	{prompt="Y offset in display pixels of number"}
int	pointsize = 3	{prompt="Size of mark type point in display pixels"}
int	txsize = 1	{prompt="Size of text and numbers in font units"}

struct	*fd1, *fd2

begin
	string	imroot, imsec, trimsec, str1, str2, str3
	file	crd, mscd, pix1, pix2, pix3, wcsim, im, out
	int	frm, nc, nl, lineno, nwcs
	int	tc1, tc2, tc3, tl1, tl2, tl3
	real	c1, c2, l1, cs, ls, l2, c, l, t, scale, cost, sint
	struct	str

	pix1 = mktemp ("tmp$iraf")
	pix2 = mktemp ("tmp$iraf")
	pix3 = mktemp ("tmp$iraf")

	# Get query parameters.
	crd = coords
	frm = frame
	mscd = mscdisp

	# Extract fields.
	fields (crd, fields, lines="", quit_if_miss=no, print_file_n=no, > pix3)

	# Add ID field if one is not present.
	fd1 = pix3
	lineno = 0
	while (fscan (fd1, str1, str2, str3) != EOF) {
	    if (str1 == "INDEF" || str2 == "INDEF")
	        next
	    lineno = lineno + 1
	    if (nscan() < 3)
		printf ("%s %s %d\n", str1, str2, lineno, >> pix2)
	    else
		printf ("%s %s %s\n", str1, str2, str3, >> pix2)
	}
	delete (pix3, verify-)
	if (access(pix2) == NO) {
	    printf ("No coordinates found (%s)\n", crd)
	    return
	}
	rename (pix2, pix3, field="all")

	# Get output file.
	out = ""
	print (output) | scan (out)
	if (out != "") {
	    fields (pix3, "1,2,3,1,2", quit_if_miss=no, print_file_n=no, > pix2)
	    delete (pix3, verify-)
	    rename (pix2, pix3, field="all")
	}

	fd1 = mscd
	while (fscan (fd1, wcsim, c1, c2, l1, l2, im, nwcs) != EOF) {
	    if (nscan() < 7)
		im = wcsim

	    # Merge any flip and trim.
	    hselect (im, "naxis1,naxis2", yes) | scan (nc, nl)
	    imsec = "[*,*]"
	    hselect (im, "datasec", yes) | scan (imsec)
	    hselect (im, "trimsec", yes) | scan (imsec)
	    trimsec = substr (imsec, 2, stridx(",",imsec)-1)
	    if (fscanf (trimsec, "%d:%d", tc1, tc2) != 2) {
		if (trimsec == "-*") {
		    tc1 = nc
		    tc2 = 1
		} else {
		    tc1 = 1
		    tc2 = nc
		}
	    }
	    tc3 = min (tc1, tc2)
	    tc2 = max (tc1, tc2)
	    tc1 = tc3
	    trimsec = substr (imsec, stridx(",",imsec)+1,1000)
	    if (fscanf (trimsec, "%d:%d", tl1, tl2) != 2) {
		if (trimsec == "-*]") {
		    tl1 = nl
		    tl2 = 1
		} else {
		    tl1 = 1
		    tl2 = nl
		}
	    }
	    tl3 = min (tl1, tl2)
	    tl2 = max (tl1, tl2)
	    tl1 = tl3

	    imsec = "[*,*]"
	    sections (im, option="section") | scan (imsec)
	    trimsec = substr (imsec, 2, stridx(",",imsec)-1)
	    if (trimsec == "-*") {
		tc3 = tc1
		tc1 = tc2
		tc2 = tc3
	    }
	    trimsec = substr (imsec, stridx(",",imsec)+1,1000)
	    if (trimsec == "-*]") {
		tl3 = tl1
		tl1 = tl2
		tl2 = tl3
	    }

	    # Apply merged flip and trim to image name.
	    if (tc1 != 1 || tc2 != nc || tl1 != 1 || tl2 != nl) {
		printf ("[%d:%d,%d:%d]\n", tc1, tc2, tl1, tl2) |
		    scan (trimsec)
		sections (im, option="root") | scan (imroot)
		if (im == wcsim)
		    wcsim = imroot // trimsec
		im = imroot // trimsec
	    }
	    
	    hselect (im, "naxis1,naxis2", yes) | scan (nc, nl)
	    cs = (c2 - c1) / (nc - 1)
	    ls = (l2 - l1) / (nl - 1)
	    mscctran (pix3, pix1, wcsim, wcs, "logical", columns="1 2",
		units="hours native", formats="", min_sigdigit=7, verbose=no)

#	    # Uncomment this to apply a WCS correction to the coordinates.
#	    mscctran (pix1, pix2, wcsim, "logical", "astrometry", columns="1 2",
#		units="native native", formats="", min_sigdigit=9, verbose=no)
#	    delete (pix1, verify-)
#	    t = 0.28
#	    scale = 1.001
#	    cost = scale * cos (t * 3.14159 / 180.)
#	    sint = scale * sin (t * 3.14159 / 180.)
#	    fd2 = pix2
#	    while (fscan (fd2, c, l, str) != EOF) {
#		x = c * cost + l * sint
#		y = -c * sint + l * cost
#		printf ("%g %g %s\n", x, y, str, >> pix1)
#	    }
#	    fd2 = ""; delete (pix2, verify-)
#	    mscctran (pix1, pix2, wcsim, "astrometry", "logical", columns="1 2",
#		units="native native", formats="", min_sigdigit=9, verbose=no)
#	    delete (pix1, verify-)
#	    rename (pix2, pix1, field="all")

	    lineno = 0
	    fd2 = pix1
	    while (fscan (fd2, c, l, str) != EOF) {
		if (nscan() != 3)
		    next
		lineno = lineno + 1
		c = c1 + cs * (c - 1)
		l = l1 + ls * (l - 1)
		if (c < c1 || c > c2 || l < l1 || l > l2)
		    next
		printf ("%.2f %.2f %s %d\n", c, l, str, lineno, >> pix2)
	    }
	    fd2 = ""; delete (pix1, verify-)


	    if (access (pix2)) {
		if (frm > 0)
		    tvmark (frm, pix2, logfile="", autolog=no, outimage="",
			deletions="", commands="", mark=mark, radii=radii,
			lengths=lengths, font=font, color=color, label=label,
			number=no, nxoffset=nxoffset, nyoffset=nyoffset,
			pointsize=pointsize, txsize=txsize, tolerance=1.5,
			interactive=no)

		if (out != "")
		    concatenate (pix2, out, out_type="in_type", append+)
		delete (pix2, verify-)
	    }

	}
	fd1 = ""

	delete (pix3, verify-)
end
mscred-5.05-2018.07.09/src/patblk.gx000066400000000000000000000054121332166314300163740ustar00rootroot00000000000000$for (ir)
# PATBLK_INIT --  Initialize block averging buffers.
# Memory is allocated with salloc assuming sfree won't be called until
# done with the block averaging.

procedure pblk_init$t (data, map, bufs, sumbuf, nc, nc1, nc2, nlbuf)

pointer	data			#I I/O data pointer
int	map			#I Use mapio?
pointer	bufs			#O Pointer to pointers of data lines
pointer	sumbuf			#O Pointer block summed data
int	nc			#I Number of unblocked columns
int	nc1			#I Column offset
int	nc2			#I Column offset
int	nlbuf			#I Number of lines to sum

int	i, j
pointer	buf, tmpbuf

pointer	imgl2$t()
$if (datatype == r)
pointer	map_gl$t()
$endif

begin
	# If no data is needed then return.
	if (nc1 == nc2 && nlbuf == 1) {
	    bufs = NULL
	    return
	}

	# Allocate and clear block averaging buffers.
	call salloc (bufs, nlbuf, TY_POINTER)
	do i = 1, nlbuf {
	    call salloc (Memi[bufs+i-1], nc, TY_PIXEL)
	    tmpbuf = Memi[bufs+i-1]
	    call aclr$t (Mem$t[tmpbuf], nc)
	}
	if (nlbuf > 1) {
	    call salloc (sumbuf, nc, TY_PIXEL)
	    call aclr$t (Mem$t[sumbuf], nc)
	} else
	    sumbuf = Memi[bufs]

	# Initialize block average buffers.
	do i = 1, nlbuf-1 {
	    $if (datatype == r)
	    if (map == YES)
		buf = map_gl$t (data, i, READ_ONLY) - nc1
	    else
	    $endif
		buf = imgl2$t (data, i) - nc1

	    tmpbuf = Memi[bufs+mod(i,nlbuf)]
	    call aclr$t (Mem$t[tmpbuf], nc)
	    do j = nc1, nc2
		call aadd$t (Mem$t[buf+j], Mem$t[tmpbuf], Mem$t[tmpbuf], nc)
	    if (nlbuf > 1)
		call aadd$t (Mem$t[tmpbuf], Mem$t[sumbuf], Mem$t[sumbuf], nc)
	}
end


# PATBLK -- Return block average with specified end line.
# A 1x1 block is allowed.
# The various input pointers must be initialized by pblk_init and this
# routine must be called sequencially through the lines.

procedure patblk$t (data, line, map, buf, bufs, sumbuf, nc, nc1, nc2, nlbuf)

pointer	data			#I I/O data pointer
int	line			#I Next line to read
int	map			#I Use mapio?
pointer	buf			#U Pointer to line of data
pointer	bufs			#I Pointer to pointers of data lines
pointer	sumbuf			#I Pointer block summed data
int	nc			#I Number of columns
int	nc1			#I Column offset
int	nc2			#I Column offset
int	nlbuf			#I Number of lines to sum

int	i
pointer	tmpbuf, imgl2$t()
$if (datatype == r)
pointer	map_gl$t()
$endif

begin
	# Get next line.
	$if (datatype == r)
	if (map == YES)
	    buf = map_gl$t (data, line, READ_ONLY) - nc1
	else
	$endif
	    buf = imgl2$t (data, line) - nc1

	# Do block averaging if needed.
	if (bufs != NULL) {
	    tmpbuf = Memi[bufs+mod(line,nlbuf)]
	    call asub$t (Mem$t[sumbuf], Mem$t[tmpbuf], mem$t[sumbuf], nc)
	    call aclr$t (Mem$t[tmpbuf], nc)
	    do i = nc1, nc2
		call aadd$t (Mem$t[buf+i], Mem$t[tmpbuf], Mem$t[tmpbuf], nc)
	    if (nlbuf > 1)
		call aadd$t (Mem$t[tmpbuf], Mem$t[sumbuf], Mem$t[sumbuf], nc)
	    buf = sumbuf
	}
end
$endfor
mscred-5.05-2018.07.09/src/patblk.x000066400000000000000000000117731332166314300162340ustar00rootroot00000000000000
# PATBLK_INIT --  Initialize block averging buffers.
# Memory is allocated with salloc assuming sfree won't be called until
# done with the block averaging.

procedure pblk_initi (data, map, bufs, sumbuf, nc, nc1, nc2, nlbuf)

pointer	data			#I I/O data pointer
int	map			#I Use mapio?
pointer	bufs			#O Pointer to pointers of data lines
pointer	sumbuf			#O Pointer block summed data
int	nc			#I Number of unblocked columns
int	nc1			#I Column offset
int	nc2			#I Column offset
int	nlbuf			#I Number of lines to sum

int	i, j
pointer	buf, tmpbuf

pointer	imgl2i()

begin
	# If no data is needed then return.
	if (nc1 == nc2 && nlbuf == 1) {
	    bufs = NULL
	    return
	}

	# Allocate and clear block averaging buffers.
	call salloc (bufs, nlbuf, TY_POINTER)
	do i = 1, nlbuf {
	    call salloc (Memi[bufs+i-1], nc, TY_INT)
	    tmpbuf = Memi[bufs+i-1]
	    call aclri (Memi[tmpbuf], nc)
	}
	if (nlbuf > 1) {
	    call salloc (sumbuf, nc, TY_INT)
	    call aclri (Memi[sumbuf], nc)
	} else
	    sumbuf = Memi[bufs]

	# Initialize block average buffers.
	do i = 1, nlbuf-1 {
		buf = imgl2i (data, i) - nc1

	    tmpbuf = Memi[bufs+mod(i,nlbuf)]
	    call aclri (Memi[tmpbuf], nc)
	    do j = nc1, nc2
		call aaddi (Memi[buf+j], Memi[tmpbuf], Memi[tmpbuf], nc)
	    if (nlbuf > 1)
		call aaddi (Memi[tmpbuf], Memi[sumbuf], Memi[sumbuf], nc)
	}
end


# PATBLK -- Return block average with specified end line.
# A 1x1 block is allowed.
# The various input pointers must be initialized by pblk_init and this
# routine must be called sequencially through the lines.

procedure patblki (data, line, map, buf, bufs, sumbuf, nc, nc1, nc2, nlbuf)

pointer	data			#I I/O data pointer
int	line			#I Next line to read
int	map			#I Use mapio?
pointer	buf			#U Pointer to line of data
pointer	bufs			#I Pointer to pointers of data lines
pointer	sumbuf			#I Pointer block summed data
int	nc			#I Number of columns
int	nc1			#I Column offset
int	nc2			#I Column offset
int	nlbuf			#I Number of lines to sum

int	i
pointer	tmpbuf, imgl2i()

begin
	# Get next line.
	    buf = imgl2i (data, line) - nc1

	# Do block averaging if needed.
	if (bufs != NULL) {
	    tmpbuf = Memi[bufs+mod(line,nlbuf)]
	    call asubi (Memi[sumbuf], Memi[tmpbuf], memi[sumbuf], nc)
	    call aclri (Memi[tmpbuf], nc)
	    do i = nc1, nc2
		call aaddi (Memi[buf+i], Memi[tmpbuf], Memi[tmpbuf], nc)
	    if (nlbuf > 1)
		call aaddi (Memi[tmpbuf], Memi[sumbuf], Memi[sumbuf], nc)
	    buf = sumbuf
	}
end

# PATBLK_INIT --  Initialize block averging buffers.
# Memory is allocated with salloc assuming sfree won't be called until
# done with the block averaging.

procedure pblk_initr (data, map, bufs, sumbuf, nc, nc1, nc2, nlbuf)

pointer	data			#I I/O data pointer
int	map			#I Use mapio?
pointer	bufs			#O Pointer to pointers of data lines
pointer	sumbuf			#O Pointer block summed data
int	nc			#I Number of unblocked columns
int	nc1			#I Column offset
int	nc2			#I Column offset
int	nlbuf			#I Number of lines to sum

int	i, j
pointer	buf, tmpbuf

pointer	imgl2r()
pointer	map_glr()

begin
	# If no data is needed then return.
	if (nc1 == nc2 && nlbuf == 1) {
	    bufs = NULL
	    return
	}

	# Allocate and clear block averaging buffers.
	call salloc (bufs, nlbuf, TY_POINTER)
	do i = 1, nlbuf {
	    call salloc (Memi[bufs+i-1], nc, TY_REAL)
	    tmpbuf = Memi[bufs+i-1]
	    call aclrr (Memr[tmpbuf], nc)
	}
	if (nlbuf > 1) {
	    call salloc (sumbuf, nc, TY_REAL)
	    call aclrr (Memr[sumbuf], nc)
	} else
	    sumbuf = Memi[bufs]

	# Initialize block average buffers.
	do i = 1, nlbuf-1 {
	    if (map == YES)
		buf = map_glr (data, i, READ_ONLY) - nc1
	    else
		buf = imgl2r (data, i) - nc1

	    tmpbuf = Memi[bufs+mod(i,nlbuf)]
	    call aclrr (Memr[tmpbuf], nc)
	    do j = nc1, nc2
		call aaddr (Memr[buf+j], Memr[tmpbuf], Memr[tmpbuf], nc)
	    if (nlbuf > 1)
		call aaddr (Memr[tmpbuf], Memr[sumbuf], Memr[sumbuf], nc)
	}
end


# PATBLK -- Return block average with specified end line.
# A 1x1 block is allowed.
# The various input pointers must be initialized by pblk_init and this
# routine must be called sequencially through the lines.

procedure patblkr (data, line, map, buf, bufs, sumbuf, nc, nc1, nc2, nlbuf)

pointer	data			#I I/O data pointer
int	line			#I Next line to read
int	map			#I Use mapio?
pointer	buf			#U Pointer to line of data
pointer	bufs			#I Pointer to pointers of data lines
pointer	sumbuf			#I Pointer block summed data
int	nc			#I Number of columns
int	nc1			#I Column offset
int	nc2			#I Column offset
int	nlbuf			#I Number of lines to sum

int	i
pointer	tmpbuf, imgl2r()
pointer	map_glr()

begin
	# Get next line.
	if (map == YES)
	    buf = map_glr (data, line, READ_ONLY) - nc1
	else
	    buf = imgl2r (data, line) - nc1

	# Do block averaging if needed.
	if (bufs != NULL) {
	    tmpbuf = Memi[bufs+mod(line,nlbuf)]
	    call asubr (Memr[sumbuf], Memr[tmpbuf], memr[sumbuf], nc)
	    call aclrr (Memr[tmpbuf], nc)
	    do i = nc1, nc2
		call aaddr (Memr[buf+i], Memr[tmpbuf], Memr[tmpbuf], nc)
	    if (nlbuf > 1)
		call aaddr (Memr[tmpbuf], Memr[sumbuf], Memr[sumbuf], nc)
	    buf = sumbuf
	}
end

mscred-5.05-2018.07.09/src/patfit.par000066400000000000000000000014671332166314300165600ustar00rootroot00000000000000input,s,a,,,,List of input images
output,s,a,,,,List of output images
pattern,s,a,,,,Pattern or list of patterns
weight,s,h,"",,,Weight or list of weights
masks,s,h,"",,,List of input image masks (optional)
patmasks,s,h,"",,,List of pattern image masks (optional)
background,s,h,"",,,List of input backgrounds (optional)
bkgpattern,s,h,"",,,List of pattern backgrounds (optional)
bkgweight,s,h,"",,,List of weight backgrounds (optional)
ncblk,i,h,1,,,Column smoothing
nlblk,i,h,1,,,Line smoothing
extfit,s,h,"",,,List of extension names to fit
extout,s,h,"",,,List of extension names to output
outtype,s,h,"none","none|fit|diff|ratio|flat|pfit|pdiff|pratio|pflat|sfit|sdiff|sratio|sflat",,Output type
logname,s,h,"PATFIT",,,Name for log and keyword identification
logfile,s,h,"",,,Logfile
verbose,b,h,yes,,,Verbose output?
mscred-5.05-2018.07.09/src/pixarea.par000066400000000000000000000002311332166314300167060ustar00rootroot00000000000000input,s,a,,,,List of input images
output,s,a,,,,List of output images
outtype,s,h,"area","area|multiply|divide",,Output type
norm,r,h,1.,,,Normalization
mscred-5.05-2018.07.09/src/pupilfit.par000066400000000000000000000027061332166314300171220ustar00rootroot00000000000000input,s,a,,,,List of input images
output,s,a,,,,List of output images
masks,s,h,"BPM",,,List of masks
type,s,h,"difference","data|fit|difference|ratio|mask",,Output type
lmedian,b,h,no,,,Subtract line-by-line median?
xc,r,h,0.,,,Pattern center offset (pixels)
yc,r,h,0.,,,Pattern center offset (pixels)
rin,r,h,300.,0.,,Radius of inner background ring (pixels)
drin,r,h,20.,1.,,Width of inner background ring (pixels)
rout,r,h,1500.,0.,,Radius of outer background ring (pixels)
drout,r,h,20.,1.,,Width of outer background ring (pixels)
funcin,s,h,"chebyshev","chebyshev|legendre|spline1|spline3",,Inner azimuthal background fitting function
orderin,i,h,2,1,,Inner azimuthal background fitting order
funcout,s,h,"spline3","chebyshev|legendre|spline1|spline3",,Outer azimuthal background fitting function
orderout,i,h,2,1,,Outer azimuthal background fitting order
rfunction,s,h,"spline3","chebyshev|legendre|spline1|spline3",,Radial profile fitting function
rorder,i,h,50,1,,Radial profile fitting order
sfunction,s,h,"spline3","chebyshev|legendre|spline1|spline3",,Radial profile fitting function
sorder,i,h,1,1,,Radial profile fitting order
abin,r,h,0.,0.,,Azimuthal bin (deg)
astep,r,h,0.,0.,,Azimuthal step (deg)
niterate,i,h,3,0,,Number of rejection iterations
lreject,r,h,3.,0.,,Low rejection rms factor
hreject,r,h,3.,0.,,High rejection rms factor
datamin,r,h,INDEF,,,Minimum good data value
datamax,r,h,INDEF,,,Maximum good data value
verbose,b,h,yes,,,Print information?
mscred-5.05-2018.07.09/src/rgstr.gx000066400000000000000000000056021332166314300162610ustar00rootroot00000000000000include 

$for (rd)

# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed
# fields are converted to strings; other fields are copied from the input
# line to the output buffer.

procedure rg_apack_line$t (inbuf, outbuf, maxch, field_pos, nfields,
    cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits)

char	inbuf[ARB]		#I the input string buffer
char	outbuf[maxch]		#O the output string buffer
int	maxch			#I the maximum size of the output buffer
int	field_pos[ARB]		#I starting positions for the fields
int	nfields			#I the number of fields
int	cinfields[ARB]		#I fields to be replaced
int	ncin			#I the number of input fields
PIXEL	coords[ARB]		#I the transformed coordinates
int	laxno[ARB]		#I the logical axis mapping
pointer	formats[ARB]		#I array of format pointers
int	nsdig[ARB]		#I array of numbers of significant digits
int	ncout			#I the number of coordinates	
int	min_sigdigits		#I the minimum number of signficant digits

int	op, num_field, width, cf, cfptr
pointer	sp, field
int	gstrcpy()

begin
	call smark (sp)
	call salloc (field, SZ_LINE, TY_CHAR)

	# Initialize output pointer.
	op = 1

	# Copy the file replacing fields as one goes.
	do num_field = 1, nfields {

	    # Find the width of the field.
	    width = field_pos[num_field + 1] - field_pos[num_field]

	    # Find the field to be replaced.
	    cfptr = 0
	    do cf = 1, ncin {
		if (cinfields[cf] != num_field)
		    next
		cfptr = cf
		    break
	    }

	    # Replace the field.
	    if (cfptr != 0) {
		if (laxno[cfptr] == 0)
	            call li_format_field$t ($INDEF$T, Memc[field], maxch,
		        Memc[formats[cfptr]], nsdig[cfptr], width,
			min_sigdigits)
		else
	            call li_format_field$t (coords[laxno[cfptr]], Memc[field],
		        maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]],
		        width, min_sigdigits)
	    } else {
	        # Put "width" characters from inbuf into field
		call strcpy (inbuf[field_pos[num_field]], Memc[field], width)
	    }

	    # Fields must be delimited by at least one blank.
	    if (num_field > 1 && !IS_WHITE (Memc[field])) {
		outbuf[op] = ' '
		op = op + 1
	    }

	    # Copy "field" to output buffer.
	    op = op + gstrcpy (Memc[field], outbuf[op], maxch)
	}

	do cfptr = ncin + 1, ncout {

	    # Copy out the extra fields if any.
	    if (laxno[cfptr] == 0)
	        call li_format_field$t ($INDEF$T, Memc[field], maxch, "%g",
		    min_sigdigits, width, min_sigdigits)
	    else
	        call li_format_field$t (coords[laxno[cfptr]], Memc[field],
		    maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]],
		    width, min_sigdigits)

	    # Fields must be delimited by at least one blank.
	    if (!IS_WHITE (Memc[field])) {
		outbuf[op] = ' '
		op = op + 1
	    }

	    # Copy "field" to output buffer.
	    op = op + gstrcpy (Memc[field], outbuf[op], maxch)
	}

	outbuf[op] = '\n'
	outbuf[op+1] = EOS

	call sfree (sp)
end


$endfor
mscred-5.05-2018.07.09/src/rgstr.x000066400000000000000000000132761332166314300161200ustar00rootroot00000000000000include 



# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed
# fields are converted to strings; other fields are copied from the input
# line to the output buffer.

procedure rg_apack_liner (inbuf, outbuf, maxch, field_pos, nfields,
    cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits)

char	inbuf[ARB]		#I the input string buffer
char	outbuf[maxch]		#O the output string buffer
int	maxch			#I the maximum size of the output buffer
int	field_pos[ARB]		#I starting positions for the fields
int	nfields			#I the number of fields
int	cinfields[ARB]		#I fields to be replaced
int	ncin			#I the number of input fields
real	coords[ARB]		#I the transformed coordinates
int	laxno[ARB]		#I the logical axis mapping
pointer	formats[ARB]		#I array of format pointers
int	nsdig[ARB]		#I array of numbers of significant digits
int	ncout			#I the number of coordinates	
int	min_sigdigits		#I the minimum number of signficant digits

int	op, num_field, width, cf, cfptr
pointer	sp, field
int	gstrcpy()

begin
	call smark (sp)
	call salloc (field, SZ_LINE, TY_CHAR)

	# Initialize output pointer.
	op = 1

	# Copy the file replacing fields as one goes.
	do num_field = 1, nfields {

	    # Find the width of the field.
	    width = field_pos[num_field + 1] - field_pos[num_field]

	    # Find the field to be replaced.
	    cfptr = 0
	    do cf = 1, ncin {
		if (cinfields[cf] != num_field)
		    next
		cfptr = cf
		    break
	    }

	    # Replace the field.
	    if (cfptr != 0) {
		if (laxno[cfptr] == 0)
	            call li_format_fieldr (INDEFR, Memc[field], maxch,
		        Memc[formats[cfptr]], nsdig[cfptr], width,
			min_sigdigits)
		else
	            call li_format_fieldr (coords[laxno[cfptr]], Memc[field],
		        maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]],
		        width, min_sigdigits)
	    } else {
	        # Put "width" characters from inbuf into field
		call strcpy (inbuf[field_pos[num_field]], Memc[field], width)
	    }

	    # Fields must be delimited by at least one blank.
	    if (num_field > 1 && !IS_WHITE (Memc[field])) {
		outbuf[op] = ' '
		op = op + 1
	    }

	    # Copy "field" to output buffer.
	    op = op + gstrcpy (Memc[field], outbuf[op], maxch)
	}

	do cfptr = ncin + 1, ncout {

	    # Copy out the extra fields if any.
	    if (laxno[cfptr] == 0)
	        call li_format_fieldr (INDEFR, Memc[field], maxch, "%g",
		    min_sigdigits, width, min_sigdigits)
	    else
	        call li_format_fieldr (coords[laxno[cfptr]], Memc[field],
		    maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]],
		    width, min_sigdigits)

	    # Fields must be delimited by at least one blank.
	    if (!IS_WHITE (Memc[field])) {
		outbuf[op] = ' '
		op = op + 1
	    }

	    # Copy "field" to output buffer.
	    op = op + gstrcpy (Memc[field], outbuf[op], maxch)
	}

	outbuf[op] = '\n'
	outbuf[op+1] = EOS

	call sfree (sp)
end




# RG_APACK_LINE -- Fields are packed into the output buffer. Transformed
# fields are converted to strings; other fields are copied from the input
# line to the output buffer.

procedure rg_apack_lined (inbuf, outbuf, maxch, field_pos, nfields,
    cinfields, ncin, coords, laxno, formats, nsdig, ncout, min_sigdigits)

char	inbuf[ARB]		#I the input string buffer
char	outbuf[maxch]		#O the output string buffer
int	maxch			#I the maximum size of the output buffer
int	field_pos[ARB]		#I starting positions for the fields
int	nfields			#I the number of fields
int	cinfields[ARB]		#I fields to be replaced
int	ncin			#I the number of input fields
double	coords[ARB]		#I the transformed coordinates
int	laxno[ARB]		#I the logical axis mapping
pointer	formats[ARB]		#I array of format pointers
int	nsdig[ARB]		#I array of numbers of significant digits
int	ncout			#I the number of coordinates	
int	min_sigdigits		#I the minimum number of signficant digits

int	op, num_field, width, cf, cfptr
pointer	sp, field
int	gstrcpy()

begin
	call smark (sp)
	call salloc (field, SZ_LINE, TY_CHAR)

	# Initialize output pointer.
	op = 1

	# Copy the file replacing fields as one goes.
	do num_field = 1, nfields {

	    # Find the width of the field.
	    width = field_pos[num_field + 1] - field_pos[num_field]

	    # Find the field to be replaced.
	    cfptr = 0
	    do cf = 1, ncin {
		if (cinfields[cf] != num_field)
		    next
		cfptr = cf
		    break
	    }

	    # Replace the field.
	    if (cfptr != 0) {
		if (laxno[cfptr] == 0)
	            call li_format_fieldd (INDEFD, Memc[field], maxch,
		        Memc[formats[cfptr]], nsdig[cfptr], width,
			min_sigdigits)
		else
	            call li_format_fieldd (coords[laxno[cfptr]], Memc[field],
		        maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]],
		        width, min_sigdigits)
	    } else {
	        # Put "width" characters from inbuf into field
		call strcpy (inbuf[field_pos[num_field]], Memc[field], width)
	    }

	    # Fields must be delimited by at least one blank.
	    if (num_field > 1 && !IS_WHITE (Memc[field])) {
		outbuf[op] = ' '
		op = op + 1
	    }

	    # Copy "field" to output buffer.
	    op = op + gstrcpy (Memc[field], outbuf[op], maxch)
	}

	do cfptr = ncin + 1, ncout {

	    # Copy out the extra fields if any.
	    if (laxno[cfptr] == 0)
	        call li_format_fieldd (INDEFD, Memc[field], maxch, "%g",
		    min_sigdigits, width, min_sigdigits)
	    else
	        call li_format_fieldd (coords[laxno[cfptr]], Memc[field],
		    maxch, Memc[formats[laxno[cfptr]]], nsdig[laxno[cfptr]],
		    width, min_sigdigits)

	    # Fields must be delimited by at least one blank.
	    if (!IS_WHITE (Memc[field])) {
		outbuf[op] = ' '
		op = op + 1
	    }

	    # Copy "field" to output buffer.
	    op = op + gstrcpy (Memc[field], outbuf[op], maxch)
	}

	outbuf[op] = '\n'
	outbuf[op+1] = EOS

	call sfree (sp)
end



mscred-5.05-2018.07.09/src/rmfringe.cl000066400000000000000000000020521332166314300167050ustar00rootroot00000000000000# RMFRINGE -- Remove fringe patterns from images.
# The images may be single images or multiextension mosaics.
# This task is a specialized interface to the PATFIT task.

procedure rmfringe (input, output, fringe, masks)

string	input		{prompt="List of input images"}
string	output		{prompt="List of output corrected images"}
string	fringe		{prompt="Fringe or list of fringe patterns"}
string	masks = ""	{prompt="List of object/bad data masks"}
string	fringemasks = "" {prompt="Fringe masks"}
string	background = ""	{prompt="Lisk of input image backgrounds"}

int	ncblk = 5	{prompt="Column smoothing"}
int	nlblk = 5	{prompt="Line smoothing"}
string	extfit = ""	{prompt="Extensions to use in scaling fit"}

file	logfile = ""	{prompt="Logfile"}
bool	verbose = yes	{prompt="Verbose?"}

begin
	patfit (input, output, fringe, weight="", masks=masks,
	    patmasks=fringemasks, background=background, bkgpattern="",
	    bkgweight="", ncblk=ncblk, nlblk=nlblk, extfit=extfit, extout="",
	    outtype="pdiff", logname="RMFRINGE", logfile=logfile,
	    verbose=verbose)
end
mscred-5.05-2018.07.09/src/rmpupil.cl000066400000000000000000000020441332166314300165650ustar00rootroot00000000000000# RMPUPIL -- Remove pupil patterns from images.
# The images may be single images or multiextension mosaics.
# This task is a specialized interface to the PATFIT task.

procedure rmpupil (input, output, pupil, masks)

string	input		{prompt="List of input images"}
string	output		{prompt="List of output corrected images"}
string	pupil = ""	{prompt="Pupil or list of pupil patterns"}
string	masks = ""	{prompt="List of object/bad data masks"}
string	pupilmasks = ""	{prompt="Pupil masks"}
string	outtype = "sdiff" {prompt="Output type", enum="sdiff|sflat"}

int	ncblk = 5	{prompt="Column smoothing"}
int	nlblk = 5	{prompt="Line smoothing"}
string	extfit = "im[2367]"	{prompt="Extensions to use in scaling fit"}

file	logfile = ""	{prompt="Logfile"}
bool	verbose = yes	{prompt="Verbose?"}

begin
	patfit (input, output, pupil, weight="", masks=masks,
	    patmasks=pupilmasks, background="", bkgpattern="",
	    bkgweight="", ncblk=ncblk, nlblk=nlblk, extfit=extfit,
	    extout="", outtype=outtype, logname="RMPUPIL", logfile=logfile,
	    verbose=verbose)
end
mscred-5.05-2018.07.09/src/setinstrument.cl000066400000000000000000000051331332166314300200230ustar00rootroot00000000000000# SETINSTRUMENT -- Set up instrument parameters for the CCD reduction tasks.
#
# This task sets default parameters based on an instrument ID.

procedure setinstrument (site, telescope, instrument)

char	site			{prompt="Site (? for menu)"}
char	telescope		{prompt="Telescope (? for menu)"}
char	instrument		{prompt="Instrument (? for a list)"}

char	directory="mscdb$noao/"	{prompt="Instrument directory"}
bool	review=yes		{prompt="Review instrument parameters?"}
char	query_site		{prompt="Site (? for menu or q to quit)",
				 mode="q"}
char	query_tel		{prompt="Telescope (? for menu or q to quit)",
				 mode="q"}
char	query_inst		{prompt="Instrument (? for menu or q to quit)",
				 mode="q"}

begin
	string	obs, tel, inst, instdir, men, dir, instfile

	# Define instrument directory.
	instdir = directory
	dir = directory

	# Define site.
	men = instdir // "sites.men"
	obs = site
	dir = instdir // obs
	while (obs != "" && !access (dir)) {
	    if (access (men)) {
		print ("\nSites:\n")
		type (men)
	    } else if (obs == "?")
		print ("Site menu ", men, " not found")
	    else
	        print ("Site ", tel, " not found")
	    print ("")
	    obs = query_site
	    if (obs == "q")
		return
	    site = obs
	    dir = instdir // obs
	}
	if (obs != "")
	    instdir = instdir // obs // "/"

	# Define telescope.
	men = instdir // "telescopes.men"
	tel = telescope
	dir = instdir // tel
	while (tel != "" && !access (dir)) {
	    if (access (men)) {
		print ("\nTelescopes:\n")
		type (men)
	    } else if (tel == "?")
		print ("Telescope menu ", men, " not found")
	    else
	        print ("Telescope ", tel, " not found")
	    print ("")
	    tel = query_tel
	    if (tel == "q")
		return
	    telescope = tel
	    dir = instdir // tel
	}
	if (tel != "")
	    instdir = instdir // tel // "/"

	# Define instrument.
	men = instdir // "instruments.men"
	inst = instrument
	instfile = instdir // inst // ".dat"
	while (inst != "" && !access (instfile)) {
	    if (access (men)) {
		print ("\nInstruments:\n")
		type (men)
	    } else if (inst == "?")
		print ("Instrument menu ", men, " not found")
	    else
	        print ("Instrument file ", instfile, " not found")
	    print ("")
	    inst = query_inst
	    if (inst == "q")
		return
	    instrument = inst
	    instfile = instdir // inst // ".dat"
	}

	# Set instrument parameter.
	if (access (instfile))
	    mscred.instrument = instfile
	else
	    mscred.instrument = ""

	# Run instrument setup script.
	instfile = instdir // inst // ".cl"
	if (access (instfile))
	    cl (< instfile)

	# Review parameters if desired.
	if (review) {
	    eparam ("mscred")
	    eparam ("ccdproc")
	}
end
mscred-5.05-2018.07.09/src/sflatcombine.cl000066400000000000000000000066301332166314300175500ustar00rootroot00000000000000# SFLATCOMBINE -- Process and combine images into a sky flat.

procedure sflatcombine (input)

string	input			{prompt="List of images to combine"}
file	output="Sflat"		{prompt="Output sky flat field root name"}
string	combine="average"	{prompt="Type of combine operation",
				 enum="average|median"}
string	reject="avsigclip"	{prompt="Type of rejection"}
string	ccdtype="object"	{prompt="CCD image type to combine"}
bool	subsets=yes	{prompt="Combine images by subset parameter?"}
string	masktype = "none"	{prompt="Mask type"}
real	maskvalue = 0.		{prompt="Mask value"}
string	scale="mode"	{prompt="Image scaling",
			 enum="none|mode|median|mean|exposure"}
string	statsec=""	{prompt="Image section for computing statistics"}
int	nkeep=1		{prompt="Minimum to keep (pos) or maximum to reject (neg)"}
int	nlow=1		{prompt="minmax: Number of low pixels to reject"}
int	nhigh=1		{prompt="minmax: Number of high pixels to reject"}
bool	mclip=yes	{prompt="Use median in sigma clipping algorithms?"}
real	lsigma=6.	{prompt="Lower sigma clipping factor"}
real	hsigma=3.	{prompt="Upper sigma clipping factor"}
string	rdnoise="rdnoise" {prompt="ccdclip: CCD readout noise (electrons)"}
string	gain="gain"	{prompt="ccdclip: CCD gain (electrons/DN)"}
string	snoise="0."	{prompt="ccdclip: Sensitivity noise (fraction)"}
real	pclip=-0.5	{prompt="pclip: Percentile clipping parameter"}
real	blank=1.	{prompt="Value if there are no pixels"}
real	grow=3.		{prompt="Radius (pixels) for neighbor rejection",
			 min=0.}

struct	*fd

begin
	string	ims, out, temp1, temp2
	real	ccdmean, sigma, lower, upper

	cache	mscextensions

	ims = input
	out = output
	temp1 = mktemp ("tmp$iraf")
	temp2 = mktemp ("tmp$iraf")

	# Check on images to combine.
	coutput (ims, out, temp1, headers="", bpmasks="", rejmasks="",
	    nrejmasks="", expmasks="", sigma="",
	    ccdtype=ccdtype, amps=yes, subsets=subsets, scale=scale,
	    zero="none", weight=no)

	# Combine the images.
	combine (ims, output=out, headers="", bpmasks="", rejmasks="",
	    nrejmasks="", expmasks="", sigma="", imcmb="$I",
	    combine=combine, reject=reject, ccdtype=ccdtype, amps=yes,
	    subsets=subsets, delete=no, project=no, outtype="real",
	    outlimits="", offsets="none", masktype=masktype,
	    maskvalue=maskvalue, blank=blank, scale=scale, zero="none",
	    weight=no, statsec=statsec, lthreshold=INDEF, hthreshold=INDEF,
	    nlow=nlow, nhigh=nhigh, nkeep=nkeep, mclip=mclip,
	    lsigma=lsigma, hsigma=hsigma, rdnoise=rdnoise, gain=gain,
	    snoise=snoise, sigscale=0.1, pclip=pclip, grow=grow)

	# Set the image type and ccdmean.
	fd = temp1
	while (fscan (fd, out) != EOF) {
	    mscextensions (out, output="file", index="0-", extname="",
		extver="", lindex=yes, lname=no, lver=no, ikparams="", > temp2)
	    if (mscextensions.imext)
		_ccdhedit (out//"[0]", "imagetyp", "skyflat", type="string")
	    _ccdhedit ("@"//temp2, "imagetyp", "skyflat", type="string")
	    if (mscextensions.nimages > 1) {
		hedit (out//"[0],@"//temp2, "ccdmean*", add-, del+, update+,
		    verify-, show-)
		imstat ("@"//temp2, fields="mean", lower=INDEF, upper=INDEF,
		    format=no) | average | scan (ccdmean,sigma)
		lower = ccdmean - sigma
		upper = ccdmean + sigma
		imstat ("@"//temp2, fields="mean", lower=lower, upper=upper,
		    format=no) | average | scan (ccdmean)
		hedit (out//"[0]", "ccdmean", ccdmean, add+, del-, update+,
		    verify-, show-)
	    }
	    delete (temp2, verify-)
	}
	fd = ""; delete (temp1, verify-)
end
mscred-5.05-2018.07.09/src/skywcs.h000066400000000000000000000054451332166314300162610ustar00rootroot00000000000000# Public definitions file for the SKYCTRAN task

define	S_VXOFF		1
define	S_VYOFF		2
define	S_VXSTEP	3
define	S_VYSTEP	4
define	S_EQUINOX	5
define	S_EPOCH		6
define	S_CTYPE		7
define	S_RADECSYS	8
define	S_WTYPE		9
define	S_PLNGAX	10
define	S_PLATAX	11
define	S_XLAX		12
define	S_YLAX		13
define	S_PTYPE		14
define	S_NLNGAX	15
define	S_NLATAX	16
define	S_NLNGUNITS	17
define	S_NLATUNITS	18
define	S_COOSYSTEM	19
define	S_STATUS	20

# Define the list of supported fundamental coordinate systems.

define	FTYPE_LIST	"|fk4|noefk4|fk5|apparent|ecliptic|galactic|\
supergalactic|"

define	FTYPE_FK4		1
define	FTYPE_FK4NOE		2
define	FTYPE_FK5		3
define	FTYPE_GAPPT		4
define	FTYPE_ECLIPTIC		5
define	FTYPE_GALACTIC		6
define	FTYPE_SUPERGALACTIC	7

# Define the list of supported coordinate systems.

#define	CTYPE_LIST	"|equatorial|ecliptic|galactic|supergalactic|"

define	CTYPE_EQUATORIAL	1
define	CTYPE_ECLIPTIC		2
define	CTYPE_GALACTIC		3
define	CTYPE_SUPERGALACTIC	4

# Define the supported equatoral reference systems.

define  EQTYPE_LIST     "|fk4|fk4-no-e|fk5|gappt|"

define	EQTYPE_FK4	1
define	EQTYPE_FK4NOE	2
define	EQTYPE_FK5	3
define	EQTYPE_GAPPT	4

# Define the input coordinate file longitude latitude units.

define	SKY_LNG_UNITLIST	"|degrees|radians|hours|"
define	SKY_LAT_UNITLIST	"|degrees|radians|"

define	SKY_DEGREES	1
define	SKY_RADIANS	2
define	SKY_HOURS	3

# Define the list of supported image sky projection types.

define  WTYPE_LIST      "|lin|azp|tan|sin|stg|arc|zpn|zea|air|cyp|car|\
mer|cea|cop|cod|coe|coo|bon|pco|gls|par|ait|mol|csc|qsc|tsc|tnx|zpx|"

define  WTYPE_LIN       1
define  WTYPE_AZP       2
define  WTYPE_TAN       3
define  WTYPE_SIN       4
define  WTYPE_STG       5
define  WTYPE_ARC       6
define  WTYPE_ZPN       7
define  WTYPE_ZEA       8
define  WTYPE_AIR       9
define  WTYPE_CYP       10
define  WTYPE_CAR       11
define  WTYPE_MER       12
define  WTYPE_CEA       13
define  WTYPE_COP       14
define  WTYPE_COD       15
define  WTYPE_COE       16
define  WTYPE_COO       17
define  WTYPE_BON       18
define  WTYPE_PCO       19
define  WTYPE_GLS       20
define  WTYPE_PAR       21
define  WTYPE_AIT       22
define  WTYPE_MOL       23
define  WTYPE_CSC       24
define  WTYPE_QSC       25
define  WTYPE_TSC       26
define  WTYPE_TNX       27
define  WTYPE_ZPX       28

# Define the supported image axis types.

define  AXTYPE_LIST     "|ra|dec|glon|glat|elon|elat|slon|slat|"

define  AXTYPE_RA       1
define  AXTYPE_DEC      2
define  AXTYPE_GLON     3
define  AXTYPE_GLAT     4
define  AXTYPE_ELON     5
define  AXTYPE_ELAT     6
define  AXTYPE_SLON     7
define  AXTYPE_SLAT     8

# Define the supported image pixel coordinate systems.

define	PIXTYPE_LIST	"|logical|tv|physical|world|"

define  PIXTYPE_LOGICAL		1
define  PIXTYPE_TV		2
define  PIXTYPE_PHYSICAL	3
define  PIXTYPE_WORLD		4

mscred-5.05-2018.07.09/src/skywcs.x000066400000000000000000001754121332166314300163030ustar00rootroot00000000000000include 
include 
include 
include 
include "skywcs.h"
include "skywcsdef.h"

define SZ_DMYTOKEN	2

# SK_DECWCS -- Decode the wcs string which may be either an image name
# plus wcs, e.g. "dev$pix logical" or a string describing the celestial
# coordinate system, e.g. "J2000" or "galactic" into a celestial coordinate
# strucuture. If the input wcs is an image wcs then a non-NULL pointer to
# the image wcs structure is also returned. ERR is returned if a valid
# celestial coordinate structure cannot be created.

int procedure sk_decwcs (instr, mw, coo, imcoo)

char	instr[ARB]		#I the input wcs string
pointer	mw			#O the pointer to the image wcs structure
pointer	coo			#O the pointer to the coordinate structure
pointer	imcoo			#I pointer to an existing coordinate structure 

int	stat
pointer	sp, str1, str2, laxno, paxval, im
int	sk_strwcs(), sk_decim()
pointer	immap()
errchk	immap()

begin
	call calloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT)
	call strcpy (instr, SKY_COOSYSTEM(coo), SZ_FNAME)

	# Allocate some working space.
	call smark (sp)
	call salloc (str1, SZ_LINE, TY_CHAR)
	call salloc (str2, SZ_LINE, TY_CHAR)
	call salloc (laxno, IM_MAXDIM, TY_INT)
	call salloc (paxval, IM_MAXDIM, TY_INT)

	# Decode the wcs.
	call sscan (instr)
	    call gargwrd (Memc[str1], SZ_LINE)
	    call gargwrd (Memc[str2], SZ_LINE)

	# First try to open an image wcs.
	iferr {
	    im = immap (Memc[str1], READ_ONLY, 0)

	# Decode the user wcs.
	} then {

	    mw = NULL
	    if (imcoo == NULL) {
	        SKY_NLNGAX(coo) = 2048
	        SKY_NLATAX(coo) = 2048
	        SKY_PLNGAX(coo) = 1
	        SKY_PLATAX(coo) = 2
	        SKY_XLAX(coo) = 1
	        SKY_YLAX(coo) = 2
	        SKY_VXOFF(coo) = 0.0d0
	        SKY_VYOFF(coo) = 0.0d0
	        SKY_VXSTEP(coo) = 1.0d0
	        SKY_VYSTEP(coo) = 1.0d0
	        SKY_WTYPE(coo) = 0
	    } else {
	        SKY_NLNGAX(coo) = SKY_NLNGAX(imcoo)
	        SKY_NLATAX(coo) = SKY_NLATAX(imcoo)
	        SKY_PLNGAX(coo) = SKY_PLNGAX(imcoo)
	        SKY_PLATAX(coo) = SKY_PLATAX(imcoo)
	        SKY_XLAX(coo) = SKY_XLAX(imcoo)
	        SKY_YLAX(coo) = SKY_YLAX(imcoo)
	        SKY_VXOFF(coo) = SKY_VXOFF(imcoo)
	        SKY_VYOFF(coo) = SKY_VYOFF(imcoo)
	        SKY_VXSTEP(coo) = SKY_VXSTEP(imcoo)
	        SKY_VYSTEP(coo) = SKY_VYSTEP(imcoo)
	        SKY_WTYPE(coo) = SKY_WTYPE(imcoo)
	    }
	    SKY_PTYPE(coo) = PIXTYPE_WORLD
	    stat = sk_strwcs (instr, SKY_CTYPE(coo), SKY_RADECSYS(coo),
	        SKY_EQUINOX(coo), SKY_EPOCH(coo))
	    switch (SKY_CTYPE(coo)) {
	    case CTYPE_EQUATORIAL:
		SKY_NLNGUNITS(coo) = SKY_HOURS
		SKY_NLATUNITS(coo) = SKY_DEGREES
	    default:
		SKY_NLNGUNITS(coo) = SKY_DEGREES
		SKY_NLATUNITS(coo) = SKY_DEGREES
	    }

	# Decode the image wcs.
	} else {
	    stat = sk_decim (im, Memc[str2], mw, coo)
	    call imunmap (im)
	}

	call sfree (sp)

	SKY_STATUS(coo) = stat
	return (stat)
end


# SK_DECIM -- Given an image descriptor and an image wcs string create a
# celstial coordinate structure. ERR is returned if the image wcs cannot be
# decoded or a a valid celestial coordinate descriptor cannot be created.

int procedure sk_decim (im, wcs, mw, coo)

pointer	im			#I the pointer to the input image
char	wcs[ARB]		#I the wcs string [logical|tv|physical|world]
pointer	mw			#O the pointer to the image wcs structure
pointer	coo			#O the pointer to the coordinate structure

int	stat
pointer	sp, str1, laxno, paxval
int	sk_imwcs(), strdic(), mw_stati()
pointer	mw_openim()
errchk	mw_openim()

begin
	call malloc (coo, LEN_SKYCOOSTRUCT, TY_STRUCT)
	call sprintf (SKY_COOSYSTEM(coo), SZ_FNAME, "%s %s")
	    call pargstr (IM_HDRFILE(im))
	    call pargstr (wcs)

	call smark (sp)
	call salloc (str1, SZ_LINE, TY_CHAR)
	call salloc (laxno, IM_MAXDIM, TY_INT)
	call salloc (paxval, IM_MAXDIM, TY_INT)

	# Try to open the image wcs.
	iferr {
	    mw = mw_openim (im)

	# Set up a dummy wcs.
	} then {
	    SKY_CTYPE(coo) = 0
	    SKY_RADECSYS(coo) = 0
	    SKY_EQUINOX(coo) = INDEFD
	    SKY_EPOCH(coo) = INDEFD
	    mw = NULL
	    SKY_PLNGAX(coo) = 1
	    SKY_PLATAX(coo) = 2
	    SKY_XLAX(coo) = 1
	    SKY_YLAX(coo) = 2
	    SKY_NLNGAX(coo) = 2048
	    SKY_NLATAX(coo) = 2048
	    SKY_VXOFF(coo) = 0.0d0
	    SKY_VYOFF(coo) = 0.0d0
	    SKY_VXSTEP(coo) = 1.0d0
	    SKY_VYSTEP(coo) = 1.0d0
	    SKY_WTYPE(coo) = 0
	    SKY_PTYPE(coo) = PIXTYPE_LOGICAL
	    SKY_NLNGUNITS(coo) = SKY_DEGREES
	    SKY_NLATUNITS(coo) = SKY_DEGREES
	    stat = ERR

	# Decode the wcs.
	} else {
	    SKY_PTYPE(coo) = strdic (wcs, Memc[str1], SZ_LINE, PIXTYPE_LIST)
	    if (SKY_PTYPE(coo) <= 0)
	        SKY_PTYPE(coo) = PIXTYPE_LOGICAL
	    if (sk_imwcs (im, mw, SKY_CTYPE(coo), SKY_PLNGAX(coo),
		    SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_RADECSYS(coo),
		    SKY_EQUINOX(coo), SKY_EPOCH(coo)) == OK) {
	    	switch (SKY_CTYPE(coo)) {
	    	case CTYPE_EQUATORIAL:
	    	    SKY_NLNGUNITS(coo) = SKY_HOURS
	    	    SKY_NLATUNITS(coo) = SKY_DEGREES
	    	default:
	    	    SKY_NLNGUNITS(coo) = SKY_DEGREES
	    	    SKY_NLATUNITS(coo) = SKY_DEGREES
	    	}
		call mw_gaxmap (mw, Memi[laxno], Memi[paxval], mw_stati(mw,
		    MW_NPHYSDIM))
		if (Memi[laxno+SKY_PLNGAX(coo)-1] <
		    Memi[laxno+SKY_PLATAX(coo)-1]) {
		    SKY_XLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] 
		    SKY_YLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] 
		} else {
		    SKY_XLAX(coo) = Memi[laxno+SKY_PLATAX(coo)-1] 
		    SKY_YLAX(coo) = Memi[laxno+SKY_PLNGAX(coo)-1] 
		}
		if (SKY_XLAX(coo) <= 0 || SKY_YLAX(coo) <= 0) {
		    SKY_VXOFF(coo) = 0.0d0
		    SKY_VYOFF(coo) = 0.0d0
		    SKY_VXSTEP(coo) = 1.0d0
		    SKY_VYSTEP(coo) = 1.0d0
	            SKY_NLNGAX(coo) = 2048
	            SKY_NLATAX(coo) = 2048
		    stat = ERR
		} else {
		    SKY_VXOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_XLAX(coo)))
		    SKY_VYOFF(coo) = IM_VOFF(im,IM_VMAP(im,SKY_YLAX(coo)))
		    SKY_VXSTEP(coo) = IM_VSTEP(im,SKY_XLAX(coo))
		    SKY_VYSTEP(coo) = IM_VSTEP(im,SKY_YLAX(coo))
	            SKY_NLNGAX(coo) = IM_LEN(im,SKY_XLAX(coo))
	            SKY_NLATAX(coo) = IM_LEN(im,SKY_YLAX(coo))
		    stat = OK
		}
	    } else {
		call mw_close (mw)
		mw = NULL
	        SKY_XLAX(coo) = 1
	        SKY_YLAX(coo) = 2
	        SKY_NLNGAX(coo) = 2048
	        SKY_NLATAX(coo) = 2048
	        SKY_VXOFF(coo) = 0.0d0
	        SKY_VYOFF(coo) = 0.0d0
	        SKY_VXSTEP(coo) = 1.0d0
	        SKY_VYSTEP(coo) = 1.0d0
	    	SKY_NLNGUNITS(coo) = SKY_DEGREES
	    	SKY_NLATUNITS(coo) = SKY_DEGREES
		stat = ERR
	    }
	}

	call sfree (sp)

	SKY_STATUS(coo) = stat
	return (stat)
end


# SK_STRWCS -- Decode the sky coordinate system from an input string.
# The string syntax is [ctype] equinox [epoch].

int procedure sk_strwcs (instr, ctype, radecsys, equinox, epoch)

char	instr[ARB]		#I the input wcs string
int	ctype			#O the output coordinate type
int	radecsys		#O the output equatorial reference system
double	equinox			#O the output equinox
double	epoch			#O the output epoch of the observation

int	ip, nitems, sctype, sradecsys, stat
pointer	sp, str1, str2
int	strdic(), nscan(), ctod()
double	sl_ej2d(), sl_epb(), sl_eb2d(), sl_epj()

begin
	# Initialize.
	ctype = 0
	radecsys = 0
	equinox = INDEFD
	epoch = INDEFD

	# Allocate working space.
	call smark (sp)
	call salloc (str1, SZ_LINE, TY_CHAR)
	call salloc (str2, SZ_LINE, TY_CHAR)

	# Determine the coordinate string.
	call sscan (instr)
	    call gargwrd (Memc[str1], SZ_LINE)

	# Return with an error if the string is blank.
	if (Memc[str1] == EOS || nscan() < 1) {
	    call sfree (sp)
	    return (ERR)
	} else
	    nitems = 1
	    
	# If the coordinate type is undefined temporarily default it to
	# equatorial.
	sctype = strdic (Memc[str1], Memc[str2], SZ_LINE, FTYPE_LIST) 
	if (sctype <= 0) {
	    ctype = CTYPE_EQUATORIAL
	} else {
	    switch (sctype) {
	    case FTYPE_FK4:
	        ctype = CTYPE_EQUATORIAL
		radecsys = EQTYPE_FK4
	    case FTYPE_FK4NOE:
	        ctype = CTYPE_EQUATORIAL
		radecsys = EQTYPE_FK4NOE
	    case FTYPE_FK5:
	        ctype = CTYPE_EQUATORIAL
		radecsys = EQTYPE_FK5
	    case FTYPE_GAPPT:
	        ctype = CTYPE_EQUATORIAL
		radecsys = EQTYPE_GAPPT
	    case FTYPE_ECLIPTIC:
	        ctype = CTYPE_ECLIPTIC
	    case FTYPE_GALACTIC:
	        ctype = CTYPE_GALACTIC
	    case FTYPE_SUPERGALACTIC:
	        ctype = CTYPE_SUPERGALACTIC
	    }
	    call gargwrd (Memc[str1], SZ_LINE)
	    if (nscan() > nitems)
		nitems = nitems + 1
	}
	sctype = ctype
	sradecsys = radecsys

	# Decode the ra/dec system and equinox
	switch (sctype) {

	case CTYPE_EQUATORIAL:

	    switch (sradecsys) {
	    case EQTYPE_FK4, EQTYPE_FK4NOE:
		if (Memc[str1] == 'J' || Memc[str1] == 'j' ||
		    Memc[str1] == 'B' || Memc[str1] == 'b')
		    ip = 2
		else 
		    ip = 1
	        if (ctod (Memc[str1], ip, equinox) <= 0)
		    equinox = 1950.0d0
		if (Memc[str1] == 'J' || Memc[str1] == 'j')
		    equinox = sl_epb (sl_ej2d (equinox))

	        call gargwrd (Memc[str2], SZ_LINE)
	        if (nscan() <= nitems)
		    #epoch = equinox
		    epoch = sl_eb2d (equinox)
		else {
		    if (Memc[str2] == 'J' || Memc[str2] == 'j' ||
		        Memc[str2] == 'B' || Memc[str2] == 'b')
		        ip = 2
		    else
		        ip = 1
		    if (ctod (Memc[str2], ip, epoch) <= 0)
		        #epoch = equinox
		        epoch = sl_eb2d (equinox)
		    else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' ||
		        Memc[str2] == 'j'))
		        #epoch = sl_epb (sl_ej2d (epoch))
		        epoch = sl_ej2d (epoch)
		    else if (epoch > 3000.0d0)
		        #epoch = sl_epb (epoch - 2400000.5d0)
		        epoch = epoch - 2400000.5d0
		    else
			epoch = sl_eb2d (epoch)
		}

	    case EQTYPE_FK5:
		if (Memc[str1] == 'J' || Memc[str1] == 'j' ||
		    Memc[str1] == 'B' || Memc[str1] == 'b')
		    ip = 2
		else 
		    ip = 1
	        if (ctod (Memc[str1], ip, equinox) <= 0)
		    equinox = 2000.0d0
		if (Memc[str1] == 'B' || Memc[str1] == 'b')
		    equinox = sl_epj(sl_eb2d (equinox))

	        call gargwrd (Memc[str2], SZ_LINE)
	        if (nscan() <= nitems)
		    #epoch = equinox
		    epoch = sl_ej2d (equinox)
		else {
		    if (Memc[str2] == 'J' || Memc[str2] == 'j' ||
		        Memc[str2] == 'B' || Memc[str2] == 'b')
		        ip = 2
		    else
		        ip = 1
		    if (ctod (Memc[str2], ip, epoch) <= 0)
		        #epoch = equinox
		        epoch = sl_ej2d (equinox)
		    else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' ||
		        Memc[str2] == 'b'))
		        #epoch = sl_epj (sl_eb2d (epoch))
		        epoch = sl_eb2d (epoch)
		    else if (epoch > 3000.0d0)
		        #epoch = sl_epj (epoch - 2400000.5d0)
		        epoch = epoch - 2400000.5d0
		    else
			epoch = sl_ej2d (epoch)
		}

	    case EQTYPE_GAPPT:
		equinox = 2000.0d0
		if (Memc[str1] == 'J' || Memc[str1] == 'j' ||
		    Memc[str1] == 'B' || Memc[str1] == 'b')
		    ip = 2
		else
		    ip = 1
	        if (ctod (Memc[str1], ip, epoch) <= 0) {
		    epoch = INDEFD
		} else if (epoch <= 3000.0d0) {
		    if (Memc[str1] == 'B' || Memc[str1] == 'b')
		        epoch = sl_eb2d (epoch)
		    else if (Memc[str1] == 'J' || Memc[str1] == 'j')
		        epoch = sl_ej2d (epoch)
		    else if (epoch < 1984.0d0)
		        epoch = sl_eb2d (epoch)
		    else
		        epoch = sl_ej2d (epoch)
		} else {
		    epoch = epoch - 2400000.5d0
		} 

	    default:
		ip = 1
		if (Memc[str1] == 'B' || Memc[str1] == 'b') {
		    radecsys = EQTYPE_FK4
		    ip = ip + 1
	            if (ctod (Memc[str1], ip, equinox) <= 0)
			equinox = 1950.0d0

	            call gargwrd (Memc[str2], SZ_LINE)
	            if (nscan() <= nitems)
			#epoch = equinox
		        epoch = sl_eb2d (equinox)
		    else {
		        if (Memc[str2] == 'J' || Memc[str2] == 'j')
		            ip = 2
		        else if (Memc[str2] == 'B' || Memc[str2] == 'b')
		            ip = 2
		        else
		            ip = 1
		        if (ctod (Memc[str2], ip, epoch) <= 0)
		            #epoch = equinox
		            epoch = sl_eb2d (equinox)
		        else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' ||
			    Memc[str2] == 'j'))
		            #epoch = sl_epb (sl_ej2d (epoch))
		            epoch = sl_ej2d (epoch)
		        else if (epoch > 3000.0d0)
		            #epoch = sl_epb (epoch - 2400000.5d0)
		            epoch = epoch - 2400000.5d0
			else
			    epoch = sl_eb2d (epoch)
		    }

		} else if (Memc[str1] == 'J' || Memc[str1] == 'j') {
		    radecsys = EQTYPE_FK5
		    ip = ip + 1
	            if (ctod (Memc[str1], ip, equinox) <= 0)
			equinox = 2000.0d0

	            call gargwrd (Memc[str2], SZ_LINE)
	            if (nscan() <= nitems)
		        #epoch = equinox
		        epoch = sl_ej2d (equinox)
		    else {
		        if (Memc[str2] == 'J' || Memc[str2] == 'j' ||
		            Memc[str2] == 'B' || Memc[str2] == 'b')
		            ip = 2
		        else
		            ip = 1
		        if (ctod (Memc[str2], ip, epoch) <= 0)
		            #epoch = equinox
		            epoch = sl_ej2d (equinox)
		        else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' ||
			    Memc[str2] == 'b'))
		            #epoch = sl_epj (sl_eb2d (epoch))
		            epoch = sl_eb2d (epoch)
		        else if (epoch > 3000.0d0)
		            #epoch = sl_epj (epoch - 2400000.5d0)
		            epoch = epoch - 2400000.5d0
			else
			    epoch = sl_ej2d (epoch)
		    }

		} else if (ctod (Memc[str1], ip, equinox) <= 0) {
		    ctype = 0
		    radecsys = 0
		    equinox = INDEFD
		    epoch = INDEFD

		} else if (equinox < 1984.0d0) {
		    radecsys = EQTYPE_FK4
	            call gargwrd (Memc[str2], SZ_LINE)
	            if (nscan() <= nitems)
		        #epoch = equinox
		        epoch = sl_eb2d (equinox)
		    else {
		        if (Memc[str2] == 'J' || Memc[str2] == 'j' ||
		            Memc[str2] == 'B' || Memc[str2] == 'b')
		            ip = 2
		        else
		            ip = 1
		        if (ctod (Memc[str2], ip, epoch) <= 0)
		            #epoch = equinox
		            epoch = sl_eb2d (equinox)
		        else if (epoch <= 3000.0d0 && (Memc[str2] == 'J' ||
			    Memc[str2] == 'j'))
		            #epoch = sl_epb (sl_ej2d (epoch))
		            epoch = sl_ej2d (epoch)
		        else if (epoch > 3000.0d0)
		            #epoch = sl_epb (epoch - 2400000.5d0)
		            epoch = epoch - 2400000.5d0
			else
			    epoch = sl_eb2d (epoch)
		    }

		} else {
		    radecsys = EQTYPE_FK5
	            call gargwrd (Memc[str2], SZ_LINE)
	            if (nscan() <= nitems)
		        #epoch = equinox
		        epoch = sl_ej2d (equinox)
		    else {
		        if (Memc[str2] == 'J' || Memc[str2] == 'j' ||
		            Memc[str2] == 'B' || Memc[str2] == 'b')
		            ip = 2
		        else
		            ip = 1
		        if (ctod (Memc[str2], ip, epoch) <= 0)
		            #epoch = equinox
		            epoch = sl_ej2d (equinox)
		        else if (epoch <= 3000.0d0 && (Memc[str2] == 'B' ||
			    Memc[str2] == 'b'))
		            #epoch = sl_epj (sl_eb2d (epoch))
		            epoch = sl_eb2d (epoch)
		        else if (epoch > 3000.0d0)
		            #epoch = sl_epj (epoch - 2400000.5d0)
		            epoch = epoch - 2400000.5d0
			else
			    epoch = sl_ej2d (epoch)
		    }
		}
	    }

	case CTYPE_ECLIPTIC:
	    if (Memc[str1] == 'J' || Memc[str1] == 'j' ||
	        Memc[str1] == 'B' || Memc[str1] == 'b')
		ip = 2
	    else
		ip = 1
	    if (ctod (Memc[str1], ip, epoch) <= 0) {
		epoch = INDEFD
	    } else if (epoch <= 3000.0d0) {
	        if (Memc[str1] == 'B' || Memc[str1] == 'b')
		    epoch = sl_eb2d (epoch)
	        else if (Memc[str1] == 'J' || Memc[str1] == 'j')
		    epoch = sl_ej2d (epoch)
		else if (epoch < 1984.0d0)
		    epoch = sl_eb2d (epoch)
		else
		    epoch = sl_ej2d (epoch)
	    } else {
		epoch = epoch - 2400000.5d0
	    }

	case CTYPE_GALACTIC, CTYPE_SUPERGALACTIC:
	    if (Memc[str1] == 'J' || Memc[str1] == 'j' ||
		Memc[str1] == 'B' || Memc[str1] == 'b')
		ip = 2
	    else
		ip = 1
	    if (ctod (Memc[str1], ip, epoch) <= 0) {
		epoch = sl_eb2d (1950.0d0)
	    } else if (epoch <= 3000.0d0) {
	        if (Memc[str1] == 'J' || Memc[str1] == 'j')
		    epoch = sl_ej2d (epoch)
	        else if (Memc[str1] == 'B' || Memc[str1] == 'b')
		    epoch = sl_eb2d (epoch)
	        else if (epoch < 1980.0d0) 
		    epoch = sl_eb2d (epoch)
		else
		    epoch = sl_ej2d (epoch)
	    } else {
		epoch = epoch - 2400000.5d0
	    }
	}

	# Return the appropriate error status.
	if (ctype == 0)
	    stat = ERR
	else if (ctype == CTYPE_EQUATORIAL && (radecsys == 0 ||
	    IS_INDEFD(equinox) || IS_INDEFD(epoch)))
	    stat = ERR
	else if (ctype == CTYPE_ECLIPTIC && IS_INDEFD(epoch))
	    stat = ERR
	else
	    stat = OK

	call sfree (sp)

	return (stat)
end


# SK_IMWCS -- Decode the sky coordinate system of the image. Return
# an error if the sky coordinate system is not one of the supported types
# or required information is missing from the image header.

int procedure sk_imwcs (im, mw, ctype, lngax, latax, wtype, radecsys,
	equinox, epoch)

pointer	im			#I the image pointer
pointer	mw			#I pointer to the world coordinate system
int	ctype			#O the output coordinate type
int	lngax			#O the output ra/glon/elon axis
int	latax			#O the output dec/glat/elat axis
int	wtype			#O the output projection type
int	radecsys		#O the output equatorial reference system
double	equinox			#O the output equinox
double	epoch			#O the output epoch of the observation

int	i, ndim, axtype, token, day, month, year, ier
pointer	sp, atval
double	imgetd(), sl_eb2d(), sl_ej2d()
int	mw_stati(), strdic()
errchk	mw_gwattrs(), imgstr(), imgetd()

begin
	call smark (sp)
	call salloc (atval, SZ_LINE, TY_CHAR)

	# Initialize
	ctype = 0
	lngax = 0
	latax = 0
	wtype = 0
	radecsys = 0
	equinox = INDEFD
	epoch = INDEFD

	# Determine the sky coordinate system of the image.
	ndim = mw_stati (mw, MW_NPHYSDIM)
	do i = 1, ndim {
	    iferr (call mw_gwattrs (mw, i, "axtype", Memc[atval], SZ_LINE))
		call strcpy ("INDEF", Memc[atval], SZ_LINE)
	    axtype = strdic (Memc[atval], Memc[atval], SZ_LINE, AXTYPE_LIST)
	    switch (axtype) {
	    case AXTYPE_RA, AXTYPE_DEC: 
		ctype = CTYPE_EQUATORIAL
	    case AXTYPE_ELON, AXTYPE_ELAT: 
		ctype = CTYPE_ECLIPTIC
	    case AXTYPE_GLON, AXTYPE_GLAT: 
		ctype = CTYPE_GALACTIC
	    case AXTYPE_SLON, AXTYPE_SLAT: 
		ctype = CTYPE_SUPERGALACTIC
	    default:
		;
	    }
	    switch (axtype) {
	    case AXTYPE_RA, AXTYPE_ELON, AXTYPE_GLON, AXTYPE_SLON:
		lngax = i
	    case AXTYPE_DEC, AXTYPE_ELAT, AXTYPE_GLAT, AXTYPE_SLAT:
		latax = i
	    default:
		;
	    }
	}

	# Return if the sky coordinate system cannot be decoded.
	if (ctype == 0 || lngax == 0 || latax == 0) {
	    call sfree (sp)
	    return (ERR)
	}

	# Decode the sky projection.
	iferr {
	    call mw_gwattrs (mw, lngax, "wtype", Memc[atval], SZ_LINE)
	} then {
	    iferr (call mw_gwattrs(mw, latax, "wtype", Memc[atval], SZ_LINE))
		call strcpy ("linear", Memc[atval], SZ_LINE)
	}
	wtype = strdic (Memc[atval], Memc[atval], SZ_LINE, WTYPE_LIST)

	# Return if the sky projection system is not supported.
	if (wtype == 0) {
	    call sfree (sp)
	    return (ERR)
	}

	# Determine the RA/DEC system and equinox.
	if (ctype == CTYPE_EQUATORIAL) {

	    # Get the equinox of the coordinate system. The EQUINOX keyword
	    # takes precedence over EPOCH.
	    iferr {
	        equinox = imgetd (im, "EQUINOX")
	    } then {
		iferr {
	            equinox = imgetd (im, "EPOCH")
		} then {
		    equinox = INDEFD
		}
	    }

	    # Determine which equatorial system will be used. The default
	    # is FK4 if equinox < 1984.0, FK5 if equinox is >= 1984.
	    iferr {
	        call imgstr (im, "RADECSYS", Memc[atval], SZ_LINE)
	    } then {
	        radecsys = 0
	    } else {
		call strlwr (Memc[atval])
	        radecsys = strdic (Memc[atval], Memc[atval], SZ_LINE,
		    EQTYPE_LIST)
	    }
	    if (radecsys == 0) {
		if (IS_INDEFD(equinox))
		    radecsys = EQTYPE_FK5
		else if (equinox < 1984.0d0)
		    radecsys = EQTYPE_FK4
		else
		    radecsys = EQTYPE_FK5
	    }

	    # Get the MJD of the observation. If there is no MJD in the
	    # header use the DATE_OBS keyword value and transform it to
	    # an MJD.
	    iferr {
	        epoch = imgetd (im, "MJD-WCS")
	    } then {
	        iferr {
	            epoch = imgetd (im, "MJD-OBS")
	        } then {
		    iferr {
	                call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE)
		    } then {
		        epoch = INDEFD
		    } else {
		        call sscan (Memc[atval])
			    call gargi (day)
			    call gargtok (token, Memc[atval], SZ_DMYTOKEN)
			    call gargi (month)
			    call gargtok (token, Memc[atval], SZ_DMYTOKEN)
			    call gargi (year)
		        call sl_cadj (year, month, day, epoch, ier)
		        if (ier != 0)
			    epoch = INDEFD
		    }
	        }
	    }

	    # Set the default equinox and epoch appropriate for each
	    # equatorial system if these are undefined.
	    switch (radecsys) {
	    case EQTYPE_FK4:
		if (IS_INDEFD(equinox))
		    equinox = 1950.0d0
		if (IS_INDEFD(epoch))
		    #epoch = 1950.0d0
		    epoch = sl_eb2d (1950.0d0)
		#else
		    #epoch = sl_epb (epoch)
	    case EQTYPE_FK4NOE:
		if (IS_INDEFD(equinox))
		    equinox = 1950.0d0
		if (IS_INDEFD(epoch))
		    #epoch = 1950.0d0
		    epoch = sl_eb2d (1950.0d0)
		#else
		    #epoch = sl_epb (epoch)
	    case EQTYPE_FK5:
		if (IS_INDEFD(equinox))
		    equinox = 2000.0d0
		if (IS_INDEFD(epoch))
		    #epoch = 2000.0d0
		    epoch = sl_ej2d (2000.0d0)
		#else
		    #epoch = sl_epj (epoch)
	    case EQTYPE_GAPPT:
		equinox = 2000.0d0
		;
	    }

	    # Return if the epoch is undefined. This can only occur if
	    # the equatorial coordinate system is GAPPT and there is NO
	    # epoch of observation in the image header.
	    if (IS_INDEFD(epoch)) {
		call sfree (sp)
		return (ERR)
	    }
	} 

	# Get the MJD of the observation. If there is no MJD in the
	# header use the DATE_OBS keyword value and transform it to
	# an MJD.
	if (ctype == CTYPE_ECLIPTIC) {

	    iferr {
	        epoch = imgetd (im, "MJD-WCS")
	    } then {
	        iferr {
	            epoch = imgetd (im, "MJD-OBS")
	        } then {
		    iferr {
	                call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE)
		    } then {
		        epoch = INDEFD
		    } else {
		        call sscan (Memc[atval])
			    call gargi (day)
			    call gargtok (token, Memc[atval], SZ_DMYTOKEN)
			    call gargi (month)
			    call gargtok (token, Memc[atval], SZ_DMYTOKEN)
			    call gargi (year)
		        call sl_cadj (year, month, day, epoch, ier)
		        if (ier != 0)
			    epoch = INDEFD
		    }
	        }
	    }

	    # Return if the epoch is undefined.
	    if (IS_INDEFD(epoch)) {
		call sfree (sp)
		return (ERR)
	    }
	}

	if (ctype == CTYPE_GALACTIC || ctype == CTYPE_SUPERGALACTIC) {

	    # Get the MJD of the observation. If there is no MJD in the
	    # header use the DATE_OBS keyword value and transform it to
	    # an MJD.
	    iferr {
	        epoch = imgetd (im, "MJD-WCS")
	    } then {
	        iferr {
	            epoch = imgetd (im, "MJD-OBS")
	        } then {
		    iferr {
	                call imgstr (im, "DATE-OBS", Memc[atval], SZ_LINE)
		    } then {
		        epoch = sl_eb2d (1950.0d0)
		    } else {
		        call sscan (Memc[atval])
			    call gargi (day)
			    call gargtok (token, Memc[atval], SZ_DMYTOKEN)
			    call gargi (month)
			    call gargtok (token, Memc[atval], SZ_DMYTOKEN)
			    call gargi (year)
		        call sl_cadj (year, month, day, epoch, ier)
		        if (ier != 0)
			    epoch = sl_eb2d (1950.0d0)
			else if (epoch < 1984.0d0)
		    	    epoch = sl_eb2d (epoch)
			else
		    	    epoch = sl_ej2d (epoch)
		    }
	        }
	    }
	}

	call sfree (sp)

	return (OK)
end


# SK_CLOSE -- Free the coordinate structure.

procedure sk_close (coo)

pointer	coo			#I the input coordinate structure

begin
	if (coo != NULL)
	    call mfree (coo, TY_STRUCT)
end


# SK_CSCOPY -- Copy the coodinate structure.

pointer procedure sk_cscopy (cooin)

pointer	cooin			#I the pointer to the input structure

pointer	cooout

begin
	if (cooin == NULL)
	    cooout = NULL
	else {
	    call calloc (cooout, LEN_SKYCOOSTRUCT, TY_STRUCT)
            SKY_VXOFF(cooout) = SKY_VXOFF(cooin)
            SKY_VYOFF(cooout) = SKY_VYOFF(cooin)
            SKY_VXSTEP(cooout) = SKY_VXSTEP(cooin)
            SKY_VYSTEP(cooout) = SKY_VYSTEP(cooin)
	    SKY_EQUINOX(cooout) = SKY_EQUINOX(cooin)
	    SKY_EPOCH(cooout) = SKY_EPOCH(cooin)
	    SKY_CTYPE(cooout) = SKY_CTYPE(cooin)
	    SKY_RADECSYS(cooout) = SKY_RADECSYS(cooin)
            SKY_WTYPE(cooout) = SKY_WTYPE(cooin)
            SKY_PLNGAX(cooout) = SKY_PLNGAX(cooin)
            SKY_PLATAX(cooout) = SKY_PLATAX(cooin)
            SKY_XLAX(cooout) = SKY_XLAX(cooin)
            SKY_YLAX(cooout) = SKY_YLAX(cooin)
            SKY_PTYPE(cooout) = SKY_PTYPE(cooin)
    	    SKY_NLNGAX(cooout) = SKY_NLNGAX(cooin)
            SKY_NLATAX(cooout) = SKY_NLATAX(cooin)
    	    SKY_NLNGUNITS(cooout) = SKY_NLNGUNITS(cooin)
            SKY_NLATUNITS(cooout) = SKY_NLATUNITS(cooin)
	    call strcpy (SKY_COOSYSTEM(cooin), SKY_COOSYSTEM(cooout),
		SZ_FNAME)
	}

	return (cooout)
end

# SKY_HDRSAVEIM -- Update the image header keywords that describe the
# fundamental coordinate system, CTYPE, RADECSYS, EQUINOX (EPOCH), and
# MJD-WCS.

procedure sk_hdrsaveim (coo, mw, im)

pointer	coo			#I pointer to the coordinate structure
pointer	mw			#I pointer to the mwcs structure
pointer	im			#I image descriptor

errchk	imdelf()

begin
	# Move all this to a separate routine
	switch (SKY_CTYPE(coo)) {

	case CTYPE_EQUATORIAL:
	    call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "ra")
	    call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "dec")
	    switch (SKY_RADECSYS(coo)) {
	    case EQTYPE_FK4:
		call imastr (im, "radecsys", "FK4")
		call imaddd (im, "equinox", SKY_EQUINOX(coo))
		#iferr (call imdelf (im, "epoch"))
		    #;
		#call imaddd (im, "mjd-wcs", sl_eb2d (SKY_EPOCH(coo)))
		call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))
	    case EQTYPE_FK4NOE:
		call imastr (im, "radecsys", "FK4NOE")
		call imaddd (im, "equinox", SKY_EQUINOX(coo))
		#iferr (call imdelf (im, "epoch"))
		    #;
		#call imaddd (im, "mjd-wcs", sl_eb2d (SKY_EPOCH(coo)))
		call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))
	    case EQTYPE_FK5:
		call imastr (im, "radecsys", "FK5")
		call imaddd (im, "equinox", SKY_EQUINOX(coo))
		#iferr (call imdelf (im, "epoch"))
		    #;
	        iferr (call imdelf (im, "mjd-wcs"))
		    ;
		#call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))
	    case EQTYPE_GAPPT:
		call imastr (im, "radecsys", "GAPPT")
		iferr (call imdelf (im, "equinox"))
		    ;
		#iferr (call imdelf (im, "epoch"))
		    #;
		call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))
	    }

	case CTYPE_ECLIPTIC:
	    call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "elon")
	    call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "elat")
	    iferr (call imdelf (im, "radecsys"))
		;
	    iferr (call imdelf (im, "equinox"))
		;
	    #iferr (call imdelf (im, "epoch"))
		#;
	    call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))

	case CTYPE_GALACTIC:
	    call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "glon")
	    call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "glat")
	    iferr (call imdelf (im, "radecsys"))
		;
	    iferr (call imdelf (im, "equinox"))
		;
	    #iferr (call imdelf (im, "epoch"))
		#;
	    iferr (call imdelf (im, "mjd-wcs"))
		;
	    #call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))

	case CTYPE_SUPERGALACTIC:
	    call mw_swattrs (mw, SKY_PLNGAX(coo), "axtype", "slon")
	    call mw_swattrs (mw, SKY_PLATAX(coo), "axtype", "slat")
	    iferr (call imdelf (im, "radecsys"))
		;
	    iferr (call imdelf (im, "equinox"))
		;
	    #iferr (call imdelf (im, "epoch"))
		#;
	    iferr (call imdelf (im, "mjd-wcs"))
		;
	    #call imaddd (im, "mjd-wcs", SKY_EPOCH(coo))
	}
end


# SK_CTYPEIM -- Modify the CTYPE keywords appropriately. This step will
# become unnecessary when MWCS is updated to deal with non-equatorial celestial
# coordinate systems.

procedure sk_ctypeim (coo, im)

pointer	coo			#I pointer to the coordinate structure
pointer	im			#I image descriptor

pointer	sp, wtype, key1, key2, attr
int	rg_wrdstr()

begin
	call smark (sp)
	call salloc (key1, 8, TY_CHAR)
	call salloc (key2, 8, TY_CHAR)
	call salloc (wtype, 3, TY_CHAR)
	call salloc (attr, 8, TY_CHAR)

	call sprintf (Memc[key1], 8, "CTYPE%d")
	    call pargi (SKY_PLNGAX(coo))
	call sprintf (Memc[key2], 8, "CTYPE%d")
	    call pargi (SKY_PLATAX(coo))

	if (SKY_WTYPE(coo) <= 0 || SKY_WTYPE(coo) == WTYPE_LIN) {
	    call imastr (im, Memc[key1], "LINEAR")
	    call imastr (im, Memc[key2], "LINEAR")
	    call sfree (sp)
	    return
	}

	if (rg_wrdstr (SKY_WTYPE(coo), Memc[wtype], 3, WTYPE_LIST) <= 0)
	    call strcpy ("tan", Memc[wtype], 3)
	call strupr (Memc[wtype])

	# Move all this to a separate routine
	switch (SKY_CTYPE(coo)) {

	case CTYPE_EQUATORIAL:
	    call sprintf (Memc[attr], 8, "RA---%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key1], Memc[attr])
	    call sprintf (Memc[attr], 8, "DEC--%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key2], Memc[attr])

	case CTYPE_ECLIPTIC:
	    call sprintf (Memc[attr], 8, "ELON-%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key1], Memc[attr])
	    call sprintf (Memc[attr], 8, "ELAT-%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key2], Memc[attr])

	case CTYPE_GALACTIC:
	    call sprintf (Memc[attr], 8, "GLON-%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key1], Memc[attr])
	    call sprintf (Memc[attr], 8, "GLAT-%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key2], Memc[attr])

	case CTYPE_SUPERGALACTIC:
	    call sprintf (Memc[attr], 8, "SLON-%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key1], Memc[attr])
	    call sprintf (Memc[attr], 8, "SLAT-%3s") 
		call pargstr (Memc[wtype])
	    call imastr (im, Memc[key2], Memc[attr])

	default:
	    call imastr (im, Memc[key1], "LINEAR")
	    call imastr (im, Memc[key2], "LINEAR")
	}

	call sfree (sp)
end


# SK_STATD -- Get a double precision coordinate parameter.

double procedure sk_statd (coo, param)

pointer	coo			#I pointer to the coordinate structure
int	param			#I the input parameter

begin
	switch (param) {
	case S_VXOFF:
	    return (SKY_VXOFF(coo))
	case S_VYOFF:
	    return (SKY_VYOFF(coo))
	case S_VXSTEP:
	    return (SKY_VXSTEP(coo))
	case S_VYSTEP:
	    return (SKY_VYSTEP(coo))
	case S_EQUINOX:
	    return (SKY_EQUINOX(coo))
	case S_EPOCH:
	    return (SKY_EPOCH(coo))
	default:
	    call error (0, "SKY_STATD: Unknown coordinate system parameter")
	}
end


# SK_SETD -- Set a double precision coordinate parameter.

procedure sk_setd (coo, param, value)

pointer	coo			#I pointer to the coordinate structure
int	param			#I the input parameter
double	value			#I the parameter value

begin
	switch (param) {
	case S_VXOFF:
	    SKY_VXOFF(coo) = value
	case S_VYOFF:
	    SKY_VYOFF(coo) = value
	case S_VXSTEP:
	    SKY_VXSTEP(coo) = value
	case S_VYSTEP:
	    SKY_VYSTEP(coo) = value
	case S_EQUINOX:
	    SKY_EQUINOX(coo) = value
	case S_EPOCH:
	    SKY_EPOCH(coo) = value
	default:
	    call error (0, "SKY_SETD: Unknown coordinate system parameter")
	}
end


# SK_STATI -- Get an integer coordinate parameter.

int procedure sk_stati (coo, param)

pointer	coo			#I pointer to the coordinate structure
int	param			#I the input parameter

begin
	switch (param) {
	case S_CTYPE:
	    return (SKY_CTYPE(coo))
	case S_RADECSYS:
	    return (SKY_RADECSYS(coo))
	case S_WTYPE:
	    return (SKY_WTYPE(coo))
	case S_PLNGAX:
	    return (SKY_PLNGAX(coo))
	case S_PLATAX:
	    return (SKY_PLATAX(coo))
	case S_XLAX:
	    return (SKY_XLAX(coo))
	case S_YLAX:
	    return (SKY_YLAX(coo))
	case S_PTYPE:
	    return (SKY_PTYPE(coo))
	case S_NLNGAX:
	    return (SKY_NLNGAX(coo))
	case S_NLATAX:
	    return (SKY_NLATAX(coo))
	case S_NLNGUNITS:
	    return (SKY_NLNGUNITS(coo))
	case S_NLATUNITS:
	    return (SKY_NLATUNITS(coo))
	case S_STATUS:
	    return (SKY_STATUS(coo))
	default:
	    call error (0, "SKY_STATI: Unknown coordinate system parameter")
	}
end


# SK_SETI -- Set an integer coordinate parameter.

procedure sk_seti (coo, param, value)

pointer	coo			#I pointer to the coordinate structure
int	param			#I the input parameter
int	value			#I the parameter value

begin
	switch (param) {
	case S_CTYPE:
	    SKY_CTYPE(coo) = value
	case S_RADECSYS:
	    SKY_RADECSYS(coo) = value
	case S_WTYPE:
	    SKY_WTYPE(coo) = value
	case S_PLNGAX:
	    SKY_PLNGAX(coo) = value
	case S_PLATAX:
	    SKY_PLATAX(coo) = value
	case S_XLAX:
	    SKY_XLAX(coo) = value
	case S_YLAX:
	    SKY_YLAX(coo) = value
	case S_PTYPE:
	    SKY_PTYPE(coo) = value
	case S_NLNGAX:
	    SKY_NLNGAX(coo) = value
	case S_NLATAX:
	    SKY_NLATAX(coo) = value
	case S_NLNGUNITS:
	    SKY_NLNGUNITS(coo) = value
	case S_NLATUNITS:
	    SKY_NLATUNITS(coo) = value
	case S_STATUS:
	    SKY_STATUS(coo) = value
	default:
	    call error (0, "SKY_SETI: Unknown coordinate system parameter")
	}
end


# SK_GETSTR -- Get a character string coordinate parameter.

procedure sk_getstr (coo, param, value, maxch)

pointer	coo			#I pointer to the coordinate structure
int	param			#I the input parameter
char	value			#O the output string
int	maxch			#I the maximum size of the string

begin
	switch (param) {
	case S_COOSYSTEM:
	    call strcpy (SKY_COOSYSTEM(coo), value, maxch)
	default:
	    call error (0, "SKY_GETSTR: Unknown coordinate system parameter")
	}
end


# SK_SETSTR -- Set a character string coordinate parameter.

procedure sk_setstr (coo, param, value)

pointer	coo			#I pointer to the coordinate structure
int	param			#I the input parameter
char	value[ARB]		#I the parameter value

begin
	switch (param) {
	case S_COOSYSTEM:
	    call strcpy (value, SKY_COOSYSTEM(coo), SZ_FNAME)
	default:
	    call error (0, "SKY_SETSTR: Unknown coordinate system parameter")
	}
end


# SK_IIPRINT -- Print a summary of the input image or list coordinate system.

procedure sk_iiprint (label, imagesys, mw, coo)

char	label[ARB]		#I the input label
char	imagesys[ARB]		#I the input image name and wcs
pointer	mw			#I pointer to the image wcs
pointer	coo			#I pointer to the coordinate system structure

begin
	if (mw == NULL)
	    call sk_inprint (label, imagesys, SKY_CTYPE(coo),
	        SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo))
	else
	    call sk_imprint (label, imagesys, SKY_CTYPE(coo), SKY_PLNGAX(coo),
	        SKY_PLATAX(coo), SKY_WTYPE(coo), SKY_PTYPE(coo),
		SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo))
end


# SK_IIWRITE -- Write a summary of the input image or list coordinate system
# to the output file

procedure sk_iiwrite (fd, label, imagesys, mw, coo)

int	fd			#I the output file descriptor
char	label[ARB]		#I the input label
char	imagesys[ARB]		#I the input image name and wcs
pointer	mw			#I pointer to the image wcs
pointer	coo			#I pointer to the coordinate system structure

begin
	if (mw == NULL)
	    call sk_inwrite (fd, label, imagesys, SKY_CTYPE(coo),
	        SKY_RADECSYS(coo), SKY_EQUINOX(coo), SKY_EPOCH(coo))
	else
	    call sk_imwrite (fd, label, imagesys, SKY_CTYPE(coo),
	        SKY_PLNGAX(coo), SKY_PLATAX(coo), SKY_WTYPE(coo),
		SKY_PTYPE(coo), SKY_RADECSYS(coo), SKY_EQUINOX(coo),
		SKY_EPOCH(coo))
end


# SK_INPRINT -- Print a summary of the input list coordinate system.

procedure sk_inprint (label, system, ctype, radecsys, equinox, epoch)

char	label[ARB]		#I the input label
char	system[ARB]		#I the input system
int	ctype			#I the input coordinate type
int	radecsys		#I the input equatorial reference system
double	equinox			#I the input equinox
double	epoch			#I the input epoch of the observation

pointer	sp, radecstr
double	sl_epj(), sl_epb()
int	rg_wrdstr()

begin
	call smark (sp)
	call salloc (radecstr, SZ_FNAME, TY_CHAR)

	switch (ctype) {

	case CTYPE_EQUATORIAL:
	    if (rg_wrdstr (radecsys, Memc[radecstr], SZ_FNAME,
	        EQTYPE_LIST) <= 0)
	        call strcpy ("FK5", Memc[radecstr], SZ_FNAME)
	    call strupr (Memc[radecstr])
	    call printf ("%s: %s  Coordinates: equatorial %s\n")
	        call pargstr (label)
		call pargstr (system)
		call pargstr (Memc[radecstr])
	    switch (radecsys) {
	    case EQTYPE_GAPPT:
		call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		    call pargd (epoch)
		    if (IS_INDEFD(epoch)) {
			call pargd (INDEFD)
			call pargd (INDEFD)
		    } else {
		        call pargd (sl_epj (epoch))
		        call pargd (sl_epb (epoch))
		    }
	    case EQTYPE_FK5:
		call printf ("    Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n")
		    call pargd (equinox)
		    call pargd (sl_epj(epoch))
		    call pargd (epoch)
	    default:
		call printf ("    Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n")
		    call pargd (equinox)
		    call pargd (sl_epb(epoch))
		    call pargd (epoch)
	    }

	case CTYPE_ECLIPTIC:
	    call printf ("%s: %s  Coordinates: ecliptic\n")
		call pargstr (label)
		call pargstr (system)
	    call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		if (IS_INDEFD(epoch)) {
		    call pargd (INDEFD)
		    call pargd (INDEFD)
		} else {
		    call pargd (sl_epj(epoch))
		    call pargd (sl_epb(epoch))
		}

	case CTYPE_GALACTIC:
	    call printf ("%s: %s  Coordinates: galactic\n")
		call pargstr (label)
		call pargstr (system)
	    call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj (epoch))
		call pargd (sl_epb (epoch))

	case CTYPE_SUPERGALACTIC:
	    call printf ("%s: %s  Coordinates: supergalactic\n")
		call pargstr (label)
		call pargstr (system)
	    call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj (epoch))
		call pargd (sl_epb (epoch))

	}

	call sfree (sp)
end


# SK_INWRITE -- Write a summary of the input coordinate system.

procedure sk_inwrite (fd, label, system, ctype, radecsys, equinox, epoch)

int	fd			#I the output file descriptor
char	label[ARB]		#I the input label
char	system[ARB]		#I the input system
int	ctype			#I the input coordinate type
int	radecsys		#I the input equatorial reference system
double	equinox			#I the input equinox
double	epoch			#I the input epoch of the observation

pointer	sp, radecstr
double	sl_epj(), sl_epb()
int	rg_wrdstr()

begin
	call smark (sp)
	call salloc (radecstr, SZ_FNAME, TY_CHAR)

	switch (ctype) {

	case CTYPE_EQUATORIAL:
	    if (rg_wrdstr (radecsys, Memc[radecstr], SZ_FNAME,
	        EQTYPE_LIST) <= 0)
	        call strcpy ("FK5", Memc[radecstr], SZ_FNAME)
	    call strupr (Memc[radecstr])
	    call fprintf (fd, "# %s: %s  Coordinates: equatorial %s\n")
	        call pargstr (label)
	        call pargstr (system)
		call pargstr (Memc[radecstr])
	    switch (radecsys) {
	    case EQTYPE_GAPPT:
		call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		    call pargd (epoch)
		    if (IS_INDEFD(epoch)) {
		        call pargd (INDEFD)
		        call pargd (INDEFD)
		    } else {
		        call pargd (sl_epj(epoch))
		        call pargd (sl_epb(epoch))
		    }
	    case EQTYPE_FK5:
		call fprintf (fd,
		    "#     Equinox: J%0.3f Epoch: J%0.8f MJD: %0.5f\n")
		    call pargd (equinox)
		    call pargd (sl_epj(epoch))
		    call pargd (epoch)
	    default:
		call fprintf (fd,
		    "#     Equinox: B%0.3f Epoch: B%0.8f MJD: %0.5f\n")
		    call pargd (equinox)
		    call pargd (sl_epb(epoch))
		    call pargd (epoch)
	    }

	case CTYPE_ECLIPTIC:
	    call fprintf (fd, "# %s: %s  Coordinates: ecliptic\n")
		call pargstr (label)
		call pargstr (system)
	    call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		if (IS_INDEFD(epoch)) {
		    call pargd (INDEFD)
		    call pargd (INDEFD)
		} else {
		    call pargd (sl_epj(epoch))
		    call pargd (sl_epb(epoch))
		}

	case CTYPE_GALACTIC:
	    call fprintf (fd, "# %s: %s  Coordinates: galactic\n")
		call pargstr (label)
		call pargstr (system)
	    call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj(epoch))
		call pargd (sl_epb(epoch))

	case CTYPE_SUPERGALACTIC:
	    call fprintf (fd, "# %s: %s  Coordinates: supergalactic\n")
		call pargstr (label)
		call pargstr (system)
	    call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj(epoch))
		call pargd (sl_epb(epoch))

	}

	call sfree (sp)
end


# SK_IMPRINT -- Print a summary of the input image coordinate system.

procedure sk_imprint (label, imagesys, ctype, lngax, latax, wtype, ptype,
	radecsys, equinox, epoch)

char	label[ARB]		#I input label
char	imagesys[ARB]		#I the input image name and system
int	ctype			#I the image coordinate type
int	lngax			#I the image ra/glon/elon axis
int	latax			#I the image dec/glat/elat axis
int	wtype			#I the image projection type
int	ptype			#I the image image wcs type
int	radecsys		#I the image equatorial reference system
double	equinox			#I the image equinox
double	epoch			#I the image epoch of the observation

pointer	sp, imname, projstr, wcsstr, radecstr
double	sl_epj(), sl_epb()
int	rg_wrdstr()

begin
	call smark (sp)
	call salloc (imname, SZ_FNAME, TY_CHAR)
	call salloc (projstr, SZ_FNAME, TY_CHAR)
	call salloc (wcsstr, SZ_FNAME, TY_CHAR)
	call salloc (radecstr, SZ_FNAME, TY_CHAR)

	call sscan (imagesys)
	    call gargwrd (Memc[imname], SZ_FNAME)
	if (rg_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0)
	    call strcpy ("linear", Memc[projstr], SZ_FNAME)
	call strupr (Memc[projstr])
	if (rg_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0)
	    call strcpy ("world", Memc[wcsstr], SZ_FNAME)
	call strlwr (Memc[wcsstr])

	switch (ctype) {

	case CTYPE_EQUATORIAL:
	    if (rg_wrdstr (radecsys, Memc[radecstr], SZ_FNAME,
	        EQTYPE_LIST) <= 0)
	        call strcpy ("FK5", Memc[radecstr], SZ_FNAME)
	    call strupr (Memc[radecstr])
	    call printf (
	    "%s: %s %s  Projection: %s  Ra/Dec axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    switch (radecsys) {
	    case EQTYPE_GAPPT:
	        call printf ("    Coordinates: equatorial %s\n")
		    call pargstr (Memc[radecstr])
		call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		    call pargd (epoch)
		    if (IS_INDEFD(epoch)) {
			call pargd (INDEFD)
			call pargd (INDEFD)
		    } else {
		        call pargd (sl_epj(epoch))
		        call pargd (sl_epb(epoch))
		    }
	    case EQTYPE_FK5:
	        call printf ("    Coordinates: equatorial %s Equinox: J%0.3f\n")
		    call pargstr (Memc[radecstr])
		    call pargd (equinox)
	        call printf ("    Epoch: J%0.8f MJD: %0.5f\n")
		    call pargd (sl_epj (epoch))
		    call pargd (epoch)
	    default:
	        call printf ("    Coordinates: equatorial %s Equinox: B%0.3f\n")
		    call pargstr (Memc[radecstr])
		    call pargd (equinox)
	        call printf ("    Epoch: B%0.8f MJD: %0.5f\n")
		    call pargd (sl_epb (epoch))
		    call pargd (epoch)
	    }

	case CTYPE_ECLIPTIC:
	    call printf (
	    "%s: %s %s  Projection: %s  Elong/Elat axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    call printf ("    Coordinates: ecliptic\n")
	    call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		if (IS_INDEFD(epoch)) {
		    call pargd (INDEFD)
		    call pargd (INDEFD)
		} else {
		    call pargd (sl_epj(epoch))
		    call pargd (sl_epb(epoch))
		}

	case CTYPE_GALACTIC:
	    call printf (
	    "%s: %s %s  Projection: %s  Glong/Glat axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    call printf ("    Coordinates: galactic\n")
	    call printf ("    MJD: %0.5f  Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj (epoch))
		call pargd (sl_epb (epoch))

	case CTYPE_SUPERGALACTIC:
	    call printf (
	    "%s: %s %s  Projection: %s  Slong/Slat axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    call printf ("    Coordinates: supergalactic\n")
	    call printf ("    MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj (epoch))
		call pargd (sl_epb (epoch))
	}

	call sfree (sp)
end


# SK_IMWRITE -- Write a summary of the image coordinate system to the
# output file.

procedure sk_imwrite (fd, label, imagesys, ctype, lngax, latax, wtype, ptype,
	radecsys, equinox, epoch)

int	fd			#I the output file descriptor
char	label[ARB]		#I input label
char	imagesys[ARB]		#I the input image name and wcs
int	ctype			#I the image coordinate type
int	lngax			#I the image ra/glon/elon axis
int	latax			#I the image dec/glat/elat axis
int	wtype			#I the image projection type
int	ptype			#I the image image wcs type
int	radecsys		#I the image equatorial reference system
double	equinox			#I the image equinox
double	epoch			#I the image epoch of the observation

pointer	sp, imname, projstr, wcsstr, radecstr
double	sl_epj(), sl_epb()
int	rg_wrdstr()

begin
	call smark (sp)
	call salloc (imname, SZ_FNAME, TY_CHAR)
	call salloc (projstr, SZ_FNAME, TY_CHAR)
	call salloc (wcsstr, SZ_FNAME, TY_CHAR)
	call salloc (radecstr, SZ_FNAME, TY_CHAR)

	call sscan (imagesys)
	    call gargwrd (Memc[imname], SZ_FNAME)
	if (rg_wrdstr (wtype, Memc[projstr], SZ_FNAME, WTYPE_LIST) <= 0)
	    call strcpy ("linear", Memc[projstr], SZ_FNAME)
	call strupr (Memc[projstr])
	if (rg_wrdstr (ptype, Memc[wcsstr], SZ_FNAME, PIXTYPE_LIST) <= 0)
	    call strcpy ("world", Memc[wcsstr], SZ_FNAME)
	call strlwr (Memc[wcsstr])

	switch (ctype) {

	case CTYPE_EQUATORIAL:
	    if (rg_wrdstr (radecsys, Memc[radecstr], SZ_FNAME,
	        EQTYPE_LIST) <= 0)
	        call strcpy ("FK5", Memc[radecstr], SZ_FNAME)
	    call strupr (Memc[radecstr])
	    call fprintf (fd,
	    "# %s: %s %s  Projection: %s  Ra/Dec axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    switch (radecsys) {
	    case EQTYPE_GAPPT:
	        call fprintf (fd, "#     Coordinates: equatorial %s\n")
		    call pargstr (Memc[radecstr])
		call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		    call pargd (epoch)
		    if (IS_INDEFD(epoch)) {
		        call pargd (INDEFD)
		        call pargd (INDEFD)
		    } else {
		        call pargd (sl_epj(epoch))
		        call pargd (sl_epb(epoch))
		    }
	    case EQTYPE_FK5:
	        call fprintf (fd,
		    "#     Coordinates: equatorial %s Equinox: J%0.3f\n")
		    call pargstr (Memc[radecstr])
		    call pargd (equinox)
	        call fprintf (fd, "#     Epoch: J%0.8f MJD: %0.5f\n")
		    call pargd (sl_epj(epoch))
		    call pargd (epoch)
	    default:
	        call fprintf (fd,
		    "#     Coordinates: equatorial %s Equinox: B%0.3f\n")
		    call pargstr (Memc[radecstr])
		    call pargd (equinox)
	        call fprintf (fd, "#     Epoch: B%0.8f MJD: %0.5f\n")
		    call pargd (sl_epb (epoch))
		    call pargd (epoch)
	    }

	case CTYPE_ECLIPTIC:
	    call fprintf (fd,
	    "# %s: %s %s  Projection: %s  Elong/Elat axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    call fprintf (fd, "#     Coordinates: ecliptic\n")
	    call fprintf (fd, "#     MJD: %0.5f  Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		if (IS_INDEFD(epoch)) {
		    call pargd (INDEFD)
		    call pargd (INDEFD)
		} else {
		    call pargd (sl_epj(epoch))
		    call pargd (sl_epb(epoch))
		}

	case CTYPE_GALACTIC:
	    call fprintf (fd,
	    "# %s: %s %s  Projection: %s  Glong/Glat axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    call fprintf (fd, "#     Coordinates: galactic\n")
	    call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj(epoch))
		call pargd (sl_epb(epoch))

	case CTYPE_SUPERGALACTIC:
	    call fprintf (fd,
	    "# %s: %s %s  Projection: %s  Slong/Slat axes: %d/%d\n")
		call pargstr (label)
		call pargstr (Memc[imname])
		call pargstr (Memc[wcsstr])
	        call pargstr (Memc[projstr])
	        call pargi (lngax)
	        call pargi (latax)
	    call fprintf (fd, "#     Coordinates: supergalactic\n")
	    call fprintf (fd, "#     MJD: %0.5f Epoch: J%0.8f B%0.8f\n")
		call pargd (epoch)
		call pargd (sl_epj(epoch))
		call pargd (sl_epb(epoch))
	}

	call sfree (sp)
end


# SK_ULTRAN -- Transform the sky coordinates from the input coordinate
# system to the output coordinate system using the units conversions as
# appropriate.

procedure sk_ultran (cooin, cooout, ilng, ilat, olng, olat, npts) 

pointer	cooin		#I pointer to the input coordinate system structure
pointer	cooout		#I pointer to the output coordinate system structure
double	ilng[ARB]	#I the input ra/longitude in radians
double	ilat[ARB]	#I the input dec/latitude in radians
double	olng[ARB]	#I the output ra/longitude in radians
double	olat[ARB]	#I the output dec/latitude in radians
int	npts		#I the number of points to be converted

double	tilng, tilat, tolng, tolat
int	i

begin
	do i = 1, npts {

	    switch (SKY_NLNGUNITS(cooin)) {
	    case SKY_HOURS:
		tilng = DEGTORAD(15.0d0 * ilng[i])
	    case SKY_DEGREES:
		tilng = DEGTORAD(ilng[i])
	    case SKY_RADIANS:
		tilng = ilng[i]
	    default:
		tilng = ilng[i]
	    }
	    switch (SKY_NLATUNITS(cooin)) {
	    case SKY_HOURS:
		tilat = DEGTORAD(15.0d0 * ilat[i])
	    case SKY_DEGREES:
		tilat = DEGTORAD(ilat[i])
	    case SKY_RADIANS:
		tilat = ilat[i]
	    default:
		tilat = ilat[i]
	    }

	    call sk_lltran (cooin, cooout, tilng, tilat, INDEFD, INDEFD,
		0.0d0, 0.0d0, tolng, tolat)

	    switch (SKY_NLNGUNITS(cooout)) {
	    case SKY_HOURS:
		olng[i] = RADTODEG(tolng) / 15.0d0
	    case SKY_DEGREES:
		olng[i] = RADTODEG(tolng)
	    case SKY_RADIANS:
		olng[i] = tolng
	    default:
		olng[i] = tolng
	    }
	    switch (SKY_NLATUNITS(cooout)) {
	    case SKY_HOURS:
		olat[i] = RADTODEG(tolat) / 15.0d0
	    case SKY_DEGREES:
		olat[i] = RADTODEG(tolat)
	    case SKY_RADIANS:
		olat[i] = tolat
	    default:
		olat[i] = tolat
	    }
	}
end


# SK_LLTRAN -- Transform the sky coordinate from the input coordinate
# system to the output coordinate system assuming that all the coordinate
# are in radians.

procedure sk_lltran (cooin, cooout, ilng, ilat, ipmlng, ipmlat, px, rv,
	olng, olat)

pointer	cooin		#I pointer to the input coordinate system structure
pointer	cooout		#I pointer to the output coordinate system structure
double	ilng		#I the input ra/longitude in radians
double	ilat		#I the input dec/latitude in radians
double	ipmlng		#I the input proper motion in ra in radians
double	ipmlat		#I the input proper motion in dec in radians
double	px		#I the input parallax in arcseconds
double	rv		#I the input radial velocity in km / second
double	olng		#I the output ra/longitude in radians
double	olat		#I the output dec/latitude in radians

int	pmflag
double	pmr, pmd
double	sl_epj(), sl_epb()

begin
	# Test for the case where the input coordinate system is the
	# same as the output coordinate system.
	if (SKY_CTYPE(cooin) == SKY_CTYPE(cooout)) {

	    switch (SKY_CTYPE(cooin)) {

	    case CTYPE_EQUATORIAL:
		call sk_equatorial (cooin, cooout, ilng, ilat, ipmlng,
		    ipmlat, px, rv, olng, olat)

	    case CTYPE_ECLIPTIC:
		if (SKY_EPOCH(cooin) == SKY_EPOCH(cooout)) {
		    olng = ilng
		    olat = ilat
		} else {
		    call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat)
		    call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat)
		}

	    default:
		olng = ilng
		olat = ilat
	    }

	    return
	}

	# Compute proper motions ?
	if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat))
	    pmflag = YES
	else
	    pmflag = NO

	# Cover the remaining cases.
	switch (SKY_CTYPE(cooin)) {

	# The input system is equatorial.
	case CTYPE_EQUATORIAL:

	    switch (SKY_RADECSYS(cooin)) {

	    case EQTYPE_FK4, EQTYPE_FK4NOE:
	        if (pmflag == YES) {
		    call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv,
		        sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)),
			olng, olat)
	        } else {
		    olng = ilng
		    olat = ilat
	        }
		if (SKY_RADECSYS(cooin) == EQTYPE_FK4)
		    call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat)
		if (SKY_EQUINOX(cooin) != 1950.0d0)
		    call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) 
		call sl_adet (olng, olat, 1950.0d0, olng, olat)
		if (pmflag == YES)
		    call sl_f45z (olng, olat, sl_epb(SKY_EPOCH(cooout)),
		        olng, olat)
		else
		    call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)),
		        olng, olat)

	    case EQTYPE_FK5:
	        if (pmflag == YES) {
		    call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv,
		        sl_epj (SKY_EPOCH(cooin)), sl_epj(SKY_EPOCH(cooout)),
			olng, olat)
	        } else {
	            olng = ilng
	            olat = ilat
		}
		if (SKY_EQUINOX(cooin) != 2000.0d0)
		    call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) 

	    case EQTYPE_GAPPT:
		call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat)

	    }

	    switch (SKY_CTYPE(cooout)) {

	    # The output coordinate system is ecliptic.
	    case CTYPE_ECLIPTIC:
		call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat)

	    # The output coordinate system is galactic.
	    case CTYPE_GALACTIC:
		call sl_eqga (olng, olat, olng, olat)

	    # The output coordinate system is supergalactic.
	    case CTYPE_SUPERGALACTIC:
		call sl_eqga (olng, olat, olng, olat)
		call sl_gasu (olng, olat, olng, olat)

	    default:
	        olng = ilng
	        olat = ilat
	    }

	# The input coordinate system is ecliptic.
	case CTYPE_ECLIPTIC:

	    call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat)
	    switch (SKY_CTYPE(cooout)) {

	    # The output coordinate system is equatorial.
	    case CTYPE_EQUATORIAL:
		#call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat)
		switch (SKY_RADECSYS(cooout)) {
		case EQTYPE_FK4, EQTYPE_FK4NOE:
		    call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)),
		        olng, olat, pmr, pmd)
		    call sl_suet (olng, olat, 1950.0d0, olng, olat)
		    if (SKY_EQUINOX(cooout) != 1950.0d0)
			call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		    if (SKY_RADECSYS(cooout) == EQTYPE_FK4)
		        call sl_adet (olng, olat, SKY_EQUINOX(cooout),
			    olng, olat)
		case EQTYPE_FK5:
		    if (SKY_EQUINOX(cooout) != 2000.0d0)
			call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		case EQTYPE_GAPPT:
		    call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0,
			2000.0d0, SKY_EPOCH(cooout), olng, olat)
		}

	    # The output coordinate system is galactic.
	    case CTYPE_GALACTIC:
		#call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat)
		call sl_eqga (olng, olat, olng, olat)

	    # The output system is supergalactic.
	    case CTYPE_SUPERGALACTIC:
		#call sl_eceq (ilng, ilat, SKY_EPOCH(cooin), olng, olat)
		call sl_eqga (olng, olat, olng, olat)
		call sl_gasu (olng, olat, olng, olat)

	    default:
	        olng = ilng
	        olat = ilat
	    }

	# The input coordinate system is galactic.
	case CTYPE_GALACTIC:

	    switch (SKY_CTYPE(cooout)) {

	    # The output coordinate system is equatorial.
	    case CTYPE_EQUATORIAL:
	        call sl_gaeq (ilng, ilat, olng, olat)
		switch (SKY_RADECSYS(cooout)) {
		case EQTYPE_FK4, EQTYPE_FK4NOE:
		    call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)),
		        olng, olat, pmr, pmd)
		    call sl_suet (olng, olat, 1950.0d0, olng, olat)
		    if (SKY_EQUINOX(cooout) != 1950.0d0)
			call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		    if (SKY_RADECSYS(cooout) == EQTYPE_FK4)
		        call sl_adet (olng, olat, SKY_EQUINOX(cooout),
			    olng, olat)
		case EQTYPE_FK5:
		    if (SKY_EQUINOX(cooout) != 2000.0d0)
			call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		case EQTYPE_GAPPT:
		    call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0,
			2000.0d0, SKY_EPOCH(cooout), olng, olat)
		}

	    # The output coordinate system is ecliptic.
	    case CTYPE_ECLIPTIC:
		call sl_gaeq (ilng, ilat, olng, olat)
		call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat)

	    # The output coordinate system is supergalactic.
	    case CTYPE_SUPERGALACTIC:
		call sl_gasu (ilng, ilat, olng, olat)

	    default:
	        olng = ilng
	        olat = ilat
	    }

	# The input coordinates are supergalactic.
	case CTYPE_SUPERGALACTIC:

	    switch (SKY_CTYPE(cooout)) {

	    case CTYPE_EQUATORIAL:
		call sl_suga (ilng, ilat, olng, olat)
		switch (SKY_RADECSYS(cooout)) {
		case EQTYPE_FK4:
		    call sl_gaeq (olng, olat, olng, olat)
		    call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)),
		        olng, olat, pmr, pmd)
		    call sl_suet (olng, olat, 1950.0d0, olng, olat)
		    if (SKY_EQUINOX(cooout) != 1950.0d0)
			call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		    call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat)
		case EQTYPE_FK4NOE:
		    call sl_gaeq (olng, olat, olng, olat)
		    call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)),
		        olng, olat, pmr, pmd)
		    call sl_suet (olng, olat, 1950.0d0, olng, olat)
		    if (SKY_EQUINOX(cooout) != 1950.0d0)
			call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		case EQTYPE_FK5:
		    call sl_gaeq (olng, olat, olng, olat)
		    if (SKY_EQUINOX(cooout) != 2000.0d0)
			call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout),
			    olng, olat) 
		case EQTYPE_GAPPT:
		    call sl_gaeq (olng, olat, olng, olat)
		    call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0,
			2000.0d0, SKY_EPOCH(cooout), olng, olat)
		}

	    case CTYPE_ECLIPTIC:
		call sl_suga (ilng, ilat, olng, olat)
		call sl_gaeq (olng, olat, olng, olat)
		call sl_eqec (olng, olat, SKY_EPOCH(cooout), olng, olat)

	    case CTYPE_GALACTIC:
		call sl_suga (ilng, ilat, olng, olat)

	    default:
	        olng = ilng
	        olat = ilat
	    }

	default:
	    olng = ilng
	    olat = ilat
	}
end


# SK_EQUATORIAL -- Convert / precess equatorial coordinates.

procedure sk_equatorial (cooin, cooout, ilng, ilat, ipmlng, ipmlat,
	px, rv, olng, olat)

pointer	cooin		#I the input coordinate system structure
pointer	cooout		#I the output coordinate system structure
double	ilng		#I the input ra in radians
double	ilat		#I the input dec in radians
double	ipmlng		#I the input proper motion in ra in radians
double	ipmlat		#I the input proper motion in dec in radians
double	px		#I the input parallax in arcseconds
double	rv		#I the input radial valocity in km / second
double	olng		#I the output ra in radians
double	olat		#I the output dec in radians

int	pmflag
double	pmr, pmd
double	sl_epb(), sl_epj()

begin
	# Check to see whether or not conversion / precession is necessary.
	if ((SKY_RADECSYS(cooin) == SKY_RADECSYS(cooout)) &&
	    (SKY_EQUINOX(cooin) == SKY_EQUINOX(cooout)) &&
	    (SKY_EPOCH(cooin) == SKY_EPOCH(cooout))) {
	    olng = ilng
	    olat = ilat
	    return
	}

	# Compute proper motions ?
	if (! IS_INDEFD(ipmlng) && ! IS_INDEFD(ipmlat))
	    pmflag = YES
	else
	    pmflag = NO

	switch (SKY_RADECSYS(cooin)) {

	# The input coordinate system is FK4 with or without the E terms.
	case EQTYPE_FK4, EQTYPE_FK4NOE:

	    if (pmflag == YES) {
		call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv,
		    sl_epb (SKY_EPOCH(cooin)), sl_epb (SKY_EPOCH(cooout)),
		    olng, olat)
	    } else {
		olng = ilng
		olat = ilat
	    }
	    if (SKY_RADECSYS(cooin) == EQTYPE_FK4)
		call sl_suet (olng, olat, SKY_EQUINOX(cooin), olng, olat)
	    if (SKY_EQUINOX(cooin) != 1950.0d0)
	        call sl_prcs (1, SKY_EQUINOX(cooin), 1950.0d0, olng, olat) 
	    call sl_adet (olng, olat, 1950.0d0, olng, olat)
	    if (pmflag == YES)
	        call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooout)),
		    olng, olat)
	    else
	        call sl_f45z (olng, olat, sl_epb (SKY_EPOCH(cooin)),
		    olng, olat)

	    switch (SKY_RADECSYS(cooout)) {

	    # The output coordinate system if FK4 with and without the E terms.
	    case EQTYPE_FK4, EQTYPE_FK4NOE:
		call sl_f54z (olng, olat, sl_epb (SKY_EPOCH(cooout)),
		    olng, olat, pmr, pmd)
	        call sl_suet (olng, olat, 1950.0d0, olng, olat)
		if (SKY_EQUINOX(cooout) != 1950.0d0)
	            call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout),
		        olng, olat) 
		if (SKY_RADECSYS(cooout) == EQTYPE_FK4)
	            call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat)

	    # The output coordinate system if FK5.
	    case EQTYPE_FK5:
		if (SKY_EQUINOX(cooout) != 2000.0d0)
		    call sl_prcs (2, 2000.0d0, SKY_EQUINOX(cooout), olng, olat) 

	    # The output coordinate system if geocentric apparent.
	    case EQTYPE_GAPPT:
		call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0,
		    SKY_EPOCH(cooout), olng, olat)
	    }

	# The input coordinate system is FK5 or geocentric apparent.
	case EQTYPE_FK5, EQTYPE_GAPPT:

	    if (SKY_RADECSYS(cooin) == EQTYPE_FK5) {
	        if (pmflag == YES) {
		    call sl_pm (ilng, ilat, ipmlng, ipmlat, px, rv,
		        sl_epj (SKY_EPOCH(cooin)), sl_epj (SKY_EPOCH(cooout)),
			    olng, olat)
	        } else {
	            olng = ilng
	            olat = ilat
		}
	    } else
	        call sl_amp (ilng, ilat, SKY_EPOCH(cooin), 2000.0d0, olng, olat)

	    switch (SKY_RADECSYS(cooout)) {

	    # The output coordinate system is FK4 with or without the E terms.
	    case EQTYPE_FK4, EQTYPE_FK4NOE:
	        if (SKY_EQUINOX(cooin) != 2000.0d0)
		    call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) 
		call sl_f54z (olng, olat, sl_epb(SKY_EPOCH(cooout)),
		    olng, olat, pmr, pmd)
		call sl_suet (olng, olat, 1950.0d0, olng, olat)
		if (SKY_EQUINOX(cooout) != 1950.0d0)
		    call sl_prcs (1, 1950.0d0, SKY_EQUINOX(cooout), olng, olat) 
		if (SKY_RADECSYS(cooout) == EQTYPE_FK4)
	            call sl_adet (olng, olat, SKY_EQUINOX(cooout), olng, olat)

	    # The output coordinate system is FK5.
	    case EQTYPE_FK5:
		if (SKY_EQUINOX(cooin) != SKY_EQUINOX(cooout))
		    call sl_prcs (2, SKY_EQUINOX(cooin), SKY_EQUINOX(cooout),
		        olng, olat) 

	    # The output coordinate system is geocentric apparent.
	    case EQTYPE_GAPPT:
	        if (SKY_EQUINOX(cooin) != 2000.0d0)
		    call sl_prcs (2, SKY_EQUINOX(cooin), 2000.0d0, olng, olat) 
		call sl_map (olng, olat, 0.0d0, 0.0d0, px, 0.0d0, 2000.0d0,
		    SKY_EPOCH(cooout), olng, olat)
	    }
	}
end


# RG_WRDSTR -- Search a dictionary string for a given string index number.
# This is the opposite function of strdic(), that returns the index for
# given string.  The entries in the dictionary string are separated by
# a delimiter character which is the first character of the dictionary
# string.  The index of the string found is returned as the function value.
# Otherwise, if there is no string for that index, a zero is returned.

int procedure rg_wrdstr (index, outstr, maxch, dict)

int	index			#I String index
char	outstr[ARB]		#O Output string as found in dictionary
int	maxch			#I Maximum length of output string
char	dict[ARB]		#IDictionary string

int	i, len, start, count

int	strlen()

begin
	# Clear the output string.
	outstr[1] = EOS

	# Return if the dictionary is not long enough.
	if (dict[1] == EOS)
	    return (0)

	# Initialize the counters.
	count = 1
	len   = strlen (dict)

	# Search the dictionary string. This loop only terminates
	# successfully if the index is found. Otherwise the procedure
	# returns with and error condition.
	for (start = 2; count < index; start = start + 1) {
	    if (dict[start] == dict[1])
		count = count + 1
	    if (start == len)
		return (0)
	}

	# Extract the output string from the dictionary.
	for (i = start; dict[i] != EOS && dict[i] != dict[1]; i = i + 1) {
	    if (i - start + 1 > maxch)
		break
	    outstr[i - start + 1] = dict[i]
	}
	outstr[i - start + 1] = EOS

	# Return index for output string.
	return (count)
end

mscred-5.05-2018.07.09/src/skywcsdef.h000066400000000000000000000025221332166314300167310ustar00rootroot00000000000000# The sky coordinates structure

define	LEN_SKYCOOSTRUCT	(30 + SZ_FNAME + 1)

define	SKY_VXOFF	Memd[P2D($1)]	    # logical ra/longitude offset
define	SKY_VYOFF	Memd[P2D($1+2)]	    # logical dec/tatitude offset
define	SKY_VXSTEP	Memd[P2D($1+4)]	    # logical ra/longitude stepsize
define	SKY_VYSTEP	Memd[P2D($1+6)]	    # logical dec/latitude stepsize
define	SKY_EQUINOX	Memd[P2D($1+8)]	    # equinox of ra/dec system (B or J)
define	SKY_EPOCH	Memd[P2D($1+10)]    # epoch of observation (MJD)
define	SKY_CTYPE	Memi[$1+12]	    # celestial coordinate system
define	SKY_RADECSYS	Memi[$1+13]	    # ra/dec system, e.g. FK4
define	SKY_WTYPE	Memi[$1+14]	    # sky projection system
define	SKY_PLNGAX	Memi[$1+15]	    # physical ra/longitude axis
define	SKY_PLATAX	Memi[$1+16]	    # physical dec/latitude axis
define	SKY_XLAX	Memi[$1+17]	    # logical ra/longitude axis
define	SKY_YLAX	Memi[$1+18]	    # latitude dec/latitude axis
define	SKY_PTYPE	Memi[$1+19]	    # iraf wcs system
define	SKY_NLNGAX	Memi[$1+20]	    # length of ra/longitude axis
define	SKY_NLATAX	Memi[$1+21]	    # length of dec/latitude axis
define	SKY_NLNGUNITS	Memi[$1+22]	    # the native ra/longitude units
define	SKY_NLATUNITS	Memi[$1+23]	    # the native dec/latitude units
define	SKY_STATUS	Memi[$1+24]	    # the status (OK or ERR)
define	SKY_COOSYSTEM	Memc[P2C($1+25)]    # the coordinate system

mscred-5.05-2018.07.09/src/t_addkey.x000066400000000000000000000114241332166314300165340ustar00rootroot00000000000000include	
include	
include	
include	

define  IDB_LENNUMERICRECORD    80              # length of new numeric records
define  IDB_SZFITSKEY           8               # max length FITS keyword


# T_ADDKEY -- Add a keyword with a comment.

procedure t_addkey ()

pointer	image		# Image to edit
pointer	key		# Keyword
pointer	sval		# Keyword string value
bool	bval		# Keyword boolean value
long	lval		# Keyword integer value
double	dval		# Keyword real value
pointer	comment		# Keyword comment
char	type		# Keyword type

char	clgetc()
bool	clgetb()
long	clgetl()
double	clgetd()
int	imaccf()
pointer	sp, im, immap()

begin
	call smark (sp)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (key, 8, TY_CHAR)
	call salloc (sval, SZ_FNAME, TY_CHAR)
	call salloc (comment, SZ_FNAME, TY_CHAR)

	# Get parameters.
	call clgstr ("image", Memc[image], SZ_FNAME)
	im = immap (Memc[image], READ_WRITE, 0)

	call clgstr ("keyword", Memc[key], 8)
	type = clgetc ("type")
	switch (type) {
	case 'b':
	    bval = clgetb ("value")
	case 's', 'i', 'l':
	    lval = clgetl ("value")
	case 'r', 'd':
	    dval = clgetd ("value")
	default:
	    call clgstr ("value", Memc[sval], SZ_FNAME)
	}
	call clgstr ("comment", Memc[comment], SZ_FNAME)

	# Initialize keyword with comment.
	if (imaccf (im, Memc[key]) == YES)
	    call imdelf (im, Memc[key])
	call imaddfc (im, Memc[key], type, Memc[comment])

	# Set value.
	switch (type) {
	case 'b':
	    call imaddb (im, Memc[key], bval)
	case 's', 'i', 'l':
	    call imaddl (im, Memc[key], lval)
	case 'r', 'd':
	    call imaddd (im, Memc[key], dval)
	default:
	    call imastr (im, Memc[key], Memc[sval])
	}

	call imunmap (im)
	call sfree (sp)
end



# IMADDFC -- Add a user field to the image header with an optional card
# comment.  It is an error if the named field already exists.

procedure imaddfc (im, key, datatype, comment)

pointer	im			#I image descriptor
char	key[ARB]		#I name of the new parameter
char	datatype[ARB]		#I string permits generalization to domains
char	comment[ARB]		#I comment string

pointer	rp, sp, keyname, ua, ip
int	fd, max_lenuserarea, curlen, buflen, nchars
int	idb_kwlookup(), idb_findrecord()
int	stropen(), strlen(), idb_filstr(), nowhite()
errchk	syserrs, stropen, fprintf, pargstr, pargi

begin
	call smark (sp)
	call salloc (keyname, SZ_FNAME, TY_CHAR)

	# FITS format requires that the keyword name be upper case, not to
	# exceed 8 characters in length.  [Nov97 - This is not entirely 
	# correct, FITS does not require upper case, however we don't want
	# to change this at this time.]

	nchars = idb_filstr (key, Memc[keyname], IDB_SZFITSKEY)
	nchars = nowhite (Memc[keyname], Memc[keyname], IDB_SZFITSKEY)
	call strupr (Memc[keyname])

	# Check for a redefinition.
	if ((idb_kwlookup (key) > 0) || (idb_findrecord (im, key, rp) > 0))
	    call syserrs (SYS_IDBREDEF, key)
	
	# Open the user area string for appending.  'buflen' is the malloc-ed
	# buffer length in struct units; IMU is the struct offset to the user
	# area, i.e., the size of that part of the image descriptor preceding
	# the user area.  If the buffer fills we must allow one extra char for
	# the EOS delimiter; since storage for the image descriptor was
	# allocated in struct units the storage allocator will not have
	# allocated space for the extra EOS char.

	ua = IM_USERAREA(im)
	curlen = strlen (Memc[ua])
	buflen = LEN_IMDES + IM_LENHDRMEM(im)
	max_lenuserarea = (buflen - IMU) * SZ_STRUCT - 1

	# If the user area is not empty the last character must be the newline
	# record delimiter, else the new record we add will be invalid.

	if (curlen > 0 && Memc[ua+curlen-1] != '\n')
	    if (curlen >= max_lenuserarea)
		call syserrs (SYS_IDBOVFL, key)
	    else {
		Memc[ua+curlen] = '\n'
		curlen = curlen + 1
		Memc[ua+curlen] = EOS
	    }

	fd = stropen (Memc[ua+curlen], max_lenuserarea-curlen, APPEND)

	# Append the new record with an uninitialized value field.
	iferr {
	    if (comment[1] == EOS) {
	        call fprintf (fd, "%-8s= %s%*t\n")
		    call pargstr (Memc[keyname])
		    if (datatype[1] == 'c') {
		        call pargstr ("'        '")
		    } else {
		        call pargstr ("")
		    }
	    } else {
	        call fprintf (fd, "%-8s= %s%33t/ %s%*t\n")
		    call pargstr (Memc[keyname])
		    if (datatype[1] == 'c') {
		        call pargstr ("'        '")
		    } else {
		        call pargstr ("")
		    }
		    call pargstr (comment)
	    }
	    call pargi (IDB_LENNUMERICRECORD + 1)

	} then {
	    # Out of space in the user area.  Discard the truncated card at the
	    # end of the buffer by backing up to the last newline and writing
	    # an EOS.

	    call close (fd)
	    for (ip=ua+max_lenuserarea-1;  ip > ua;  ip=ip-1)
		if (Memc[ip] == '\n') {
		    Memc[ip+1] = EOS
		    break
		}
	    call syserrs (SYS_IDBOVFL, key)
	}

	call close (fd)
	call sfree (sp)
end
mscred-5.05-2018.07.09/src/t_fitscopy.x000066400000000000000000000401071332166314300171330ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

include	
include	
include 
include 

# FITS header data structure.
define	LEN_HDR		261
define	GROUP		Memi[$1]		# Group number
define	NAXIS		Memi[$1+$2+1]		# Axes sizes
define	BITPIX		Memi[$1+9]		# Bits per pixel
define	NEXTEND		Memi[$1+10]		# Bits per pixel
define	XTENSION	Memc[P2C($1+20)]	# Extension type
define	EXTNAME		Memc[P2C($1+60)]	# Extension name
define	EXTVER		Memc[P2C($1+100)]	# Extension version
define	OBJECT		Memc[P2C($1+140)]	# Object/title
define	FILENAME	Memc[P2C($1+180)]	# Filename
define	TEMP		Memc[P2C($1+220)]	# Temporary string


# T_FITSCOPY -- Copy FITS files.

procedure t_fitscopy ()

int	input			# Input list of FITS files
int	output			# Output list of FITS files
int	list			# List only?
int	slist			# Short listing?
int	llist			# Long listing?
pointer	extn			# Extension for output disk filenames
int	offset			# Offset for numbering of  output disk filenames
int	original		# Rename to  original filename?
int	intape			# Input files on tape?
int	outtape			# Output files to tape?
pointer	tapefiles		# List of tape file numbers
int	blockfac		# FITS tape blocking factor

int	i, j, innum, outnum
pointer	sp, in_root, out_root, in_fname, out_fname, pat, rngstr, junk

int	fits_copy()
int	fntopnb(), imtopen(), clgeti(), fntgfnb(), fntlenb()
int	fstati(), btoi(), mtneedfileno(), mtfile(), gstrmatch(), nowhite()
int	decode_ranges(), get_next_number()
bool	clgetb()
errchk	fits_copy

begin
	call smark (sp)
	call salloc (in_root, SZ_LINE, TY_CHAR)
	call salloc (out_root, SZ_LINE, TY_CHAR)
	call salloc (extn, SZ_FNAME, TY_CHAR)
	call salloc (in_fname, SZ_FNAME, TY_CHAR)
	call salloc (out_fname, SZ_FNAME, TY_CHAR)
	call salloc (extn, SZ_FNAME, TY_CHAR)
	call salloc (pat, SZ_FNAME, TY_CHAR)
	call salloc (rngstr, SZ_LINE, TY_CHAR)
	call salloc (junk, SZ_LINE, TY_CHAR)

	# Flush on a newline if the output is not redirected.
	if (fstati (STDOUT, F_REDIR) == NO)
	    call fseti (STDOUT, F_FLUSHNL, YES)

	# Get the parameters.
	call clgstr ("input", Memc[in_root], SZ_LINE)
	list = btoi (clgetb ("listonly"))
	slist = btoi (clgetb ("shortlist"))
	llist = btoi (clgetb ("longlist"))
	intape = btoi (clgetb ("intape"))
	if (list == NO) {
	    call clgstr ("output", Memc[out_root], SZ_LINE)
	    call clgstr ("extn", Memc[extn+1], SZ_FNAME)
	    outtape = btoi (clgetb ("outtape"))
	    offset = clgeti ("offset")
	    original = btoi (clgetb ("original"))
	    blockfac = clgeti ("blocking_factor")
	    if (nowhite (Memc[out_root], Memc[out_root], SZ_LINE) == 0) {
		if (original == YES)
		    call mktemp ("tmp$", Memc[out_root], SZ_LINE)
		else
		    call error (1, "No output name specified")
	    }
	}

	if (list == YES && llist == NO)
	    slist = YES
	if (llist == YES && slist == YES)
	    slist = NO

	# Set the file name expansions.
	Memc[extn] = '.'
	call sprintf (Memc[pat], SZ_FNAME, "%s$")
	    call pargstr (Memc[extn])

	if (intape == NO) {
	    input = fntopnb (Memc[in_root], NO)
	} else {
	    input = imtopen (Memc[in_root])
	    if (fntgfnb (input, Memc[in_root], SZ_LINE) == EOF)
		call error (1, "No input tape name")
	    if (mtneedfileno (Memc[in_root]) == YES) {
		call fntclsb (input)
		call salloc (tapefiles, 100*3, TY_INT)
		call clgstr ("tapefiles", Memc[rngstr], SZ_LINE)
		if (decode_ranges (Memc[rngstr], Memi[tapefiles], 100,
		    innum) == ERR)
		    call error (1, "Error in tape file list")
	    } else
		call fntrewb (input)
	}

	output = NULL
	if (list == YES ||
	    nowhite (Memc[out_root], Memc[out_fname], SZ_FNAME) == 0) {
	    Memc[out_root] = EOS
	    Memc[out_fname] = EOS
	    outtape = NO
	} else {
	    if (outtape == YES) {
		if (mtneedfileno (Memc[out_root]) == YES) {
		    if (!clgetb ("newtape"))
			call mtfname (Memc[out_root], EOT, Memc[out_fname],
			    SZ_FNAME)
		    else
			call mtfname (Memc[out_root], 1, Memc[out_fname],
			    SZ_FNAME)
		}
		Memc[out_root] = EOS
	    } else {
		output = fntopnb (Memc[out_root], NO)
		if (input != NULL) {
		    if (fntlenb (output) != fntlenb (input)) {
			if (fntlenb (output) > 1)
			    call error (1, "Input and output lists don't match")
			if (fntgfnb (output, Memc[out_root], SZ_LINE) == EOF)
			    call error (1, "Error in output name")
			call fntclsb (output)
		    }
		} else {
		    if (fntgfnb (output, Memc[out_root], SZ_FNAME) == EOF)
			call error (1, "Error in output name")
		    call fntclsb (output)
		}
		if (gstrmatch (Memc[out_root], Memc[pat], i, j) != 0)
		    Memc[out_root+i-1] = EOS
	    }
	}

	# Copy the FITS files.
	innum = 0
	outnum = offset
	repeat {
	    if (input != NULL) {
		if (fntgfnb (input, Memc[in_fname], SZ_FNAME) == EOF)
		    break
		outnum = outnum + 1
		if (intape == NO) {
		    if (gstrmatch (Memc[in_fname], Memc[pat], i, j) == 0)
			call strcat (Memc[extn], Memc[in_fname], SZ_FNAME)
		} else if (mtfile (Memc[in_fname]) == YES) {
		    call mtparse (Memc[in_fname], Memc[junk], SZ_LINE,
			innum, i, Memc[junk], SZ_LINE)
		    if (innum != ERR)
			outnum = innum + offset 
		}
	    } else {
		if (get_next_number (Memi[tapefiles], innum) == EOF)
		    break
		call sprintf (Memc[in_fname], SZ_FNAME, "%s[%d]")
		    call pargstr (Memc[in_root])
		    call pargi (innum)
		outnum = innum + offset
	    }

	    if (list == NO && outtape == NO) {
		if (output != NULL) {
		    if (fntgfnb (output, Memc[out_fname], SZ_FNAME) == EOF)
			break
		    if (gstrmatch (Memc[out_fname], Memc[pat], i, j) == 0)
			call strcat (Memc[extn], Memc[out_fname], SZ_FNAME)
		} else if (Memc[out_root] != EOS) {
		    call sprintf (Memc[out_fname], SZ_FNAME, "%s%04d%s")
			call pargstr (Memc[out_root])
			call pargi (outnum)
			call pargstr (Memc[extn])
		}
	    }

	    iferr (i = fits_copy (Memc[in_fname], Memc[out_fname], list, slist,
		llist, original, Memc[extn], intape, outtape, blockfac)) {
		if (intape == YES || outtape == YES)
		    call erract (EA_ERROR)
		else
		    call erract (EA_WARN)
	    }

	    if (i == EOF) {
		if (slist == YES || llist == YES) {
		    if (intape == YES)
			call printf ("  End of tape\n")
		    else
			call printf ("  Empty file\n")
		}
		if (intape == YES)
		    break
	    }
	    if (outtape == YES)
		call mtfname (Memc[out_fname], EOT, Memc[out_fname],
		    SZ_FNAME)
	}

	if (input != NULL)
	    call fntclsb (input)
	if (output != NULL)
	    call fntclsb (output)
	call sfree (sp)
end


# FITS_COPY -- Copy FITS files.

int procedure fits_copy (in_fname, out_fname, list, slist, llist, original,
	extn, intape, outtape, blocking)

char	in_fname[ARB]		#I input file name
char	out_fname[ARB]		#I output file name
int	list			#I List only?
int	slist			#I Short list?
int	llist			#I Long list?
int	original		#I restore original file name?
char	extn[ARB]		#I extension for disk images
int	intape			#I input tape?
int	outtape			#I output tape?
int	blocking		#I output FITS blocking factor

int	in, out, mov_nbytes, rem_in, rem_out
int	sz_charsin, sz_charsout, szb_inrecord, szb_outrecord, szb_outblock
int	bytes_read, ip, op, nchars, recnum, hdrrec, err
long	bytes_write, offset
pointer	sp, inbuf, outbuf, hdr, errmsg, tmp, fname

int	fnroot(), mtopen(), read(), fstati(), open(), strmatch()
long	awaitb()
bool	strne()
errchk	open, mtopen, read, awriteb, awaitb, close, mfree, malloc
errchk	open, mtopen, fits_hdr

begin
	call smark (sp)
	call salloc (hdr, LEN_HDR, TY_STRUCT)
	call salloc (errmsg, SZ_LINE, TY_CHAR)

	# Print filenames.
	if (slist == YES || llist == YES) {
	    call printf ("%s")
		call pargstr (in_fname)
	    if (out_fname[1] != EOS) {
		call printf ("  ->  %s")
		    call pargstr (out_fname)
	    }
	    call printf (":")
	    call flush (STDOUT)
	}

	# Setup the input.  The output file is setup after checking the
	# first record of the input file.

	if (intape == NO) {
	    nchars = fnroot (in_fname, FILENAME(hdr), 80)
	    in = open (in_fname, READ_ONLY, BINARY_FILE)
	} else {
	    FILENAME(hdr) = EOS
	    in = mtopen (in_fname, READ_ONLY, 0)
	}
	out = NULL

	sz_charsin = 1440
	szb_inrecord = sz_charsin * SZB_CHAR
	rem_in = szb_inrecord
	call salloc (inbuf, sz_charsin, TY_CHAR)

	err = NO
	iferr {
	    # Loop over the input blocks.
	    ip = 1
	    op = 1
	    offset = 1
	    recnum = 0
	    repeat {
		# Read a block and update block counter.
		nchars = read (in, Memc[inbuf], sz_charsin)
		if (nchars == EOF)
		    break
		bytes_read = nchars * SZB_CHAR
		if (mod (fstati (in, F_SZBBLK), SZB_CHAR) != 0)
		    bytes_read = bytes_read - mod (fstati (in, F_SZBBLK),
			SZB_CHAR)

		iferr (call fits_hdr (Memc[inbuf], hdr, recnum, hdrrec,
		    list, slist, llist, outtape)) {
		    call close (in)
		    call sfree (sp)
		    call erract (EA_FATAL)
		}

		if (list == YES && slist == YES) {
		    if (hdrrec == NO)
			break
		    else
			next
		}

		if (out == NULL) {
		    if (outtape == NO) {
			if (out_fname[1] == EOS)
			    next
			tmp = open (out_fname, NEW_FILE, BINARY_FILE)
			out = tmp
			szb_outblock = fstati (out, F_BUFSIZE) * SZB_CHAR
		    } else {
			tmp = mtopen (out_fname, WRITE_ONLY, 0)
			out = tmp
			szb_outblock = blocking * 2880
		    }
		    szb_outrecord = szb_outblock
		    rem_out = szb_outrecord

		    if (mod (szb_outblock, SZB_CHAR) == 0)
			sz_charsout = szb_outblock / SZB_CHAR
		    else
			sz_charsout = (szb_outblock / SZB_CHAR + 1) * SZB_CHAR
		    if (sz_charsout != sz_charsin)
			call salloc (outbuf, sz_charsout, TY_CHAR)
		    else
			outbuf = inbuf
		}

		if (outbuf == inbuf) {
		    call awriteb (out, Memc[inbuf], bytes_read, offset)
		    bytes_write = awaitb (out)
		    if (bytes_write == ERR) {
			call sprintf (Memc[errmsg], SZ_LINE,
			    "Write failed (%s -> %s)")
			    call pargstr (in_fname)
			    call pargstr (out_fname)
			call error (1, Memc[errmsg])
		    }
		    offset = offset + bytes_write
		} else {
		    repeat {
			# Calculate the number of bytes to be moved.
			mov_nbytes = min (bytes_read - ip + 1,
			    rem_in, rem_out, szb_outblock - op + 1)
			call bytmov (Memc[inbuf], ip, Memc[outbuf], op,
			    mov_nbytes)

			# Update the remainders
			rem_in = rem_in - mov_nbytes
			if (rem_in == 0)
			    rem_in = szb_inrecord
			rem_out = rem_out - mov_nbytes
			if (rem_out == 0)
			    rem_out = szb_outrecord

			# Update pointers
			ip = ip + mov_nbytes
			op = op + mov_nbytes

			# If output buffer is exhausted, output block of data.
			if (op > szb_outblock) {
			    call awriteb (out, Memc[outbuf], szb_outblock,
				offset)
			    bytes_write = awaitb (out)
			    if (bytes_write == ERR) {
				call sprintf (Memc[errmsg], SZ_LINE,
				    "Write failed:  %s -> %s")
				    call pargstr (in_fname)
				    call pargstr (out_fname)
				call error (1, Memc[errmsg])
			    }
			    offset = offset + bytes_write
			    op = 1
			}
		    } until (ip > bytes_read)

		    ip = 1
		}
	    }

	    # Output remainder of data
	    if (op > 1) {
		call awriteb (out, Memc[outbuf], op - 1, offset)
		if (awaitb (out) == ERR) {
		    call sprintf (Memc[errmsg], SZ_LINE,
			"Write failed:  %s -> %s")
			call pargstr (in_fname)
			call pargstr (out_fname)
		    call error (1, Memc[errmsg])
		}
	    }
	} then
	    err = YES

	call close (in)
	if (out != NULL) {
	    call close (out)
	    if (outtape == NO && original == YES &&
		strne (out_fname, FILENAME(hdr))) {
		if (FILENAME(hdr) != EOS) {
		    call salloc (fname, SZ_FNAME, TY_CHAR)
		    call sprintf (Memc[fname], SZ_FNAME, "%s$")
			call pargstr (extn)
		    if (strmatch (FILENAME(hdr), Memc[fname]) == 0) {
			call sprintf (Memc[fname], SZ_FNAME, "%s%s")
			    call pargstr (FILENAME(hdr))
			    call pargstr (extn)
		    } else
			call strcpy (FILENAME(hdr), Memc[fname], SZ_FNAME)
		    if (slist == YES || llist == YES) {
			call printf ("  Rename %s -> %s\n")
			    call pargstr (out_fname)
			    call pargstr (Memc[fname])
		    }
		    iferr (call rename (out_fname, Memc[fname]))
			call erract (EA_WARN)
		} else
		    call printf ("  Original filename not found\n")
	    }
	}
	call sfree (sp)

	if (err == YES)
	    call erract (EA_ERROR)
	else if (recnum == 0)
	    return (EOF)
	else
	    return (OK)
end


# FITS_HDR -- FITS header record.

procedure fits_hdr (inrec, hdr, recnum, hdrrec, list, slist, llist, filename)

char	inrec[ARB]	#I Input FITS record
pointer hdr		#O Header structure
int	recnum		#U Record number
int	hdrrec		#O Header record?
int	list		#I List only?
int	slist		#I Short list?
int	llist		#I Long list?
int	filename	#I Update file name?

int     i, j, strncmp()
bool	strne()
char    line[81]

begin
	recnum = recnum + 1
	if (recnum == 1)
	    hdrrec = NO
	line[81] = '\n'
	for (i=1; i<=1440; i=i+40) {
	    call achtbc(inrec[i], line, 80)
	    if (hdrrec == NO) {
		if (recnum == 1) {
		    if (strncmp (line, "SIMPLE", 6) != 0) {
			if (list == NO)
			    call error (1, "Not a FITS file - file not written")
			else
			    call error (1, "Not a FITS file")
		    }
		    call strcpy ("PRIMARY", XTENSION(hdr), 80)
		    GROUP(hdr) = 0
		    NEXTEND(hdr) = INDEFI
		} else {
		    if (strncmp (line, "XTENSION", 8) != 0)
			return
		    call fits_gstr (line, XTENSION(hdr), 80)
		    GROUP(hdr) = GROUP(hdr) + 1
		}
		NAXIS(hdr,0) = 0
		BITPIX(hdr,0) = 0
		EXTNAME(hdr) = EOS
		EXTVER(hdr) = EOS
		OBJECT(hdr) = EOS
		hdrrec = YES
		next
	    }

	    if (strncmp (line, "END", 3) == 0) {
		if (slist == YES || llist == YES) {
		    if (GROUP(hdr) == 0) {
			if (FILENAME(hdr) != EOF) {
			    call printf ("  %-20s")
				call pargstr (FILENAME(hdr))
			}
			if (!IS_INDEFI(NEXTEND(hdr))) {
			    call printf (" nextend=%d")
				call pargi (NEXTEND(hdr))
			}
			call printf ("  %s\n")
			    call pargstr (OBJECT(hdr))
		    }
		    if (llist == YES) {
			call printf ("  %2d %7s %3s %s")
			    call pargi (GROUP(hdr))
			    call pargstr (XTENSION(hdr))
			    call pargstr (EXTNAME(hdr))
			    call pargstr (EXTVER(hdr))
			if (NAXIS(hdr,0) > 0) {
			    call printf (" %2d %d")
				call pargi (BITPIX(hdr))
				call pargi (NAXIS(hdr,1))
			    do j = 2, NAXIS(hdr,0) {
				call printf ("x%d")
				    call pargi (NAXIS(hdr,j))
			    }
			}
			call printf ("\n")
		    }
		}
		hdrrec = NO
		return
	    }

	    if (strncmp (line, "NAXIS", 5) == 0) {
		if (line[6] == ' ')
		    call fits_geti (line, NAXIS(hdr,0))
		else if (IS_DIGIT(line[6]))
		    call fits_geti (line, NAXIS(hdr,TO_INTEG(line[6])))
	    } else if (strncmp (line, "BITPIX", 6) == 0) {
		call fits_geti (line, BITPIX(hdr))
	    } else if (strncmp (line, "NEXTEND", 7) == 0) {
		call fits_geti (line, NEXTEND(hdr))
	    } else if (strncmp (line, "EXTNAME", 7) == 0) {
		call fits_gstr (line, EXTNAME(hdr), 80)
	    } else if (strncmp (line, "EXTVER", 6) == 0) {
		call fits_gstr (line, EXTVER(hdr), 80)
	    } else if (strncmp (line, "OBJECT", 6) == 0) {
		call fits_gstr (line, OBJECT(hdr), 80)
	    } else if (strncmp (line, "FILENAME", 8) == 0) {
		call fits_gstr (line, TEMP(hdr), 80)
		if (FILENAME(hdr) == EOS)
		    call strcpy (TEMP(hdr), FILENAME(hdr), 80)
		if (strne (TEMP(hdr), FILENAME(hdr)) || line[80] == '\n') {
		    call sprintf (line[11], 71, "'%8s'%71t\n")
			call pargstr (FILENAME(hdr))
		    call achtcb (line, inrec[i], 80)
		}
	    } else if (strncmp (line, "IRAFNAME", 8) == 0) {
		call fits_gstr (line, TEMP(hdr), 80)
		if (FILENAME(hdr) == EOS)
		    call strcpy (TEMP(hdr), FILENAME(hdr), 80)
		if (strne (TEMP(hdr), FILENAME(hdr)) || line[80] == '\n') {
		    call sprintf (line[11], 71, "'%8s'%71t\n")
			call pargstr (FILENAME(hdr))
		    call achtcb (line, inrec[i], 80)
		}
	    }
	}
	hdrrec = YES
end


# FITS_GETS -- Get the string value of a FITS encoded card.  Strip leading
# and trailing whitespace and any quotes.

procedure fits_gstr (card, outstr, maxch)

char	card[ARB]		#I FITS card to be decoded
char	outstr[ARB]		#O output string to receive parameter value
int	maxch			#I length of outstr

int	ip, op
int	ctowrd(), strlen()

begin
	ip = 10
	if (ctowrd (card, ip, outstr, maxch) > 0) {
	    # Strip trailing whitespace.
	    op = strlen (outstr)
	    while (op > 0 && (IS_WHITE(outstr[op]) || outstr[op] == '\n'))
		op = op - 1
	    outstr[op+1] = EOS
	} else
	    outstr[1] = EOS
end

# FITS_GETI -- Return the integer value of a FITS encoded card.

procedure fits_geti (card, ival)

char	card[ARB]		#I card to be decoded
int	ival			#O receives integer value

int	ip, ctoi()
char	sval[68]

begin
	call fits_gstr (card, sval, 68)
	ip = 1
	if (ctoi (sval, ip, ival) <= 0)
	    ival = 0
end
mscred-5.05-2018.07.09/src/t_getcatalog.x000066400000000000000000000316221332166314300174070ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

include 
include 
include	
include	
include	

# List of catalogs recognized by this task.
define	CATALOGS	"|NOAO:USNO-A2|CADC:USNO-A2|"
define	NOAOUSNO	1		# NOAO:USNO-A2
define	CADCUSNO	2		# CADC:USNO-A2

define  SZ_BUF          32768
define	NMAGS		5		# Maximum number of magnitudes

# T_GETCATALOG -- Given a list of images or a position and radius return an
# output text file with the results of the query.  If possible the output
# should have RA, DEC, and a magnitude for the objects in the first three
# columns.  Other information may be included.  It is up to the user of the
# output to know about the fields.  Currently the task should return
# J2000 coordinates and internally precess them if necessary.
# 
# If a list of images is given then the WCS defines the position and radius.
# The position is the midpoint of the extremes of the corners of the images
# in the list.  The radius is the minimum radius from the midpoint that
# includes all the corners of all the images.  The "rmin" parameter can be
# used to force a bigger radius. The feature to use a list of images with
# common tangent point, as opposed to a single image, is appropriate for a
# list of extensions from a mosaic.

procedure t_getcatalog ()

int	images		#I List of images with WCS
double	rafield		#I RA of field (hours)
double	decfield	#I DEC of field (degrees)
double	radius		#I Field radius (arcmin)
double	magmin		#I Minimum magnitude
double	magmax		#I Minimum magnitude
pointer	catalog		#I Catalog
pointer	output		#I Output file
double	rmin		#I Minimum radius

int	i, j, out, nobjs, catid
double	r, ratan, dectan, x, y, xmin, xmax, ymin, ymax
pointer	sp, image
pointer	im, mw, wcs, ct
pointer	ra, dec, mags[NMAGS]

int	strdic(), open()
int	imtopenp(), imtlen(), imtgetim()
pointer	immap(), msc_openim, msc_sctran()
double	clgetd(), slDSEP()
errchk	immap, msc_openim, open, mscagetcat, noaousno, cadcusno

begin
	call smark (sp)
	call salloc (catalog, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)
	call salloc (image, SZ_FNAME, TY_CHAR)

	# Get parameters.
	images = imtopenp ("images")
	if (imtlen (images) == 0) {
	    rafield = clgetd ("ra")
	    decfield = clgetd ("dec")
	    radius = clgetd ("radius")
	}
	magmin = clgetd ("magmin")
	magmax = clgetd ("magmax")
	call clgstr ("catalog", Memc[catalog], SZ_FNAME)
	call clgstr ("output", Memc[output], SZ_FNAME)
	rmin = clgetd ("rmin")

	# Get region if images are given.
	# Multiple images must have the same tangent point.
	if (imtlen (images) > 0) {
	    ratan = INDEFD; dectan = INDEFD
	    xmin = MAX_DOUBLE; xmax=-MAX_DOUBLE
	    ymin = MAX_DOUBLE; ymax=-MAX_DOUBLE
	    while (imtgetim (images, Memc[image], SZ_FNAME) != EOF) {
		im = immap (Memc[image], READ_ONLY, 0)
		mw = msc_openim (im, wcs)

		ct = msc_sctran (wcs, 2, "astrometry", "world", 3)
		call msc_c2trand (wcs, 2, 0D0, 0D0, x, y)
		if (IS_INDEFD(ratan)) {
		    ratan = x
		    dectan = y
		} else {
		    r = sqrt ((x-ratan)**2+(y-dectan)**2)
		    r = r / 3600.
		    if (r > 1)
			call error (1,
			    "Images don't have the same tangent point")
		}

		ct = msc_sctran (wcs, 1, "logical", "astrometry", 3)
		call msc_c2trand (wcs, 1, 1D0, 1D0, x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)
		call msc_c2trand (wcs, 1, double(IM_LEN(im,1)), 1D0, x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)
		call msc_c2trand (wcs, 1, double(IM_LEN(im,1)),
		    double(IM_LEN(im,2)), x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)
		call msc_c2trand (wcs, 1, 1D0, double(IM_LEN(im,2)), x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)

		x = (xmax + xmin) / 2
		y = (ymax + ymin) / 2
		call msc_c2trand (wcs, 2, x, y, rafield, decfield)
		radius = 0
		r = sqrt ((xmin-x)**2+(ymin-y)**2)
		radius = max (radius, r)
		r = sqrt ((xmax-x)**2+(ymin-y)**2)
		radius = max (radius, r)
		r = sqrt ((xmin-x)**2+(ymax-y)**2)
		radius = max (radius, r)
		r = sqrt ((xmax-x)**2+(ymax-y)**2)
		radius = max (radius, r)

		call msc_close (wcs)
		call imunmap (im)
	    }
	    rafield = rafield / 15.
	    radius = radius / 60.
	    radius = max (rmin, radius)
	    call clputd ("ra", rafield)
	    call clputd ("dec", decfield)
	    call clputd ("radius", radius)
	}
	
	# Get catalog data and format the output.  This is catalog dependent.
	# Each entry in the switch has some knowledge of how to query the
	# catalog and what it returns.  In future there may be epoch
	# parameters to the task to allow precession of coordinates from
	# whatever the catalog returns.  Currently the routines should
	# return J2000 coordinates.

	call aclri (mags, NMAGS)
	catid = strdic (Memc[catalog], Memc[catalog], SZ_FNAME, CATALOGS)
	switch (catid) {
	case NOAOUSNO:
	    call noaousno (rafield, decfield, radius, ra, dec,
		mags, nobjs)
	case CADCUSNO:
	    call cadcusno (rafield, decfield, radius, ra, dec,
		mags, nobjs)
	default:
	    call mscagetcat (Memc[catalog], rafield, decfield, radius,
		ra, dec, mags, nobjs)
	}

	rafield = DEGTORAD (15D0 * rafield)
	decfield = DEGTORAD (decfield)
	radius = DEGTORAD (radius / 60D0)

	out = open (Memc[output], NEW_FILE, TEXT_FILE)
	do i = 0, nobjs-1 {
	    if (Memd[mags[1]+i] < magmin || Memd[mags[1]+i] > magmax)
		next
	    x = DEGTORAD (15D0 * Memd[ra+i])
	    y = DEGTORAD (Memd[dec+i])
	    r = slDSEP (rafield, decfield, x, y)
	    if (r > radius)
		next
	    call fprintf (out, "%13.3h %13.2h")
		call pargd (Memd[ra+i])
		call pargd (Memd[dec+i])
	    do j = 1, NMAGS {
		if (mags[j] == NULL)
		    break
		call fprintf (out, " %6.3f")
		    call pargd (Memd[mags[j]+i])
	    }
	    call fprintf (out, "\n")
	}

	call close (out)
	call mfree (ra, TY_DOUBLE)
	call mfree (dec, TY_DOUBLE)
	do j = 1, NMAGS
	    call mfree (mags[j], TY_DOUBLE)

	# Finish up.
	call sfree (sp)
end


# MSCAGETCAT -- Get catalog through the ASTCAT package.

procedure mscagetcat (catalog, rafield, decfield, radius, ra, dec,
	mags, nobjs)

char	catalog[ARB]		#I Catalog name
double	rafield			#I Field RA (hours)
double	decfield		#I Field DEC (degrees)
double	radius			#I Field radius (arc min)
pointer	ra			#O Double pointer to RA (hours)
pointer	dec			#O Double pointer to DEC (degrees)
pointer	mags[NMAGS]		#O Double pointers to magnitudes
int	nobjs			#O Number of objects returned

int     i, nmags, fd
double	raval, decval, magval[NMAGS]
pointer sp, temp, cmd
int     access(), open(), fscan(), nscan()
errchk	open, delete, malloc, realloc

begin
	call smark (sp)
	call salloc (temp, SZ_FNAME, TY_CHAR)
	call salloc (cmd, 2*SZ_LINE, TY_CHAR)

	# Get catalog data into a temporary file.
	call mktemp ("temp", Memc[temp], SZ_FNAME)
	call sprintf (Memc[cmd], SZ_LINE, "mscagetcat %s %s %g %g %g %g")
	    call pargstr (Memc[temp])
	    call pargstr (catalog)
	    call pargd (rafield)
	    call pargd (decfield)
	    call pargd (2*radius)
	    call pargd (2*radius)
	call clcmdw (Memc[cmd])
	if (access (Memc[temp], 0, 0) == NO) {
	    call sprintf (Memc[cmd], SZ_LINE, "Catalog not found (%s)")
		call pargstr (catalog)
	    call error (1, Memc[cmd])
	}

	# Read the catalog fields.
	fd = open (Memc[temp], READ_ONLY, TEXT_FILE)
	nobjs = 0; nmags = 0
	while (fscan (fd) != EOF) {
	    call gargd (raval)
	    call gargd (decval)
	    do i = 1, NMAGS
		call gargd (magval[i])
	    i = nscan()
	    if (nmags == 0)
	        nmags = i - 2
	    if (i < 2 + nmags)
		next

	    if (nobjs == 0) {
		call malloc (ra, 100, TY_DOUBLE)
		call malloc (dec, 100, TY_DOUBLE)
		do i = 1, nmags
		    call malloc (mags[i], 100, TY_DOUBLE)
	    } else if (mod (nobjs, 100) == 0) {
		call realloc (ra, nobjs+100, TY_DOUBLE)
		call realloc (dec, nobjs+100, TY_DOUBLE)
		do i = 1, nmags
		    call realloc (mags[i], nobjs+100, TY_DOUBLE)
	    }

	    Memd[ra+nobjs] = raval
	    Memd[dec+nobjs] = decval
	    do i = 1, nmags
		Memd[mags[i]+nobjs] = magval[i]
	    nobjs = nobjs + 1
        }
        call close (fd)
	call delete (Memc[temp])

	call sfree (sp)
end


# NOAOUSNO -- USNO-A2 catalog from NOAO server.

procedure noaousno (rafield, decfield, radius, ra, dec, mags, nobjs)

double	rafield			#I Field RA (hours)
double	decfield		#I Field DEC (degrees)
double	radius			#I Field radius (arc min)
pointer	ra			#O Double pointer to RA (hours)
pointer	dec			#O Double pointer to DEC (degrees)
pointer	mags[NMAGS]		#O Double pointer to magnitudes

int     i, fd, nchars, nobjs
double	raval, decval, mag1val, mag2val
pointer sp, url, buf
int     ndopen(), read(), stropen(), fscan(), nscan()
errchk	ndopen, malloc, realloc

begin
	call smark (sp)
	call salloc (url, SZ_LINE, TY_CHAR)

	# Initialize.
	ra = NULL
	dec = NULL
	mags[1] = NULL
	mags[2] = NULL
	nobjs = 0

        # Connect to HTTP server and return on error.
        fd = ndopen ("inet:80:www.noao.edu:text", READ_WRITE)

        # Send the get-url request to the server.
        call sprintf (Memc[url], SZ_BUF,
	    "/cgi-bin/usno/usnoextract?search=yes&ra=%0h&dec=%h&width=%0.1f")
            call pargd (rafield)
            call pargd (decfield)
            call pargd (radius)
        call fprintf (fd, "GET %s HTTP/1.0\n\n")
            call pargstr (Memc[url])
        call flush (fd)

	# Read the returned text into a string buffer.
	nchars = 0
	repeat {
	    if (nchars == 0)
		call malloc (buf, SZ_BUF, TY_CHAR)
	    else
		call realloc (buf, nchars+SZ_BUF, TY_CHAR)
            call fseti (fd, F_CANCEL, OK)
            i = read (fd, Memc[buf+nchars], SZ_BUF)
            if (i <= 0)
		break
	    nchars = nchars + i
	}
	Memc[buf+nchars] = EOS
        call close (fd)

	# Parse the text.
	fd = stropen (Memc[buf], nchars, READ_ONLY)
	while (fscan (fd) != EOF) {
	    call gargd (raval)
	    call gargd (decval)
	    call gargd (mag1val)
	    call gargd (mag2val)
	    if (nscan() != 4)
		next

	    if (nobjs == 0) {
		call malloc (ra, 100, TY_DOUBLE)
		call malloc (dec, 100, TY_DOUBLE)
		call malloc (mags[1], 100, TY_DOUBLE)
		call malloc (mags[2], 100, TY_DOUBLE)
	    } else if (mod (nobjs, 100) == 0) {
		call realloc (ra, nobjs+100, TY_DOUBLE)
		call realloc (dec, nobjs+100, TY_DOUBLE)
		call realloc (mags[1], nobjs+100, TY_DOUBLE)
		call realloc (mags[2], nobjs+100, TY_DOUBLE)
	    }

	    Memd[ra+nobjs] = raval
	    Memd[dec+nobjs] = decval
	    Memd[mags[1]+nobjs] = mag1val
	    Memd[mags[2]+nobjs] = mag2val
	    nobjs = nobjs + 1
        }

        call close (fd)
	call mfree (buf, TY_CHAR)
	call sfree (sp)
end


# CADCUSNO -- USNO-A2 catalog from CADC server.

procedure cadcusno (rafield, decfield, radius, ra, dec, mags, nobjs)

double	rafield			#I Field RA (hours)
double	decfield		#I Field DEC (degrees)
double	radius			#I Field radius (arc min)
pointer	ra			#O Double pointer to RA (hours)
pointer	dec			#O Double pointer to DEC (degrees)
pointer	mags[NMAGS]		#O Double pointer to magnitudes

int     i, fd, nchars, nobjs
double	raval, decval, mag1val, mag2val
pointer sp, url, id, buf
int     ndopen(), read(), stropen(), fscan(), nscan()
errchk	ndopen, malloc, realloc

begin
	call smark (sp)
	call salloc (url, SZ_LINE, TY_CHAR)
	call salloc (id, SZ_LINE, TY_CHAR)

	# Initialize.
	ra = NULL
	dec = NULL
	mags[1] = NULL
	mags[2] = NULL
	nobjs = 0

        # Connect to HTTP server and return on error.
        fd = ndopen ("inet:80:cadcwww.dao.nrc.ca:text", READ_WRITE)

        # Send the get-url request to the server.
        call sprintf (Memc[url], SZ_BUF,
"/cadcbin/getusno2?ra=%0h&dec=%h&radius=%0.1f&m=0,21&sort_select=Alpha&epoch_in=2000.0&nout=1000000")
            call pargd (rafield)
            call pargd (decfield)
            call pargd (radius)
        call fprintf (fd, "GET %s HTTP/1.0\n\n")
            call pargstr (Memc[url])
        call flush (fd)

	# Read the returned text into a string buffer.
	nchars = 0
	repeat {
	    if (nchars == 0)
		call malloc (buf, SZ_BUF, TY_CHAR)
	    else
		call realloc (buf, nchars+SZ_BUF, TY_CHAR)
            call fseti (fd, F_CANCEL, OK)
            i = read (fd, Memc[buf+nchars], SZ_BUF)
            if (i <= 0)
		break
	    nchars = nchars + i
	}
	Memc[buf+nchars] = EOS
        call close (fd)

	# Parse the text.
	fd = stropen (Memc[buf], nchars, READ_ONLY)
	while (fscan (fd) != EOF) {
	    call gargwrd (Memc[id], SZ_LINE)
	    call gargd (raval)
	    call gargd (decval)
	    call gargd (mag1val)
	    call gargd (mag2val)
	    if (nscan() != 5)
		next

	    if (nobjs == 0) {
		call malloc (ra, 100, TY_DOUBLE)
		call malloc (dec, 100, TY_DOUBLE)
		call malloc (mags[1], 100, TY_DOUBLE)
		call malloc (mags[2], 100, TY_DOUBLE)
	    } else if (mod (nobjs, 100) == 0) {
		call realloc (ra, nobjs+100, TY_DOUBLE)
		call realloc (dec, nobjs+100, TY_DOUBLE)
		call realloc (mags[1], nobjs+100, TY_DOUBLE)
		call realloc (mags[2], nobjs+100, TY_DOUBLE)
	    }

	    Memd[ra+nobjs] = raval / 15.
	    Memd[dec+nobjs] = decval
	    Memd[mags[1]+nobjs] = mag2val
	    Memd[mags[2]+nobjs] = mag1val
	    nobjs = nobjs + 1
        }

        call close (fd)
	call mfree (buf, TY_CHAR)
	call sfree (sp)
end
mscred-5.05-2018.07.09/src/t_imext.x000066400000000000000000000052331332166314300164220ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

define	OUTPUTS		"|none|list|file|"
define	NONE		1		# No output
define	LIST		2		# List output
define	FILE		3		# File output

define	SZ_LISTOUT	255		# Size of output list


# T_IMEXTENSIONS -- Expand a template of FITS files into a list of image
# extensions on the standard output and record the number image extensions
# in a parameter.

procedure t_imextensions()

pointer	input			# List of ME file names
int	output			# Output list (none|list|file)
pointer	index			# Range list of extension indexes
pointer	extname			# Patterns for extension names
pointer extver			# Range list of extension versions
int	lindex			# List index number?
int	lname			# List extension name?
int	lver			# List extension version?
pointer	ikparams		# Image kernel parameters

pointer	sp, image, listout
int	list, nimages, fd
int	clgwrd(), btoi(), imextensions(), stropen()
int	imtgetim(), imtlen()
bool	clgetb()
errchk	stropen, fprintf, strclose

begin
	call smark (sp)
	call salloc (input, SZ_LINE, TY_CHAR)
	call salloc (index, SZ_LINE, TY_CHAR)
	call salloc (extname, SZ_LINE, TY_CHAR)
	call salloc (extver, SZ_LINE, TY_CHAR)
	call salloc (ikparams, SZ_LINE, TY_CHAR)
	call salloc (image, SZ_FNAME, TY_CHAR)

	# Task parameters
	call clgstr ("input", Memc[input], SZ_LINE)
	output = clgwrd ("output", Memc[image], SZ_FNAME, OUTPUTS)
	call clgstr ("index", Memc[index], SZ_LINE)
	call clgstr ("extname", Memc[extname], SZ_LINE)
	call clgstr ("extver", Memc[extver], SZ_LINE)
	lindex = btoi (clgetb ("lindex"))
	lname = btoi (clgetb ("lname"))
	lver = btoi (clgetb ("lver"))
	call clgstr ("ikparams", Memc[ikparams], SZ_LINE)

	# Get the list.
	list = imextensions (Memc[input], Memc[index], Memc[extname],
	    Memc[extver], lindex, lname, lver, Memc[ikparams], YES)

	# Format the output and set the number of images.
	switch (output) {
	case LIST:
	    call salloc (listout, SZ_LISTOUT, TY_CHAR)
	    iferr {
		fd = stropen (Memc[listout], SZ_LISTOUT, WRITE_ONLY)
		nimages = 0
		while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) {
		    nimages = nimages + 1
		    if (nimages == 1) {
			call fprintf (fd, "%s")
			    call pargstr (Memc[image])
		    } else {
			call fprintf (fd, ",%s")
			    call pargstr (Memc[image])
		    }
		}
		call strclose (fd)
		call printf ("%s\n")
		    call pargstr (Memc[listout])
	    } then {
		call imtclose (list)
		call sfree (sp)
		call error (1, "Output list format is too long")
	    }
	case FILE:
	    while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) {
		call printf ("%s\n")
		    call pargstr (Memc[image])
	    }
	}
	call clputi ("nimages", imtlen (list))

	call imtclose (list)
	call sfree (sp)
end
mscred-5.05-2018.07.09/src/t_imstat.x000066400000000000000000000621231332166314300165760ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

include	
include	
include "imstat.h"


# T_IMSTATISTICS -- Compute and print the statistics of images.

procedure t_imstatistics ()

pointer	fieldstr			# Pointer to fields string
pointer	mask				# Mask
real	lower				# Lower limit of data value window
real	upper				# Upper limit of data value window
real	lclip				# Lower clipping factor
real	uclip				# Upper clipping factor
int	nclip				# Number of clipping iterations
real	binwidth			# Width of histogram bin in sigma
int	format				# Format the output

int	i, n, nfields, nbins, npixused
int	minmax, npix, mean, median, mode, stddev, skew, kurtosis
pointer	sp, mname, fields, image, v
pointer	im, pm, list, ist, buf, hgm
real	low, up, hwidth, hmin, hmax

bool	clgetb()
int	ist_fields(), ist_isfield, imtgetim(), ist_ihist(), btoi()
int	clgeti(), ist_gdata()
pointer	imtopenp()
real	clgetr()
pointer	immap(), yt_pmmap()

begin
	call smark (sp)
	call salloc (fieldstr, SZ_LINE, TY_CHAR)
	call salloc (mask, SZ_FNAME, TY_CHAR)
	call salloc (mname, SZ_FNAME, TY_CHAR)
	call salloc (fields, NFIELDS, TY_INT)
	call salloc (ist, LEN_IMSTAT, TY_STRUCT)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (v, IM_MAXDIM, TY_LONG)

	# Open the list of input images, mask, fields and the data value limits.
	list = imtopenp ("images")
	call clgstr ("mask", Memc[mask], SZ_FNAME)
	call clgstr ("fields", Memc[fieldstr], SZ_LINE)
	lower = clgetr ("lower")
	upper = clgetr ("upper")
	lclip = clgetr ("lclip")
	uclip = clgetr ("uclip")
	nclip = clgeti ("nclip")
	binwidth = clgetr ("binwidth")
	format = btoi (clgetb ("format"))

	if (nclip > 0 && lclip <= 0. && uclip <= 0.)
	    nclip = 0

	# Get the selected fields.
	nfields = ist_fields (Memc[fieldstr], Memi[fields], NFIELDS)
	if (nfields <= 0) {
	    call imtclose (list)
	    call sfree (sp)
	    return
	}

	# Set the computation switches.
	npix = ist_isfield (IS_FNPIX, Memi[fields], nfields)
	mean = ist_isfield (IS_FMEAN, Memi[fields], nfields)
	median = ist_isfield (IS_FMEDIAN, Memi[fields], nfields)
	mode = ist_isfield (IS_FMODE, Memi[fields], nfields)
	stddev = ist_isfield (IS_FSTDDEV, Memi[fields], nfields)
	skew = ist_isfield (IS_FSKEW, Memi[fields], nfields)
	kurtosis = ist_isfield (IS_FKURTOSIS, Memi[fields], nfields)
	if (ist_isfield (IS_FMIN, Memi[fields], nfields) == YES)
	    minmax = YES
	else if (ist_isfield (IS_FMAX, Memi[fields], nfields) == YES)
	    minmax = YES
	else if (median == YES || mode == YES)
	    minmax = YES
	else
	    minmax = NO
	if (nclip > 0)
	    stddev = YES

	# Print a header banner for the selected fields.
	if (format == YES)
	    call ist_pheader (Memi[fields], nfields)

	# Loop through the input images.
	while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) {

	    # Open image and mask.  If mask pointer is null then all
	    # pixels are used.

	    im = immap (Memc[image], READ_ONLY, 0)
	    pm = yt_pmmap (Memc[mask], im, Memc[mname], SZ_FNAME)

	    # Accumulate the central moment statistics.
	    low = lower
	    up = upper
	    do i = 0, nclip {
		call amovkl (long(1), Meml[v], IM_NDIM(im))

		call ist_initialize (ist, low, up)
		if (kurtosis == YES) {
		    while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
			call ist_accumulate4 (ist, Memr[buf], n, low, up,
			    minmax)
		} else if (skew == YES) {
		    while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
			call ist_accumulate3 (ist, Memr[buf], n,
			    low, up, minmax)
		} else if (stddev == YES || median == YES || mode == YES) {
		    while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
			call ist_accumulate2 (ist, Memr[buf], n,
			    low, up, minmax)
		} else if (mean == YES) {
		    while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
			call ist_accumulate1 (ist, Memr[buf], n,
			    low, up, minmax)
		} else if (npix == YES) {
		    while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
			call ist_accumulate0 (ist, Memr[buf], n,
			    low, up, minmax)
		} else if (minmax == YES) {
		    while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
			call ist_accumulate0 (ist, Memr[buf], n,
			    low, up, YES)
		}

		# Compute the central moment statistics.
		call ist_stats (ist, skew, kurtosis)

		# Set clipping.
		if (i < nclip) {
		    if (lclip > 0.)
			low = IS_MEAN(ist) - lclip * IS_STDDEV(ist)
		    if (uclip > 0.)
			up =  IS_MEAN(ist) + uclip * IS_STDDEV(ist)
		    if (i > 0 && IS_NPIX(ist) == npixused)
			break
		    npixused = IS_NPIX(ist)
		}
	    }

	    # Accumulate the histogram.
	    hgm = NULL
	    if ((median == YES || mode == YES) && ist_ihist (ist, binwidth,
	        hgm, nbins, hwidth, hmin, hmax) == YES) {
		call aclri (Memi[hgm], nbins)
		call amovkl (long(1), Meml[v], IM_NDIM(im))
		while (ist_gdata (im, pm, Meml[v], buf, n) != EOF)
		    call ahgmr (Memr[buf], n, Memi[hgm], nbins, hmin, hmax)
		if (median == YES)
		    call ist_hmedian (ist, Memi[hgm], nbins, hwidth, hmin,
			hmax)
		if (mode == YES)
		    call ist_hmode (ist, Memi[hgm], nbins, hwidth, hmin, hmax)
	    }

	    # Print the statistics.
	    if (format == YES)
	        call ist_print (Memc[image], ist, Memi[fields], nfields)
	    else
	        call ist_fprint (Memc[image], ist, Memi[fields], nfields)
		
	    if (hgm != NULL)
		call mfree (hgm, TY_INT)
	    if (pm != NULL)
		call imunmap (pm)
	    call imunmap (im)
	}

	call imtclose (list)
	call sfree (sp)
end


# IST_FIELDS -- Procedure to decode the fields string into a list of the
# fields to be computed and printed.

int procedure ist_fields (fieldstr, fields, max_nfields)

char	fieldstr[ARB]		# string containing the list of fields
int	fields[ARB]		# fields array
int	max_nfields		# maximum number of fields

int	nfields, flist, field
pointer	sp, fname
int	fntopenb(), fntgfnb(), strdic()

begin
	nfields = 0

	call smark (sp)
	call salloc (fname, SZ_FNAME, TY_CHAR)

	flist = fntopenb (fieldstr, NO)
	while (fntgfnb (flist, Memc[fname], SZ_FNAME) != EOF && 
	    (nfields < max_nfields)) {
	    field = strdic (Memc[fname], Memc[fname], SZ_FNAME, IS_FIELDS)
	    if (field == 0)
		next
	    nfields = nfields + 1
	    fields[nfields] = field
	}
	call fntclsb (flist)

	call sfree (sp)

	return (nfields)
end


# IST_ISFIELD -- Procedure to determine whether a specified field is one
# of the selected fields or not.

int procedure ist_isfield (field, fields, nfields)

int	field		# field to be tested
int	fields[ARB]	# array of selected fields
int	nfields		# number of fields

int	i, isfield

begin
	isfield = NO
	do i = 1, nfields {
	    if (field != fields[i])
		next
	    isfield = YES
	    break
	}

	return (isfield)
end


# IST_INITIALIZE -- Initialize the sum array to zero.

procedure ist_initialize (ist, lower, upper)

pointer	ist		# pointer to the statistics structure
real	lower		# lower datalimit
real	upper		# upperlimit

begin
	if (IS_INDEFR(lower))
	    IS_LO(ist) = -MAX_REAL
	else
	    IS_LO(ist) = lower
	if (IS_INDEFR(upper))
	    IS_HI(ist) = MAX_REAL
	else
	    IS_HI(ist) = upper

	IS_NPIX(ist) = 0
	IS_SUMX(ist) = 0.0d0
	IS_SUMX2(ist) = 0.0d0
	IS_SUMX3(ist) = 0.0d0
	IS_SUMX4(ist) = 0.0d0

	IS_MIN(ist) = MAX_REAL
	IS_MAX(ist) = -MAX_REAL
	IS_MEAN(ist) = INDEFR
	IS_MEDIAN(ist) = INDEFR
	IS_MODE(ist) = INDEFR
	IS_STDDEV(ist) = INDEFR
	IS_SKEW(ist) = INDEFR
	IS_KURTOSIS(ist) = INDEFR
end


# IST_ACCUMULATE4 -- Accumulate sums up to the fourth power of the data for
# data values between lower and upper.

procedure ist_accumulate4 (is, x, npts, lower, upper, minmax)

pointer	is		# pointer to the statistics structure
real	x[ARB]		# the data array
int	npts		# the number of data points
real	lower		# lower data boundary
real	upper		# upper data boundary
int	minmax		# compute the minimum and maximum

int	i, npix
real	lo, hi, xmin, xmax
double	xx, xx2, sumx, sumx2, sumx3, sumx4

begin
	lo = IS_LO(is)
	hi = IS_HI(is)
	npix = IS_NPIX(is)
	sumx = 0.0
	sumx2 = 0.0
	sumx3 = 0.0
	sumx4 = 0.0
	xmin = IS_MIN(is)
	xmax = IS_MAX(is)

	if (IS_INDEFR(lower) && IS_INDEFR(upper)) {
	    npix = npix + npts
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		    sumx4 = sumx4 + xx2 * xx2
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		    sumx4 = sumx4 + xx2 * xx2
		}
	    }
	} else {
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    npix = npix + 1
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		    sumx4 = sumx4 + xx2 * xx2
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    npix = npix + 1
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		    sumx4 = sumx4 + xx2 * xx2
		}
	    }
	}

	IS_NPIX(is) = npix
	IS_SUMX(is) = IS_SUMX(is) + sumx
	IS_SUMX2(is) = IS_SUMX2(is) + sumx2
	IS_SUMX3(is) = IS_SUMX3(is) + sumx3
	IS_SUMX4(is) = IS_SUMX4(is) + sumx4
	IS_MIN(is) = xmin
	IS_MAX(is) = xmax
end


# IST_ACCUMULATE3 -- Accumulate sums up to the third power of the data for
# data values between lower and upper.

procedure ist_accumulate3 (is, x, npts, lower, upper, minmax)

pointer	is		# pointer to the statistics structure
real	x[ARB]		# the data array
int	npts		# the number of data points
real	lower		# lower data boundary
real	upper		# upper data boundary
int	minmax		# compute the minimum and maximum

int	i, npix
real	lo, hi, xmin, xmax
double 	xx, xx2, sumx, sumx2, sumx3

begin
	lo = IS_LO(is)
	hi = IS_HI(is)
	npix = IS_NPIX(is)
	sumx = 0.0
	sumx2 = 0.0
	sumx3 = 0.0
	xmin = IS_MIN(is)
	xmax = IS_MAX(is)

	if (IS_INDEFR(lower) && IS_INDEFR(upper)) {
	    npix = npix + npts
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		}
	    }
	} else {
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    npix = npix + 1
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    npix = npix + 1
		    xx2 = xx * xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx2
		    sumx3 = sumx3 + xx2 * xx
		}
	    }
	}

	IS_NPIX(is) = npix
	IS_SUMX(is) = IS_SUMX(is) + sumx
	IS_SUMX2(is) = IS_SUMX2(is) + sumx2
	IS_SUMX3(is) = IS_SUMX3(is) + sumx3
	IS_MIN(is) = xmin
	IS_MAX(is) = xmax
end


# IST_ACCUMULATE2 -- Accumulate sums up to the second power of the data for
# data values between lower and upper.

procedure ist_accumulate2 (is, x, npts, lower, upper, minmax)

pointer	is		# pointer to the statistics structure
real	x[ARB]		# the data array
int	npts		# the number of data points
real	lower		# lower data boundary
real	upper		# upper data boundary
int	minmax		# compute the minimum and maximum

int	i, npix
real	lo, hi, xmin, xmax
double	xx, sumx, sumx2

begin
	lo = IS_LO(is)
	hi = IS_HI(is)
	npix = IS_NPIX(is)
	sumx = 0.0
	sumx2 = 0.0
	xmin = IS_MIN(is)
	xmax = IS_MAX(is)

	if (IS_INDEFR(lower) && IS_INDEFR(upper)) {
	    npix = npix + npts
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx * xx
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx * xx
		}
	    }
	} else {
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    npix = npix + 1
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx * xx
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    npix = npix + 1
		    sumx = sumx + xx
		    sumx2 = sumx2 + xx * xx
		}
	    }
	}

	IS_NPIX(is) = npix
	IS_SUMX(is) = IS_SUMX(is) + sumx
	IS_SUMX2(is) = IS_SUMX2(is) + sumx2
	IS_MIN(is) = xmin
	IS_MAX(is) = xmax
end


# IST_ACCUMULATE1 -- Accumulate sums up to the first power of the data for
# data values between lower and upper.

procedure ist_accumulate1 (is, x, npts, lower, upper, minmax)

pointer	is		# pointer to the statistics structure
real	x[ARB]		# the data array
int	npts		# the number of data points
real	lower		# lower data boundary
real	upper		# upper data boundary
int	minmax		# compute the minimum and maximum

int	i, npix
real	lo, hi, xx, xmin, xmax
double	sumx

begin
	lo = IS_LO(is)
	hi = IS_HI(is)
	npix = IS_NPIX(is)
	sumx = 0.0
	xmin = IS_MIN(is)
	xmax = IS_MAX(is)

	if (IS_INDEFR(lower) && IS_INDEFR(upper)) {
	    npix = npix + npts
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    sumx = sumx + xx
		}
	    } else {
		do i = 1, npts
		    sumx = sumx + x[i]
	    }
	} else {
	    if (minmax == YES) {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    npix = npix + 1
		    if (xx < xmin)
			xmin = xx
		    if (xx > xmax)
			xmax = xx
		    sumx = sumx + xx
		}
	    } else {
		do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
			next
		    npix = npix + 1
		    sumx = sumx + xx
		}
	    }
	}

	IS_NPIX(is) = npix
	IS_SUMX(is) = IS_SUMX(is) + sumx
	IS_MIN(is) = xmin
	IS_MAX(is) = xmax
end


# IST_ACCUMULATE0 -- Accumulate sums up to the 0th power of the data for
# data values between lower and upper.

procedure ist_accumulate0 (is, x, npts, lower, upper, minmax)

pointer	is		# pointer to the statistics structure
real	x[ARB]		# the data array
int	npts		# the number of data points
real	lower		# lower data boundary
real	upper		# upper data boundary
int	minmax		# compute the minimum and maximum

int	i, npix
real	lo, hi, xx, xmin, xmax

begin
	lo = IS_LO(is)
	hi = IS_HI(is)
	npix = IS_NPIX(is)
	xmin = IS_MIN(is)
	xmax = IS_MAX(is)

	if (IS_INDEFR(lower) && IS_INDEFR(upper)) {
	    npix = npix + npts
	    if (minmax == YES) {
	        do i = 1, npts {
		    xx = x[i]
		    if (xx < xmin)
		        xmin = xx
		    if (xx > xmax)
		        xmax = xx
	        }
	    }
	} else {
	    if (minmax == YES) {
	        do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
		        next
		    npix = npix + 1
		    if (xx < xmin)
		        xmin = xx
		    if (xx > xmax)
		        xmax = xx
	        }
	    } else {
	        do i = 1, npts {
		    xx = x[i]
		    if (xx < lo || xx > hi)
		        next
		    npix = npix + 1
		}
	    }
	}

	IS_NPIX(is) = npix
	IS_MIN(is) = xmin
	IS_MAX(is) = xmax
end


# IST_STATS -- Procedure to compute the first four central moments of the
# distribution.

procedure ist_stats (ist, bskew, bkurtosis)

pointer	ist			# statistics structure
int	bskew			# skew switch
int	bkurtosis		# kurtosis switch

double	mean, var, stdev
bool	fp_equalr()

begin
	if (fp_equalr (IS_MIN(ist), MAX_REAL))
	    IS_MIN(ist) = INDEFR
	if (fp_equalr (IS_MAX(ist), -MAX_REAL))
	    IS_MAX(ist) = INDEFR

	if (IS_NPIX(ist) <= 0)
	    return
	mean = IS_SUMX(ist) / IS_NPIX(ist)
	IS_MEAN(ist) = mean

	if (IS_NPIX(ist) < 2)
	    return
	var = (IS_SUMX2(ist) - IS_SUMX(ist) * mean) /
	    (IS_NPIX(ist) - 1)
	if (var <= 0.0) {
	    IS_STDDEV(ist) = 0.0
	    return
	} else {
	    stdev = sqrt (var)
	    IS_STDDEV(ist) = stdev
	}

	if (bskew == YES)
	    IS_SKEW(ist) = (IS_SUMX3(ist) - 3.0d0 * IS_MEAN(ist) *
	        IS_SUMX2(ist) + 3.0d0 * mean * mean *
		IS_SUMX(ist) - IS_NPIX(ist) * mean ** 3) /
		IS_NPIX(ist) / stdev / stdev / stdev
	    
	if (bkurtosis == YES)
	    IS_KURTOSIS(ist) = (IS_SUMX4(ist) - 4.0d0 * mean *
	        IS_SUMX3(ist) + 6.0d0 * mean * mean *
	        IS_SUMX2(ist) - 4.0 * mean ** 3 * IS_SUMX(ist) +
	        IS_NPIX(ist) * mean ** 4) / IS_NPIX(ist) /
	        stdev / stdev / stdev / stdev - 3.0d0
end


# IST_IHIST -- Procedure to initilaize the histogram of the image pixels.

int procedure ist_ihist (ist, binwidth, hgm, nbins, hwidth, hmin, hmax)

pointer	ist		# pointer to the statistics structure
real	binwidth	# histogram bin width in sigma
pointer	hgm		# pointer to the histogram
int	nbins		# number of bins
real	hwidth		# histogram resolution
real	hmin		# minimum histogram value
real	hmax		# maximum histogram value

begin
	nbins = 0
	if (binwidth <= 0.0)
	    return (NO)
	hwidth = binwidth * IS_STDDEV(ist)
	if (hwidth <= 0.0)
	    return (NO)
	nbins = (IS_MAX(ist) - IS_MIN(ist)) / hwidth + 1
	if (nbins < 3)
	    return (NO)

	hmin = IS_MIN(ist)
	hmax = IS_MAX(ist)
	call malloc (hgm, nbins, TY_INT)
	return (YES)
end


# IST_HMEDIAN -- Procedure to compute the median of the values.

procedure ist_hmedian (ist, hgm, nbins, hwidth, hmin, hmax)

pointer	ist		# pointer to the statistics strucuture
int	hgm[ARB]	# histogram of the pixels
int	nbins		# number of bins in the histogram
real	hwidth		# resolution of the histogram
real	hmin		# minimum histogram value
real	hmax		# maximum histogram value

int	i, lo, hi
pointer	sp, ihgm
real	h1, hdiff, hnorm
bool	fp_equalr()

begin
	call smark (sp)
	call salloc (ihgm, nbins, TY_REAL)

	# Integrate the histogram and normalize.
	Memr[ihgm] = hgm[1]
	do i = 2, nbins
	    Memr[ihgm+i-1] = hgm[i] + Memr[ihgm+i-2]
	hnorm = Memr[ihgm+nbins-1]
	call adivkr (Memr[ihgm], hnorm, Memr[ihgm], nbins)

	# Initialize the low and high bin numbers.
	lo = 0
	hi = 1

	# Search for the point which divides the integral in half.
	do i = 1, nbins {
	    if (Memr[ihgm+i-1] > 0.5)
		break
	    lo = i
	}
	hi = lo + 1
	#call eprintf (
	    #"hmin=%g hmax=%g hw=%g nbins=%d lo=%d ih(lo)=%g hi=%d ih(hi)=%g\n")
	    #call pargr (hmin)
	    #call pargr (hmax)
	    #call pargr (hwidth)
	    #call pargi (nbins)
	    #call pargi (lo)
	    #call pargr (Memr[ihgm+lo-1])
	    #call pargi (hi)
	    #call pargr (Memr[ihgm+hi-1])

	# Approximate the histogram.
	h1 = hmin + lo * hwidth
	if (lo == 0)
	    hdiff = Memr[ihgm+hi-1]
	else
	    hdiff = Memr[ihgm+hi-1] - Memr[ihgm+lo-1]
	if (fp_equalr (hdiff, 0.0))
	    IS_MEDIAN(ist) = h1
	else if (lo == 0)
	    IS_MEDIAN(ist) = h1 + 0.5 / hdiff * hwidth
	else
	    IS_MEDIAN(ist) = h1 + (0.5 - Memr[ihgm+lo-1]) / hdiff * hwidth
	#call eprintf ("hlo=%g hhi=%g h1=%g hdiff=%g median=%g\n")
	    #call pargr (hmin)
	    #call pargr (hmin + (nbins - 1) * hwidth)
	    #call pargr (h1)
	    #call pargr (hdiff)
	    #call pargr (IS_MEDIAN(ist))

	call sfree (sp)
end


# IST_HMODE -- Procedure to compute the mode.

procedure ist_hmode (ist, hgm, nbins, hwidth, hmin, hmax)

pointer	ist		# pointer to the statistics strucuture
int	hgm[ARB]	# histogram of the pixels
int	nbins		# number of bins in the histogram
real	hwidth		# resolution of the histogram
real	hmin		# minimum histogram value
real	hmax		# maximum histogram value

int	i, bpeak
real	hpeak, dh1, dh2, denom
bool	fp_equalr()

begin
	# If there is a single bin return the midpoint of that bin.
	if (nbins == 1) {
	    IS_MODE(ist) = hmin + 0.5 * hwidth
	    return
	}

	# If there are two bins return the midpoint of the greater bin.
	if (nbins == 2) {
	    if (hgm[1] > hgm[2])
	        IS_MODE(ist) = hmin + 0.5 * hwidth
	    else if (hgm[2] > hgm[1])
	        IS_MODE(ist) = hmin + 1.5 * hwidth
	    else
	        IS_MODE(ist) = hmin + hwidth
	    return
	}

	# Find the bin containing the histogram maximum.
	hpeak = hgm[1]
	bpeak = 1
	do i = 2, nbins {
	    if (hgm[i] > hpeak) {
		hpeak = hgm[i]
		bpeak = i
	    }
	}

	# If the maximum is in the first bin return the midpoint of the bin.
	if (bpeak == 1) {
	    IS_MODE(ist) = hmin + 0.5 * hwidth
	    return
	}

	# If the maximum is in the last bin return the midpoint of the bin.
	if (bpeak == nbins) {
	    IS_MODE(ist) = hmin + (nbins - 0.5) * hwidth
	    return
	}

	# Compute the lower limit of bpeak.
	bpeak = bpeak - 1

	# Do a parabolic interpolation to find the peak.
	dh1 = hgm[bpeak+1] - hgm[bpeak]
	dh2 = hgm[bpeak+1] - hgm[bpeak+2]
	denom = dh1 + dh2
	if (fp_equalr (denom, 0.0)) {
	    IS_MODE(ist) = hmin + (bpeak + 0.5) * hwidth
	} else {
	    IS_MODE(ist) = bpeak + 1 + 0.5 * (dh1 - dh2) / denom
	    IS_MODE(ist) = hmin + (IS_MODE(ist) - 0.5) * hwidth
	}


	dh1 = hgm[bpeak] * (hmin + (bpeak - 0.5) * hwidth) +
	    hgm[bpeak+1] * (hmin + (bpeak + 0.5) * hwidth) +
	    hgm[bpeak+2] * (hmin + (bpeak + 1.5) * hwidth)
	dh2 = hgm[bpeak] + hgm[bpeak+1] + hgm[bpeak+2]
end


# IST_PHEADER -- Print the banner fields.

procedure ist_pheader (fields, nfields)

int	fields[ARB]		# fields to be printed
int	nfields			# number of fields

int	i

begin
	call printf ("#")
	do i = 1, nfields {
	    switch (fields[i]) {
	    case IS_FIMAGE:
	        call printf (IS_FSTRING)
		    call pargstr (IS_KIMAGE)
	    case IS_FNPIX:
	        call printf (IS_FCOLUMN)
		    call pargstr (IS_KNPIX)
	    case IS_FMIN:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KMIN)
	    case IS_FMAX:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KMAX)
	    case IS_FMEAN:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KMEAN)
	    case IS_FMEDIAN:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KMEDIAN)
	    case IS_FMODE:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KMODE)
	    case IS_FSTDDEV:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KSTDDEV)
	    case IS_FSKEW:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KSKEW)
	    case IS_FKURTOSIS:
		call printf (IS_FCOLUMN)
		    call pargstr (IS_KKURTOSIS)
	    }
	}

	call printf ("\n")
	call flush (STDOUT)
end


# IST_PRINT -- Print the fields

procedure ist_print (image, ist, fields, nfields)

char	image[ARB]		# image name
pointer	ist			# pointer to the statistics structure
int	fields[ARB]		# fields to be printed
int	nfields			# number of fields

int	i

begin
	call printf (" ")
	do i = 1, nfields {
	    switch (fields[i]) {
	    case IS_FIMAGE:
	        call printf (IS_FSTRING)
		    call pargstr (image)
	    case IS_FNPIX:
	        call printf (IS_FINTEGER)
		    call pargi (IS_NPIX(ist))
	    case IS_FMIN:
		call printf (IS_FREAL)
		    call pargr (IS_MIN(ist))
	    case IS_FMAX:
		call printf (IS_FREAL)
		    call pargr (IS_MAX(ist))
	    case IS_FMEAN:
		call printf (IS_FREAL)
		    call pargr (IS_MEAN(ist))
	    case IS_FMEDIAN:
		call printf (IS_FREAL)
		    call pargr (IS_MEDIAN(ist))
	    case IS_FMODE:
		call printf (IS_FREAL)
		    call pargr (IS_MODE(ist))
	    case IS_FSTDDEV:
		call printf (IS_FREAL)
		    call pargr (IS_STDDEV(ist))
	    case IS_FSKEW:
		call printf (IS_FREAL)
		    call pargr (IS_SKEW(ist))
	    case IS_FKURTOSIS:
		call printf (IS_FREAL)
		    call pargr (IS_KURTOSIS(ist))
	    }
	}

	call printf ("\n")
	call flush (STDOUT)
end


# IST_FPRINT -- Print the fields using a free format.

procedure ist_fprint (image, ist, fields, nfields)

char	image[ARB]		# image name
pointer	ist			# pointer to the statistics structure
int	fields[ARB]		# fields to be printed
int	nfields			# number of fields

int	i

begin
	do i = 1, nfields {
	    switch (fields[i]) {
	    case IS_FIMAGE:
	        call printf ("%s")
		    call pargstr (image)
	    case IS_FNPIX:
	        call printf ("%d")
		    call pargi (IS_NPIX(ist))
	    case IS_FMIN:
		call printf ("%g")
		    call pargr (IS_MIN(ist))
	    case IS_FMAX:
		call printf ("%g")
		    call pargr (IS_MAX(ist))
	    case IS_FMEAN:
		call printf ("%g")
		    call pargr (IS_MEAN(ist))
	    case IS_FMEDIAN:
		call printf ("%g")
		    call pargr (IS_MEDIAN(ist))
	    case IS_FMODE:
		call printf ("%g")
		    call pargr (IS_MODE(ist))
	    case IS_FSTDDEV:
		call printf ("%g")
		    call pargr (IS_STDDEV(ist))
	    case IS_FSKEW:
		call printf ("%g")
		    call pargr (IS_SKEW(ist))
	    case IS_FKURTOSIS:
		call printf ("%g")
		    call pargr (IS_KURTOSIS(ist))
	    }
	    if (i < nfields)
		call printf ("  ")
	}

	call printf ("\n")
	call flush (STDOUT)
end



# IST_GDATA -- Get a line of masked data.
# If mask pointer is null then return the whole line.
# This routine allocates/reallocates memory for one line of image data.

int procedure ist_gdata (im, pm, v, buf, n)

pointer	im			#I Image pointer
pointer	pm			#I Mask image pointer
long	v[IM_MAXDIM]		#I Line
pointer	buf			#I Buffer to be filled (externally allocated)
int	n			#O Number of pixels

int	i, nalloc, imgnlr(), imgnls()
long	pmv[IM_MAXDIM]
pointer	data, imbuf, pmbuf
errchk	malloc, realloc, imgnlr, imgnls

data	nalloc /0/

begin
	# If there is no mask return the whole line in the IMIO buffer.
	if (pm == NULL) {
	    n = IM_LEN(im,1)
	    return (imgnlr (im, buf, v))
	}

	# Allocate or reallocate a line buffer as needed.
	if (nalloc == 0) {
	    nalloc = IM_LEN(im,1)
	    call malloc (data, nalloc, TY_REAL)
	} else if (nalloc < IM_LEN(im,1)) {
	    nalloc = IM_LEN(im,1)
	    call realloc (data, nalloc, TY_REAL)
	}

	# Initialize return values.
	n = 0
	buf = data

	# Get line of data and mask.
	call amovl (v, pmv, IM_MAXDIM)
	if (imgnlr (im, imbuf, v) == EOF)
	    return (EOF)
	if (imgnls (pm, pmbuf, pmv) == EOF)
	    return (EOF)

	# Copy the masked values to the output buffer.
	do i = 1, IM_LEN(im,1) {
	    if (Mems[pmbuf] != 0) {
		Memr[buf+n] = Memr[imbuf]
		n = n + 1
	    }
	    imbuf = imbuf + 1
	    pmbuf = pmbuf + 1
	}

	return (n)
end
mscred-5.05-2018.07.09/src/t_jlists.x000066400000000000000000000054641332166314300166120ustar00rootroot00000000000000# T_JLISTS -- Expand and join file or image lists.

procedure t_jlists ()

int	i, j, nlists, lenlists, fd
bool	shortest
pointer	sp, lists, fname, delim, missing, param

bool	clgetb()
int	clgeti(), clgwrd()
int	open()
int	fntopnb(), fntlenb(), fntgfnb()
int	imtopen(), imtlen(), imtgetim()
errchk	open, fntopnb, imtopen

begin
	nlists = clgeti ("$nargs")

	call smark (sp)
	call salloc (lists, nlists, TY_INT)
	call salloc (fname, SZ_LINE, TY_CHAR)
	call salloc (delim, SZ_LINE, TY_CHAR)
	call salloc (missing, SZ_LINE, TY_CHAR)
	call salloc (param, SZ_LINE, TY_CHAR)

	# Get parameters.
	call clgstr ("output", Memc[fname], SZ_LINE)
	call clgstr ("delim", Memc[delim], SZ_FNAME)
	shortest = clgetb ("shortest")
	call clgstr ("missing", Memc[missing], SZ_FNAME)

	# Open output.
	fd = open (Memc[fname], APPEND, TEXT_FILE)

	# Expand lists.
	switch (clgwrd ("type", Memc[fname], SZ_LINE, "|file|image|")) {
	case 1:
	    # Open lists.
	    lenlists = 0
	    do i = 1, nlists {
		call sprintf (Memc[param], SZ_LINE, "list%d")
		    call pargi (i)
		call clgstr (Memc[param], Memc[fname], SZ_LINE)
		Memi[lists+i-1] = fntopnb (Memc[fname], NO)
		if (i == 1)
		    lenlists = fntlenb (Memi[lists+i-1])
		else if (shortest)
		    lenlists = min (fntlenb(Memi[lists+i-1]), lenlists)
		else
		    lenlists = max (fntlenb(Memi[lists+i-1]), lenlists)
	    }
	    # Output lists.
	    do j = 1, lenlists {
		do i = 1, nlists {
		    if (i > 1) {
			call fprintf (fd, "%s")
			    call pargstr (Memc[delim])
		    }
		    if (fntgfnb (Memi[lists+i-1],Memc[fname],SZ_LINE) != EOF) {
			call fprintf (fd, "%s")
			    call pargstr (Memc[fname])
		    } else {
			call fprintf (fd, "%s")
			    call pargstr (Memc[missing])
		    }
		}
		call fprintf (fd, "\n")
	    }
	    # Close lists.
	    do i = 1, nlists
		call fntclsb (Memi[lists+i-1])
	    
	case 2:
	    # Open lists.
	    lenlists = 0
	    do i = 1, nlists {
		call sprintf (Memc[param], SZ_LINE, "list%d")
		    call pargi (i)
		call clgstr (Memc[param], Memc[fname], SZ_LINE)
		Memi[lists+i-1] = imtopen (Memc[fname])
		if (i == 1)
		    lenlists = imtlen (Memi[lists+i-1])
		else if (shortest)
		    lenlists = min (imtlen(Memi[lists+i-1]), lenlists)
		else
		    lenlists = max (imtlen(Memi[lists+i-1]), lenlists)
	    }
	    # Output lists.
	    do j = 1, lenlists {
		do i = 1, nlists {
		    if (i > 1) {
			call fprintf (fd, "%s")
			    call pargstr (Memc[delim])
		    }
		    if (imtgetim (Memi[lists+i-1],Memc[fname],SZ_LINE) != EOF) {
			call fprintf (fd, "%s")
			    call pargstr (Memc[fname])
		    } else {
			call fprintf (fd, "%s")
			    call pargstr (Memc[missing])
		    }
		}
		call fprintf (fd, "\n")
	    }
	    # Close lists.
	    do i = 1, nlists
		call imtclose (Memi[lists+i-1])

	default:
	    call error (1, "Unknown list type")
	}

	# Close output.
	call close (fd)

	call sfree (sp)
end

mscred-5.05-2018.07.09/src/t_mkmsc.x000066400000000000000000000303161332166314300164060ustar00rootroot00000000000000include	
include	
include	


# T_MKMSC -- Convert data to MSCRED format.

procedure t_mkmsc()

pointer	inlist				# Input list of image
pointer	outlist				# Output list of files
pointer	desc				# Description file
bool	verbose				# Verbose?

int	i, j, l, n
int	datasec[3,2], trimsec[3,2], biassec[3,2]
int	dsec[2,2], bsec[2,2], ndata[2], nbias[2]
double	dval
pointer	sp, val, input, output, temp, image, extname, ptr, ibuf, obuf
pointer	estp, esym, stp, sym
pointer	in, out

bool	clgetb(), streq()
int	strlen(), stridxs(), ctod(), ctoi(), errcode(), imaccess()
int	imtopenp(), imtgetim(), imtlen()
pointer	immap(), imgl2i(), impl2i(), imgl2r(), impl2r()
pointer	estp_open(), sthead(), stnext(), stname()

errchk	estp_open, immap, imgl2i, impl2i, imgl2r, impl2r

begin
	call smark (sp)
	call salloc (desc, SZ_FNAME, TY_CHAR)
	call salloc (val, SZ_LINE, TY_CHAR)
	call salloc (input, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)
	call salloc (temp, SZ_FNAME, TY_CHAR)
	call salloc (image, SZ_FNAME, TY_CHAR)

	inlist = imtopenp ("input")
	outlist = imtopenp ("output")
	call clgstr ("description", Memc[desc], SZ_FNAME)
	verbose = clgetb ("verbose")

	# Check lists match.
	i = imtlen (inlist)
	j = imtlen (outlist)
	if (j > 0 && j != i)
	    call error (1, "Input and output lists do not match")

	# Read description file into symbol tables.
	estp = estp_open (Memc[desc], verbose)

	# Create the extensions.
	while (imtgetim (inlist, Memc[image], SZ_FNAME) != EOF) {
	    # Ignore any image sections in the input.
	    call imgimage (Memc[image], Memc[input], SZ_FNAME)
	    if (imtgetim (outlist, Memc[temp], SZ_FNAME) == EOF) {
		call mktemp ("tmp", Memc[temp], SZ_FNAME)
		call strcat (".fits", Memc[temp], SZ_FNAME)
		call strcpy (Memc[input], Memc[output], SZ_FNAME)
	    } else if (streq (Memc[input], Memc[output])) {
		call mktemp ("tmp", Memc[temp], SZ_FNAME)
		call strcat (".fits", Memc[temp], SZ_FNAME)
		call strcpy (Memc[input], Memc[output], SZ_FNAME)
	    } else
		call strcpy (Memc[temp], Memc[output], SZ_FNAME)

	    iferr {
		in = NULL
		out = NULL

		if (imaccess (Memc[temp], 0) == YES) {
		    call sprintf (Memc[val], SZ_LINE,
			"Output file already exists (%s)")
			call pargstr (Memc[temp])
		    call error (1, Memc[val])
		}

		ptr = immap (Memc[input], READ_ONLY, 0); in = ptr

		for (esym=sthead(estp); esym!=NULL; esym=stnext(estp,esym)){
		    stp = Memi[esym]
		    extname = stname (estp, esym)

		    # Check whether to create extension.
		    call mk_gkey (stp, in, "DATASEC", Memc[val], SZ_LINE)
		    if (Memc[val] == EOS)
			next

		    # Create output extension.
		    call sprintf (Memc[image], SZ_LINE, "%s[%s,append]")
			call pargstr (Memc[temp])
			call pargstr (Memc[extname])
		    iferr (ptr = immap (Memc[image], NEW_COPY, in)) {
			switch (errcode()) {
			case SYS_IKIKSECTNS:
			    # Try adding ".fits" to name.
			    call sprintf (Memc[image], SZ_LINE,
				"%s.fits[%s,append]")
				call pargstr (Memc[temp])
				call pargstr (Memc[extname])
			    ptr = immap (Memc[image], NEW_COPY, in)
			default:
			    call erract (EA_ERROR)
			}
		    }
		    out = ptr

		    # Determine data section.
		    datasec[1,1] = 1
		    datasec[2,1] = IM_LEN(in,1)
		    datasec[3,1] = 1
		    datasec[1,2] = 1
		    datasec[2,2] = IM_LEN(in,2)
		    datasec[3,2] = 1
		    call mk_gkey (stp, in, "DATASEC", Memc[val], SZ_LINE)
		    if (Memc[val] != EOS)
			call ccd_section (Memc[val], datasec[1,1],
			    datasec[2,1], datasec[3,1], datasec[1,2],
			    datasec[2,2], datasec[3,2])
		    dsec[1,1] = min (datasec[1,1], datasec[2,1])
		    dsec[2,1] = max (datasec[1,1], datasec[2,1])
		    dsec[1,2] = min (datasec[1,2], datasec[2,2])
		    dsec[2,2] = max (datasec[1,2], datasec[2,2])
		    ndata[1] = dsec[2,1] - dsec[1,1] + 1
		    ndata[2] = dsec[2,2] - dsec[1,2] + 1

		    # Determine trim section.
		    call mk_gkey (stp, in, "TRIMSEC", Memc[val], SZ_LINE)
		    if (Memc[val] != EOS) {
			trimsec[1,1] = 1
			trimsec[2,1] = IM_LEN(in,1)
			trimsec[3,1] = 1
			trimsec[1,2] = 1
			trimsec[2,2] = IM_LEN(in,2)
			trimsec[3,2] = 1
			call ccd_section (Memc[val], trimsec[1,1],
			    trimsec[2,1], trimsec[3,1], trimsec[1,2],
			    trimsec[2,2], trimsec[3,2])
		    } else
			trimsec[1,1] = INDEFI

		    # Determine bias section.
		    call mk_gkey (stp, in, "BIASSEC", Memc[val], SZ_LINE)
		    if (Memc[val] != EOS) {
			biassec[1,1] = 1
			biassec[2,1] = IM_LEN(in,1)
			biassec[3,1] = 1
			biassec[1,2] = 1
			biassec[2,2] = IM_LEN(in,2)
			biassec[3,2] = 1
			call ccd_section (Memc[val], biassec[1,1],
			    biassec[2,1], biassec[3,1], biassec[1,2],
			    biassec[2,2], biassec[3,2])
			bsec[1,1] = min (biassec[1,1], biassec[2,1])
			bsec[2,1] = max (biassec[1,1], biassec[2,1])
			bsec[1,2] = dsec[1,2]
			bsec[2,2] = dsec[2,2]
			nbias[1] = bsec[2,1] - bsec[1,1] + 1
			nbias[2] = bsec[2,2] - bsec[1,2] + 1
		    } else {
			nbias[1] = INDEFI
			nbias[2] = INDEFI
		    }

		    # Set output size.
		    IM_LEN(out,1) = ndata[1]
		    IM_LEN(out,2) = ndata[2]
		    if (!IS_INDEFI(nbias[1]))
			IM_LEN(out,1) = IM_LEN(out,1) + nbias[1]

		    # Set header.
		    call sprintf (Memc[val], SZ_LINE, "[%d:%d,%d:%d]")
			call pargi (datasec[1,1] - dsec[1,1] + 1)
			call pargi (datasec[2,1] - dsec[1,1] + 1)
			call pargi (datasec[1,2] - dsec[1,2] + 1)
			call pargi (datasec[2,2] - dsec[1,2] + 1)
		    call imastr (out, "DATASEC", Memc[val])
		    if (!IS_INDEFI(trimsec[1,1])) {
			call sprintf (Memc[val], SZ_LINE, "[%d:%d,%d:%d]")
			    call pargi (trimsec[1,1] - dsec[1,1] + 1)
			    call pargi (trimsec[2,1] - dsec[1,1] + 1)
			    call pargi (trimsec[1,2] - dsec[1,2] + 1)
			    call pargi (trimsec[2,2] - dsec[1,2] + 1)
			call imastr (out, "TRIMSEC", Memc[val])
		    }
		    if (!IS_INDEFI(nbias[1])) {
			i = min (biassec[1,1], biassec[2,1]) - 1 - ndata[1]
			j = min (biassec[1,2], biassec[2,2]) - 1
			call sprintf (Memc[val], SZ_LINE, "[%d:%d,%d:%d]")
			    call pargi (biassec[1,1] - bsec[1,1] + ndata[1] + 1)
			    call pargi (biassec[2,1] - bsec[1,1] + ndata[1] + 1)
			    call pargi (biassec[1,2] - bsec[1,2] + 1)
			    call pargi (biassec[2,2] - bsec[1,2] + 1)
			call imastr (out, "BIASSEC", Memc[val])
		    }
		    for (sym=sthead(stp); sym!=NULL; sym=stnext(stp,sym)) {
			ptr = stname (stp, sym) 
			if (streq (Memc[ptr], "DATASEC"))
			    next
			else if (streq (Memc[ptr], "TRIMSEC"))
			    next
			else if (streq (Memc[ptr], "BIASSEC"))
			    next

			call mk_gkey (stp, in, Memc[ptr], Memc[val], SZ_LINE)
			n = strlen (Memc[val])
			i = 1
			j = 1
			if (ctoi (Memc[val], i, l) == n)
			    call imaddi (out, Memc[ptr], l)
			else if (ctod (Memc[val], j, dval) == n) {
			    if (stridxs (":", Memc[val]) > 0)
				call imastr (out, Memc[ptr], Memc[val])
			    else
				call imaddd (out, Memc[ptr], dval)
			} else
			    call imastr (out, Memc[ptr], Memc[val])
		    }

		    if (verbose) {
			call printf ("  Create %s[%s][%d,%d]: %s\n")
			    call pargstr (Memc[output])
			    call pargstr (Memc[extname])
			    call pargi (IM_LEN(out,1))
			    call pargi (IM_LEN(out,2))
			    call pargstr (IM_TITLE(out))
			call printf ("    %s[%d:%d,%d,%d]")
			    call pargstr (Memc[input])
			    call pargi (dsec[1,1])
			    call pargi (dsec[2,1])
			    call pargi (dsec[1,2])
			    call pargi (dsec[2,2])
			call printf (" -> %s[%s][%d:%d,%d:%d]\n")
			    call pargstr (Memc[output])
			    call pargstr (Memc[extname])
			    call pargi (1)
			    call pargi (ndata[1])
			    call pargi (1)
			    call pargi (ndata[2])
			if (!IS_INDEFI(nbias[1])) {
			    call printf ("    %s[%d:%d,%d,%d]")
				call pargstr (Memc[input])
				call pargi (bsec[1,1])
				call pargi (bsec[2,1])
				call pargi (bsec[1,2])
				call pargi (bsec[2,2])
			    call printf (" -> %s[%s][%d:%d,%d:%d]\n")
				call pargstr (Memc[output])
				call pargstr (Memc[extname])
				call pargi (ndata[1]+1)
				call pargi (ndata[1]+nbias[1])
				call pargi (1)
				call pargi (nbias[2])
			}
			call flush (STDOUT)
		    }

		    # Copy data.
		    switch (IM_PIXTYPE(in)) {
		    case TY_USHORT, TY_INT:
			do l = 1, IM_LEN(out,2) {
			    ibuf = imgl2i (in, l+dsec[1,2]-1)
			    obuf = impl2i (out, l)
			    call amovi (Memi[ibuf+dsec[1,1]-1],
				Memi[obuf], ndata[1])
			    if (!IS_INDEFI(nbias[1]))
				call amovi (Memi[ibuf+bsec[1,1]-1],
				    Memi[obuf+ndata[1]], nbias[1])
			}
		    default:
			do l = 1, IM_LEN(out,2) {
			    ibuf = imgl2r (in, l+dsec[1,2]-1)
			    obuf = impl2r (out, l)
			    call amovr (Memr[ibuf+dsec[1,1]-1],
				Memr[obuf], ndata[1])
			    if (!IS_INDEFI(nbias[1]))
				call amovr (Memr[ibuf+bsec[1,1]-1],
				    Memr[obuf+ndata[1]], nbias[1])
			}
		    }

		    call imunmap (out)
		}

		call imunmap (in)

		if (streq (Memc[output], Memc[input])) {
		    call imdelete (Memc[input])
		    call imrename (Memc[temp], Memc[input])
		}
	    } then {
		if (out != NULL) {
		    call imunmap (out)
		    call imdelete (Memc[temp])
		}
		if (in != NULL)
		    call imunmap (in)
		call erract (EA_WARN)
	    }
	}

	# Close the symbol tables.
	for (esym=sthead(estp); esym!=NULL; esym=stnext(estp,esym))
	    call stclose (Memi[esym])
	call stclose (estp)

	call imtclose (outlist)
	call imtclose (inlist)

	call sfree (sp)
end


# MK_GKEY -- Get keyword.

procedure mk_gkey (stp, im, key, val, maxchar)

pointer	stp			#I Symbol table
pointer	im			#I Image pointer
char	key[ARB]		#I Key
char	val[ARB]		#O Value
int	maxchar			#I Maximum characters to return

pointer	sym, cp, stfind(), strefsbuf()

begin
	# Initialize return value.
	val[1] = EOS

	# Find key in symbol table.
	sym = stfind (stp, key)
	if (sym == NULL)
	    return

	# Get key value.  If not an image reference return value.
	cp = strefsbuf (stp, Memi[sym])
	if (Memc[cp] != '!') {
	    call strcpy (Memc[cp], val, maxchar)
	    return
	}

	iferr (call imgstr (im, Memc[cp+1], val, maxchar))
	    val[1] = EOS
end


# ESTP_OPEN --  Read description file into symbol tables.  There is a symbol
# table of other symbol tables indexed by the extension names.
# Each extension name has a symbol table of keywords.

pointer procedure estp_open (desc, verbose)

char	desc[ARB]		#I Description file
bool	verbose			#I Verbose?
pointer	estp			#O Symbol table of extensions

int	ip, fd
pointer	sp, key, val, extname, ptr
pointer	esym, stp, sym, estp1, esym1, stp1, sym1

int	open(), fscan(), nscan(), stpstr()
pointer	stopen(), stenter(), stfind(), sthead(), stnext(), stname(), strefsbuf()

errchk	open

begin
	call smark (sp)
	call salloc (key, SZ_FNAME, TY_CHAR)
	call salloc (val, SZ_LINE, TY_CHAR)

	estp = stopen (desc, 32, 32, 32*16)

	if (verbose) {
	    call printf ("  Reading description file %s\n")
	        call pargstr (desc)
	    call flush (STDOUT)
	}

	fd = open (desc, READ_ONLY, TEXT_FILE)
	while (fscan(fd) != EOF) {
	    call gargwrd (Memc[key], SZ_FNAME)
	    call gargwrd (Memc[val], SZ_LINE)
	    if (nscan() != 2)
		next
	    if (Memc[key] == '#')
		next

	    # Separate key into keyword and extension name.
	    extname = NULL
	    for (ip=key; Memc[ip] != EOS; ip=ip+1) {
		if (Memc[ip] == '(') {
		    Memc[ip] = EOS
		    extname = ip + 1
		} else if (Memc[ip] == ')')
		    Memc[ip] = EOS
	    }

	    # Get extension symbol table.  Create one as needed.
	    esym = stfind (estp, Memc[extname])
	    if (esym == NULL) {
		esym = stenter (estp, Memc[extname], 1)
		Memi[esym] = stopen (Memc[extname], 32, 32, 32*SZ_LINE)
	    }
	    stp = Memi[esym]

	    # Enter keyword value.  Previous values are overridden.
	    call strupr (Memc[key])
	    sym = stfind (stp, Memc[key])
	    if (sym == NULL) {
		sym = stenter (stp, Memc[key], 1)
		Memi[sym] = stpstr (stp, Memc[val], SZ_LINE)
	    } else {
		ptr = strefsbuf (stp, Memi[sym])
		call strcpy (Memc[val], Memc[ptr], SZ_LINE)
	    }
	}
	call close (fd)

	# Reverse the symbol tables so that we can use sthead/stnext.
	estp1 = stopen (desc, 32, 32, 32*16)
	for (esym=sthead(estp); esym!=NULL; esym=stnext(estp,esym)) {
	    stp = Memi[esym]
	    extname = stname (estp, esym)

	    stp1 = stopen (Memc[extname], 32, 32, 32*SZ_LINE)
	    esym1 = stenter (estp1, Memc[extname], 1)
	    Memi[esym1] = stp1
	    for (sym=sthead(stp); sym!=NULL; sym=stnext(stp,sym)) {
		ptr = strefsbuf (stp, Memi[sym])
		sym1 = stenter (stp1, Memc[stname(stp,sym)], 1)
		Memi[sym1] = stpstr (stp1, Memc[ptr], SZ_LINE)
	    }
	    call stclose (stp)
	}
	call stclose (estp)
	estp = estp1

	call sfree (sp)
	return (estp)
end
mscred-5.05-2018.07.09/src/t_msccmatch.x000066400000000000000000000731131332166314300172400ustar00rootroot00000000000000include	
include	
include	
include	
include	

define	SZ_CMD	4*SZ_LINE
define	CT_LW	1	# Logical to world
define	CT_WL	2	# World to logical
define	CT_WA	3	# World to astrometry

procedure t_msccmatch ()

int	input		# List of input Mosaic images
pointer	coords		# Input coordinate file or command
pointer outcoords	# Output coordinate files
bool	usebpm		# Use BPM?
int	nsearch		# Maximum number of coordinates for search
double	search		# Maximum search radius (may be zero)
double	rsearch		# Maximum rotation search (degrees)
int	nfit		# Minimum number of coordinates for fit
double	rms		# Maximum rms to accept
double	maxshift	# Maximum shift (arc sec)
pointer	fitgeom		# Fit geometry
int	interactive	# Interactive?
int	ifit		# Interactive fitting?
int	update		# Update?
int	verbose		# Verbose?
int	listcoords	# List coordinates?
int	accept		# Accept solution?
int	cbox		# Centering box (pixels)
double	csig		# Maximum centering uncertainty to accept (pixels)
double	cfrac		# Minimum fraction of accepted centers

int	i, n, nm, outlist, extlist, nims, stat, srch
double	scale, xshift, yshift, theta, xshft, yshft, t,  results[8]
real	reject
pointer	sp, sp1, mef, image, bpmname, keyval
pointer	xptr, yptr, mptr, mw, ct
pointer	im, wcs, crpix, bpm, imin, wcsin, xref, yref, mref, xin, yin, sort, tmp

bool	clgetb()
real	clgetr()
int	clgeti(), btoi (), cm_compared()
int	imtopenp(), imtlen(), imtgetim(), imtrgetim(), xt_extns()
int	clpopnu(), clgfil()
long	clktime()
double	clgetd(), msc_wcsstatd()
pointer	immap(), yt_pmmap(),  msc_openim(), msc_sctran(), wcs_trans()
errchk	open, immap, yt_pmmap, msc_openim
errchk	cm_pixel, cm_shift, cm_center, cm_geomap, wcs_adjust, cm_updcoords
errchk	cm_getcoords
extern	cm_compared()

begin
	call smark (sp)
	call salloc (mef, SZ_FNAME, TY_CHAR)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (bpmname, SZ_FNAME, TY_CHAR)
	call salloc (coords, SZ_LINE, TY_CHAR)
	call salloc (outcoords, SZ_FNAME, TY_CHAR)
	call salloc (fitgeom, SZ_FNAME, TY_CHAR)
	call salloc (keyval, SZ_FNAME, TY_CHAR)

	# Get task parameters.
	input = imtopenp ("input")
	call clgstr ("coords", Memc[coords], SZ_LINE)
	outlist = clpopnu ("outcoords")
	usebpm = clgetb ("usebpm")
	nsearch = clgeti ("nsearch")
	search = clgetd ("search")
	rsearch = clgetd ("rsearch")
	maxshift = clgetd ("maxshift")
	nfit = clgeti ("nfit")
	rms = clgetd ("rms")
	call clgstr ("fitgeometry", Memc[fitgeom], SZ_FNAME)
	interactive = btoi (clgetb ("interactive"))
	ifit = btoi (clgetb ("fit"))
	update = btoi (clgetb ("update"))
	verbose = btoi (clgetb ("verbose"))
	listcoords = btoi (clgetb ("listcoords"))
	reject = clgetr ("reject")
	accept = update
	cbox = clgeti ("cbox")
	csig = clgetd ("csig")
	cfrac = clgetd ("cfrac")

	if (verbose == YES) {
	    call fseti (STDOUT, F_FLUSHNL, YES)
	    call printf ("MSCCMATCH:\n")
	}

	# Initialize shifts.  If using a dither placing this outside the
	# image loop will track the shifts.
	xshift = 0.
	yshift = 0.
	theta = 0.

	# Loop on the input MEF files.
	while (imtgetim (input, Memc[mef], SZ_FNAME) != EOF) {
	    if (clgfil (outlist, Memc[outcoords], SZ_FNAME) == EOF)
		Memc[outcoords] = EOS

	    if (verbose == YES) {
		call printf ("  %s:\n")
		    call pargstr (Memc[mef])
	    }

	    iferr {
		bpm = NULL; wcs = NULL; im = NULL
		call smark (sp1)

		extlist = xt_extns (Memc[mef], "IMAGE", "0-", "", "",
		    YES, NO, NO, NO, "", NO, i)
		nims = imtlen (extlist)
		if (nims == 0)
		    call error (1, "No images found")

		# Read coordinates.
		call cm_getcoords (Memc[mef], Memc[coords], xptr, yptr,
		    n, mptr, nm)

		if (n == 0)
		    call error (1, "No input coordinates found")

		if (nfit <= 0)
		    nfit = max (1, n + nfit)
		if (n < nfit)
		    call error (1,
			"Too few input coordinates for minimum number to fit")

		call salloc (imin, n, TY_POINTER)
		call salloc (wcsin, n, TY_POINTER)
		call salloc (xref, n, TY_DOUBLE)
		call salloc (yref, n, TY_DOUBLE)
		call salloc (mref, n, TY_DOUBLE)
		call salloc (xin, n, TY_DOUBLE)
		call salloc (yin, n, TY_DOUBLE)
		call salloc (sort, n, TY_INT)

		call amovd (Memd[xptr], Memd[xref], n)
		call amovd (Memd[yptr], Memd[yref], n)
		call amovd (Memd[mptr], Memd[mref], n)
		call mfree (xptr, TY_DOUBLE)
		call mfree (yptr, TY_DOUBLE)
		call mfree (mptr, TY_DOUBLE)

		do i = 0, n-1
		    Memi[sort+i] = i

		call salloc (im, nims, TY_POINTER)
		call salloc (wcs, nims, TY_POINTER)
		call salloc (crpix, 2*nims, TY_DOUBLE)
		call salloc (bpm, nims, TY_POINTER)

		call amovki (NULL, Memi[im], nims)
		call amovki (NULL, Memi[wcs], nims)
		call amovki (NULL, Memi[bpm], nims)

		# Open data structures and set average scale.
		scale = 0.
		do i = 1, nims {
		    stat = imtrgetim (extlist, i, Memc[image], SZ_FNAME)
		    tmp = immap (Memc[image], READ_ONLY, 0)
		    Memi[im+i-1] = tmp
		    mw = msc_openim (Memi[im+i-1], tmp)
		    Memi[wcs+i-1] = tmp
		    ct = msc_sctran (Memi[wcs+i-1], CT_LW, "logical",
			"world", 3)
		    ct = msc_sctran (Memi[wcs+i-1], CT_WL, "world",
			"logical", 3)
		    ct = msc_sctran (Memi[wcs+i-1], CT_WA, "world",
			 "astrometry", 3)
		    scale = scale + msc_wcsstatd (Memi[wcs+i-1], "scale")
		    Memd[crpix+2*i-2] = msc_wcsstatd (Memi[wcs+i-1], "crpix1")
		    Memd[crpix+2*i-1] = msc_wcsstatd (Memi[wcs+i-1], "crpix2")
		    if (usebpm) {
			tmp = yt_pmmap ("BPM", Memi[im+i-1],
			    Memc[bpmname], SZ_FNAME)
			Memi[bpm+i-1] = tmp
		    }
		}
		scale = scale / nims

		# Search for approximate shift.
		if (nsearch > 0 && search > 0.) {
		    # Sort by mref if possible.
		    if (nm > 0)
			call gqsort (Memi[sort], n, cm_compared, mref)

		    srch = nint (search / scale)

		    call cm_pixel (Memi[im], Memi[wcs], Memd[crpix], Memi[bpm],
			nims, Memd[xref], Memd[yref], xshift, yshift,
			theta, srch, 0.5, 2, Memi[imin], Memi[wcsin], Memd[xin],
			Memd[yin], n, verbose)

		    iferr (call cm_shift (Memi[im], Memi[wcs], Memd[crpix],
			nims, Memi[imin], Memd[xin], Memd[yin], Memi[sort],
			n, nsearch, srch, rsearch, xshft, yshft, t,
			"", verbose)) {
			srch = 2 * srch
		        call cm_shift (Memi[im], Memi[wcs], Memd[crpix], nims,
			    Memi[imin], Memd[xin], Memd[yin], Memi[sort],
			    n, nsearch, srch, rsearch, xshft, yshft, t,
			    "", verbose)
		    }
		    xshift = xshift + xshft
		    yshift = yshift + yshft
		    theta = theta + t

		    while (abs (xshft) > 0.8 * srch ||
			abs (yshft) > 0.8 * srch) { 
			call cm_pixel (Memi[im], Memi[wcs], Memd[crpix],
			    Memi[bpm], nims, Memd[xref], Memd[yref],
			    xshift, yshift, theta, srch, 0.5, 2, Memi[imin],
			    Memi[wcsin], Memd[xin], Memd[yin], n,
			    verbose)

			call cm_shift (Memi[im], Memi[wcs], Memd[crpix], nims,
			    Memi[imin], Memd[xin], Memd[yin], Memi[sort],
			    n, nsearch, srch, rsearch, xshft, yshft, t,
			    "", verbose)
			xshift = xshift + xshft
			yshift = yshift + yshft
			theta = theta + t
		    }
		}

		# Convert to pixel coordinates.
		call cm_pixel (Memi[im], Memi[wcs], Memd[crpix], Memi[bpm],
		    nims, Memd[xref], Memd[yref], xshift, yshift, theta,
		    nint(maxshift/scale), 0.0, 0, Memi[imin], Memi[wcsin],
		    Memd[xin], Memd[yin], n, verbose)

		# Sort by yin for I/O efficiency.
		call gqsort (Memi[sort], n, cm_compared, yin)

		# Center on coordinates.
		call cm_center (Memi[im], Memi[wcs], nims, Memi[imin],
		    Memd[xin], Memd[yin], Memi[sort], n, nfit, cbox,
		    maxshift, csig, cfrac, verbose, listcoords)

		# Compute the WCS adjustment.
		call  cm_geomap (Memi[imin], Memi[wcsin], Memd[xref],
		    Memd[yref], Memd[xin], Memd[yin], n, nfit, rms,
		    Memc[fitgeom], interactive, ifit, results, verbose, reject)

		# Close data structures before update.
		do i = 1, nims {
		    if (Memi[bpm+i-1] != NULL) {
		       call imunmap (Memi[bpm+i-1])
		       Memi[bpm+i-1] = NULL
		    }
		    if (Memi[wcs+i-1] != NULL) {
			call msc_close (Memi[wcs+i-1])
			Memi[wcs+i-1] = NULL
		    }
		    if (Memi[im+i-1] != NULL) {
			call imunmap (Memi[im+i-1])
			Memi[im+i-1] = NULL
		    }
		}

		# Update WCS if desired.
		if (update == YES && interactive == YES)
		    accept = btoi (clgetb ("accept"))
		if (accept == YES) {
		    call cnvdate (clktime(0), Memc[image], SZ_FNAME)
		    call sprintf (Memc[keyval], SZ_FNAME,
			"%s %.2f/%.2f %.3f/%.3f %.3f/%.3f")
			call pargstr (Memc[image])
			call pargd (results[1])
			call pargd (results[2])
			call pargd (results[3])
			call pargd (results[4])
			call pargd (results[5])
			call pargd (results[6])
		    mw = wcs_trans (results[1], results[2], results[3],
			results[4], results[5], results[6])
		    do i = 1, nims {
			stat = imtrgetim (extlist, i, Memc[image], SZ_FNAME)
			call wcs_adjust (Memc[image], mw, NO, 200, 4, 4, 4, 4)
			tmp = immap (Memc[image], READ_WRITE, 0)
			call imastr (tmp, "MSCCMATCH", Memc[keyval])
			call imunmap (tmp)
		    }
		    call mw_close (mw)
		    if (verbose == YES)
			call printf ("    Coordinate system updated.\n")

		    if (Memc[outcoords] != EOS) {
			call cm_updcoords (Memc[coords], Memc[outcoords],
			    Memd[xin])
			if (verbose == YES)
			    call printf ("    Coordinate list updated.\n")
		    }
		}
	    } then {
		call erract (EA_WARN)
		call eprintf ("ERROR: MSCCMATCH failed for %s\n")
		    call pargstr (Memc[mef])
	    }

	    # Close data structures in case of an error.
	    do i = 1, nims {
		if (bpm != NULL) {
		    if (Memi[bpm+i-1] != NULL)
		       call imunmap (Memi[bpm+i-1])
		}
		if (wcs != NULL) {
		    if (Memi[wcs+i-1] != NULL)
			call msc_close (Memi[wcs+i-1])
		}
		if (im != NULL) {
		    if (Memi[im+i-1] != NULL)
			call imunmap (Memi[im+i-1])
		}
	    }

	    call imtclose (extlist)
	    call sfree(sp1)
	}
	    
	call clpcls (outlist)
	call imtclose (input)
	call sfree (sp)
end


# CM_PIXEL -- Convert to pixel coordinates.

procedure cm_pixel (im, wcs, crpix, bpm, nims, xref, yref, xshift, yshift,
	theta, bpmbox, bpmfrac, bpmflag, imin, wcsin, xin, yin, n, verbose)

pointer	im[nims]	#I IMIO pointers
pointer	wcs[nims]	#I WCS pointers
double	crpix[2,nims]	#I Tangent point in pixels
pointer	bpm[nims]	#I BPM pointers
int	nims		#I Number of images
double	xref[n]		#I X reference coordinate
double	yref[n]		#I Y reference coordinate
double	xshift		#I X shift in pixels
double	yshift		#I Y shift in pixels
double	theta		#I rotation in radians
int	bpmbox		#I BPM check box
real	bpmfrac		#I Maximum fraction to be rejected by mask
int	bpmflag		#I BPM flag value (pos to select neg to exclude)
pointer	imin[n]		#O IMIO pointer assigned to each coordinate
pointer	wcsin[n]	#O WCS pointer assigned to each coordinate
double	xin[n]		#O X pixel coordinate for reference coordinate
double	yin[n]		#O Y pixel coordinate for reference coordinate
int	n		#I Number of coordinates
int	verbose		#I Verbose?

bool	sat
int	i, j, bpmbx, nofb, nbpm, c1, c2, l1, l2, c, l
double	x, y, sint, cost
pointer	buf, imgs2s()

begin
	if (verbose == YES) {
	    call printf ("    %d input coordinates\n")
		call pargi (n)
	}

	sint = sin (theta)
	cost = cos (theta)
	bpmbx = bpmbox

	repeat {
	    nofb = 0
	    nbpm = 0
	    do j = 1, n {
		imin[j] = NULL
		wcsin[j] = NULL
		xin[j] = INDEFD
		yin[j] = INDEFD
		do i = 1, nims {
		    call msc_c2trand (wcs[i], CT_WL, xref[j], yref[j], x, y)
		    x = (x-crpix[1,i])*cost - (y-crpix[2,i])*sint + crpix[1,i]
		    y = (x-crpix[1,i])*sint + (y-crpix[2,i])*cost + crpix[2,i]
		    x = x + xshift
		    y = y + yshift
		    if (x>=1 && x<=IM_LEN(im[i],1) &&
			y>=1 && y<=IM_LEN(im[i],2))
			break
		}
		if (i > nims) {
		    nofb = nofb + 1
		    next
		}
		if (!IS_INDEFI(bpmbx) && bpm[i] != NULL) {
		    c1 = max (1, nint (x) - bpmbx)
		    c2 = min (IM_LEN(im[i],1), nint (x) + bpmbx)
		    l1 = max (1, nint (y) - bpmbx)
		    l2 = min (IM_LEN(im[i],2), nint (y) + bpmbx)
		    buf = imgs2s (bpm[i], c1, c2, l1, l2)
		    sat = false
		    do l = l1, l2 {
			do c = c1, c2 {
			   if (Mems[buf] != 0) {
			       if (bpmflag == 0 || Mems[buf] == bpmflag) {
				   sat = true
				   break
				}
			    }
			    buf = buf + 1
			}
			if (sat)
			    break
		    }
		    if (sat) {
			nbpm = nbpm + 1
			next
		    }
		}
		imin[j] = im[i]
		wcsin[j] = wcs[i]
		xin[j] = x
		yin[j] = y
	    }

	    bpmbx = INDEFI
	} until (n-nofb-nbpm >= bpmfrac*(n-nofb))

	if (verbose == YES) {
	    if (nofb > 0) {
		call printf ("    %d/%d coordinates out of bounds\n")
		    call pargi (nofb)
		    call pargi (n)
	    }
	    if (nbpm > 0) {
		call printf ("    %d/%d coordinates masked\n")
		    call pargi (nbpm)
		    call pargi (n-nofb)
	    }
	}

	if (n - nofb - nbpm == 0)
	    call error (1, "No coordinates")
end


define	CM_SHIFT_SAMP	50	# Number of sample points per axis for sorting
define	CM_SHIFT_THRESH	0.9	# Threshold for voting

# CM_SHIFT -- Find shift.

procedure cm_shift (im, wcs, crpix, nims, imin, xin, yin, sort, ncoords,
	nsearch, search, rsearch, xshift, yshift, theta, vote, verbose)

pointer	im[nims]	#I IMIO pointers
pointer	wcs[nims]	#I WCS pointers
double	crpix[2,nims]	#I Tangent point in pixels
int	nims		#I Number of images
pointer	imin[ncoords]	#I IMIO pointer assigned to each coordinate
double	xin[ncoords]	#I X target coordinate for reference coordinate
double	yin[ncoords]	#I Y target coordinate for reference coordinate
int	sort[ncoords]	#I Sort index
int	ncoords		#I Number of coordinates
int	nsearch		#I Number of brightest objects to use
int	search		#I Search radius (pixels)
double	rsearch		#I Rotation search radius (degrees)
double	xshift		#O X shift in pixels
double	yshift		#O Y shift in pixels
double	theta		#O Rotation in radians
char	vote[ARB]	#O Vote array output name
int	verbose		#I Verbose?

int	i, j, k, c, l
int	nc, nl, nt, npix, nsamp, nwork, c1, c2, l1, l2, nfound
real	maxval, val, sum
real	r, rmax, dsint, sint, cost, c0, l0, ck0, lk0, ck, lk
pointer	sp, votes, work, buf, ptr1, ptr2, imv

real	asokr()
pointer	immap(), imgs2r(), imps2r(), imps3r()

errchk	immap

begin
	if (verbose == YES) {
	    call printf ("    search using up to %d objects:\n")
		call pargi (nsearch)
	}

	# Determine maximum radius from tangent point.
	nfound = 0
	rmax = 0
	for (i=1; i<=ncoords && nfound IM_LEN(im[k],1) ||
		l1 < 1 || l2 > IM_LEN(im[k],2))
		next
	    nfound = nfound + 1

	    r = sqrt ((xin[j]-crpix[1,k])**2 + (yin[j]-crpix[2,k])**2)
	    rmax = max (r, rmax)
	}

	# Set memory.
	dsint = max (10, search/10) / rmax
	nc = 2 * search + 1
	nl = 2 * search + 1
	nt = 2 * nint (min (real(0.8*search/rmax), real(DEGTORAD(rsearch))) /
	    dsint) + 1
	npix = nc * nl
	nsamp = max (1, nc / CM_SHIFT_SAMP)
	nwork = (nc / nsamp + 1) * (nl / nsamp + 1)

	call smark (sp)
	call salloc (votes, npix * nt, TY_REAL)
	call salloc (work, nwork, TY_REAL)

	# Accumulate data.
	call aclrr (Memr[votes], npix * nt)
	nfound = 0
	for (i=1; i<=ncoords && nfound IM_LEN(im[k],1) ||
		l1 < 1 || l2 > IM_LEN(im[k],2))
		next
	    nfound = nfound + 1

	    # Get data.
	    buf = imgs2r (im[k], c1, c2, l1, l2)
	    c0 = crpix[1,k]
	    l0 = crpix[2,k]

	    # Subsample for finding threshold.
	    ptr2 = work
	    do l = l1, l2, nsamp {
		ptr1 = buf + (l - l1) * nc
		do c = c1, c2, nsamp {
		    Memr[ptr2] = Memr[ptr1]
		    ptr1 = ptr1 + 1
		    ptr2 = ptr2 + 1
		}
	    }
	    maxval = asokr (Memr[work], nwork, nint (CM_SHIFT_THRESH * nwork))

	    # Accumulate.  Optimize the calculation and accumulation.
	    ptr1 = votes - 1
	    do k = 1, nt {
		if (k == nt / 2 + 1) {
		    ptr2 = buf - 1
		    do l = l1, l2 {
			do c = c1, c2 {
			    ptr1 = ptr1 + 1
			    ptr2 = ptr2 + 1
			    val = Memr[ptr2]
			    if (val > maxval)
				Memr[ptr1] = Memr[ptr1] + 1
			}
		    }
		} else {
		    sint = (k - 1 - (nt - 1) / 2.) * dsint 
		    cost = sqrt (1. - sint * sint)
		    ck0 = (c1-c0) * cost - (l1-l0) * sint + c0
		    lk0 = (c1-c0) * sint + (l1-l0) * cost + l0
		    ck0 = ck0 - cost + sint
		    lk0 = lk0 - sint - cost
		    do l = l1, l2 {
			ck0 = ck0 - sint
			lk0 = lk0 + cost
			ck = ck0
			lk = lk0
			do c = c1, c2 {
			    ck = ck + cost
			    lk = lk + sint
			    ptr1 = ptr1 + 1
			    if (ck < c1 || ck > c2 || lk < l1 || lk > l2)
				next
			    ptr2 = buf + nint (lk - l1) * nc + nint (ck - c1)
			    val = Memr[ptr2]
			    if (val > maxval)
				Memr[ptr1] = Memr[ptr1] + 1
			}
		    }
		}
	    }
	}

	# Output vote array if desired.
	if (vote[1] != EOS) {
	    imv = immap (vote, NEW_IMAGE, 0)
	    IM_NDIM(imv) = 3
	    IM_LEN(imv,1) = nc
	    IM_LEN(imv,2) = nl
	    IM_LEN(imv,3) = nt
	    IM_PIXTYPE(imv) = TY_REAL
	    if (nt > 1)
		call amovr (Memr[votes], Memr[imps3r(imv,1,nc,1,nl,1,nt)],
		    npix*nt)
	    else {
		IM_NDIM(imv) = 2
		call amovr (Memr[votes], Memr[imps2r(imv,1,nc,1,nl)], npix)
	    }
	    call imunmap (imv)
	}

	# Find centroids above half the votes.
	maxval = nfound / 2
	ptr1 = votes
	xshift = 0
	yshift = 0
	theta = 0
	sum = 0
	do k = 1, nt {
	    sint = (k - 1 - (nt - 1) / 2.) * dsint 
	    do l = 1, nl {
		do c = 1, nc {
		    val = Memr[ptr1] - maxval
		    ptr1 = ptr1 + 1
		    if (val <= 0.)
			next
		    xshift = xshift + c * val
		    yshift = yshift + l * val
		    theta = theta + sint * val
		    sum = sum + val
		}
	    }
	}
	if (sum == 0)
	   call error (1, "Automatic search failed")

	xshift = xshift / sum - search
	yshift = yshift / sum - search
	theta = asin (theta / sum)

	if (verbose == YES) {
	    call printf ("    search found offsets of (%.0f, %.0f) pixels")
		call pargd (xshift)
		call pargd (yshift)
	    call printf (" and rotation %.2f degrees\n")
		call pargd (RADTODEG (theta))
	}

	call sfree (sp)
end


# CM_CENTER -- Find and center on objects near reference coordinates.

procedure cm_center (im, wcs, nims, imin, xin, yin, sort, n, nfit, cbox,
	maxshift, csig, cfrac, verbose, listcoords)

pointer	im[nims]	#I IMIO pointers
pointer	wcs[nims]	#I WCS pointers
int	nims		#I Number of images
pointer	imin[n]		#I IMIO pointer assigned to each coordinate
double	xin[n]		#I X target coordinate for reference coordinate
double	yin[n]		#I Y target coordinate for reference coordinate
int	sort[n]		#I Sort index
int	n		#I Number of coordinates
int	nfit		#I Minimum number to centroid
int	cbox		#I Centering box (pixels)
double	maxshift	#I Maximum shift (arcsec)
double	csig		#I Maximum centering uncertainty (arcsec)
double	cfrac		#I Minimum fraction of accepted centers
int	verbose		#I Verbose?
int	listcoords	#I List coordinates?

int	i, j, k, ncenter, nfail, fd, stat
double	x, y, scale, xshift, yshift, xerr, yerr
pointer	sp, image, cmd, temp1

int	open(), fscan(), nscan()
double	msc_wcsstatd()
errchk	open

begin
	call smark (sp)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (cmd, SZ_CMD, TY_CHAR)
	call salloc (temp1, SZ_FNAME, TY_CHAR)

	call mktemp ("tmp$iraf", Memc[temp1], SZ_FNAME)

	# Center coordinates for each image in turn.
	ncenter = 0
	nfail = 0
	do i = 1, nims {
	    fd = NULL
	    do k = 1, n {
		j = sort[k] + 1
		if (imin[j] != im[i])
		    next
		if (fd == NULL)
		    fd = open (Memc[temp1], NEW_FILE, TEXT_FILE)
		call fprintf (fd, "%g %g\n")
		    call pargd (xin[j])
		    call pargd (yin[j])
		ncenter = ncenter + 1
	    }
	    if (fd == NULL)
		next
	    call close (fd)

	    # Set scale to convert maxshift to pixels.
	    call imstats (im[i], IM_IMAGENAME, Memc[image], SZ_FNAME)
	    scale = msc_wcsstatd (wcs[i], "scale")

	    # Execute centering command.
	    call sprintf (Memc[cmd], SZ_CMD,
		"msccntr %s %s cbox=%d maxshift=%g")
		call pargstr (Memc[image])
		call pargstr (Memc[temp1])
		call pargi (cbox)
		call pargd (maxshift/scale)
	    call clcmdw (Memc[cmd])

	    # Update with the centered coordinates.  Print results if needed.
	    fd = open (Memc[temp1], READ_ONLY, TEXT_FILE)
	    do k = 1, n {
		j = sort[k] + 1
		if (imin[j] != im[i])
		    next
		stat = fscan (fd)
		call gargd (x)
		call gargd (y)
		call gargd (xshift)
		call gargd (yshift)
		call gargd (xerr)
		call gargd (yerr)
		call gargi (stat)
		call gargwrd (Memc[cmd], SZ_CMD)
		if (nscan() < 8) {
		    imin[j] = NULL
		    next
		}
		if (verbose == YES && listcoords == YES) {
		    call printf (
			"      %s %8.2f %8.2f %6.2f %6.2f %4.2f %4.2f")
			call pargstr (Memc[image])
			call pargd (x)
			call pargd (y)
			call pargd (xshift)
			call pargd (yshift)
			call pargd (xerr)
			call pargd (yerr)
		    if (stat != 0) {
			call printf (" **%s**")
			    call pargstr (Memc[cmd])
		    }
		    call printf ("\n")
		}
		if (stat != 0 || IS_INDEFD(xerr) || IS_INDEFD(yerr)) {
		    imin[j] = NULL
		    xin[j] = INDEFD
		    yin[j] = INDEFD
		    nfail = nfail + 1
		} else if (sqrt (xerr**2 + yerr**2) > csig / scale) {
		    imin[j] = NULL
		    xin[j] = INDEFD
		    yin[j] = INDEFD
		    nfail = nfail + 1
		} else {
		    xin[j] = x
		    yin[j] = y
		}
	    }
	    call close (fd)

	    call delete (Memc[temp1])
	}

	if (verbose == YES) {
	    call printf ("    %d/%d not centroided\n")
		call pargi (nfail)
		call pargi (ncenter)
	}

	if (nfail > cfrac * ncenter) {
	    call sprintf (Memc[cmd], SZ_CMD,
		"Too many coordinates failed to centroid: %d/%d < %.2f")
		    call pargi (nfail)
		    call pargi (ncenter)
		    call pargd (cfrac)
	    call error (1, Memc[cmd])
	}

	call sfree (sp)
end


# CM_GEOMAP -- Compute shift, scale, and rotation.

procedure cm_geomap (imin, wcsin, xref, yref, xin, yin, n,
	nfit, rms, fitgeom, interactive, ifit, results, verbose, reject)

pointer	imin[n]		#I IMIO pointer assigned to each coordinate
pointer	wcsin[n]	#I WCS pointer assigned to each coordinate
double	xref[n]		#I X reference coordinate
double	yref[n]		#I Y reference coordinate
double	xin[n]		#I X target coordinate for reference coordinate
double	yin[n]		#I Y target coordinate for reference coordinate
int	n		#I Number of coordinates
int	nfit		#I Minimum number of coordinates for fit
double	rms		#I Maximum rms to accept
char	fitgeom[ARB]	#I Fit geometry
int	interactive	#I Interactive?
int	ifit		#I Interactive fit?
double	results[8]	#O Results
int	verbose		#I Verbose?
real	reject 		#I sigma rejection

int	i, nfound, fd
double	x1, y1, x2, y2, xavg, yavg
pointer	sp, temp1, temp2, cmd, graphics, cursor

int	open(), stropen(), strdic(), fscan(), nscan()
errchk	open

begin
	call smark (sp)
	call salloc (temp1, SZ_FNAME, TY_CHAR)
	call salloc (temp2, SZ_FNAME, TY_CHAR)
	call salloc (graphics, SZ_FNAME, TY_CHAR)
	call salloc (cursor, SZ_FNAME, TY_CHAR)
	call salloc (cmd, SZ_CMD, TY_CHAR)

	call mktemp ("tmp$iraf", Memc[temp1], SZ_FNAME)
	call mktemp ("tmp$iraf", Memc[temp2], SZ_FNAME)

	# Convert input and centered coordinates to astrometry coordinates.
	nfound = 0
	do i = 1, n
	    if (imin[i] != NULL)
		nfound = nfound + 1

	if (nfound < nfit) {
	    call sprintf (Memc[cmd], SZ_CMD,
		"Too few coordinates to fit: %d/%d")
		    call pargi (nfound)
		    call pargi (nfit)
	    call error (1, Memc[cmd])
	}

	if (verbose == YES)
	    call printf ("    Fit coordinates:\n")

	fd = open (Memc[temp1], NEW_FILE, TEXT_FILE)
	xavg = 0.; yavg = 0.
	do i = 1, n {
	    if (imin[i] == NULL)
		next
	    call msc_c2trand (wcsin[i], CT_WA, xref[i], yref[i], x1, y1)
	    call msc_c2trand (wcsin[i], CT_LW, xin[i], yin[i], x2, y2)
	    call msc_c2trand (wcsin[i], CT_WA, x2, y2, x2, y2)
	    call fprintf (fd, "%g %g %g %g\n")
		call pargd (x1)
		call pargd (y1)
		call pargd (x2)
		call pargd (y2)
	    xavg = xavg + x2 - x1
	    yavg = yavg + y2 - y1
	}
	call close (fd)

	call clgstr ("graphics", Memc[graphics], SZ_LINE)
	call clgstr ("cursor", Memc[cursor], SZ_LINE)
	fd = stropen (Memc[cmd], SZ_CMD, NEW_FILE)
	call fprintf (fd,
	    "geomap input=%s database=%s transforms='' results=''")
	    call pargstr (Memc[temp1])
	    call pargstr (Memc[temp2])
	call fprintf (fd, " xmin=INDEF xmax=INDEF ymin=INDEF ymax=INDEF")
	call fprintf (fd, " fitgeom=%s func=polynomial")
	    if (nfound > 1)
		call pargstr (fitgeom)
	    else
		call pargstr ("shift")
	call fprintf (fd, " xxo=2 xyo=2 xxt=half yxo=2 yyo=2 yxt=half")
	call fprintf (fd, " maxiter=%d reject=%g calc=double verb-")
	    if (reject <= 0. || IS_INDEF(reject)) {
		call pargi (0)
		call pargr (3.)	
	    } else {
		call pargi (4)
		call pargr (reject)	
	    }
	call fprintf (fd, " inter=%b graphics=%s cursor=\"%s\"")
	    call pargb ((ifit==YES&&(interactive==YES||Memc[cursor]!=EOS)))
	    call pargstr (Memc[graphics])
	    call pargstr (Memc[cursor])
	if (Memc[cursor] != EOS)
	    call fprintf (fd, " > dev$null")
	call close (fd)

	call clcmdw (Memc[cmd])

	fd = open (Memc[temp2], READ_ONLY, TEXT_FILE)
	while (fscan (fd) != EOF) {
	    call gargwrd (Memc[cmd], SZ_CMD)
	    if (nscan() != 1)
		next
	    i = strdic (Memc[cmd], Memc[cmd], SZ_CMD,
		"|xshift|yshift|xmag|ymag|xrotation|yrotation|xrms|yrms|")
	    if (i == 0)
		next
	    call gargd (results[i])
	    if (i == 5 || i == 6)
		if (results[i] > 180.)
		    results[i] = results[i] - 360.
	}
	call close (fd)

	if (verbose == YES || interactive == YES) {
	    call printf ("      input number of coordinates = %d\n")
		call pargi (nfound)
	    call printf ("      average shift = (%.2f, %.2f) arcsec\n")
		call pargd (xavg / nfound)
		call pargd (yavg / nfound)
	    call printf ("      tangent point shift = (%.2f, %.2f) arcsec\n")
		call pargd (results[1])
		call pargd (results[2])
	    call printf ("      fractional scale change = (%.3f, %.3f)\n")
		call pargd (results[3])
		call pargd (results[4])
	    call printf ("      axis rotation = (%.3f, %.3f) degrees\n")
		call pargd (results[5])
		call pargd (results[6])
	    call printf ("      rms = (%.3f, %.3f) arcsec\n")
		call pargd (results[7])
		call pargd (results[8])
	}

	call delete (Memc[temp1])
	call delete (Memc[temp2])

	if (interactive == NO && rms < max (results[7], results[8])) {
	    call sprintf (Memc[cmd], SZ_CMD,
		"RMS of fit is too large: %.3f > %.3f")
		call pargd (max (results[7], results[8]))
		call pargd (rms)
	    call error (1, Memc[cmd])
	}

	call sfree (sp)
end


# CM_UPDCOORDS -- Update coordinate file.

procedure cm_updcoords (incoords, outcoords, flags)

char	incoords[ARB]		#I Input coordinate filename
char	outcoords[ARB]		#I Output coordinate filename
double	flags[ARB]		#I Rejected points are given as INDEFD

int	fdin, fdout, n
double	x, y
pointer	sp, line, fname

bool	streq()
int	open(), getline(), nscan()
errchk	open

begin
	# Do nothing if no output coordinate file is specified.
	if (outcoords[1] == EOS)
	    return

	call smark (sp)
	call salloc (line, SZ_LINE, TY_CHAR)

	# Open coordinate files.
	if (streq (incoords, outcoords)) {
	    call salloc (fname, SZ_FNAME, TY_CHAR)
	    call mktemp ("tmp$iraf", Memc[fname], SZ_FNAME)
	    fdout = open (Memc[fname], NEW_FILE, TEXT_FILE)
	} else {
	    fname = NULL
	    fdout = open (outcoords, NEW_FILE, TEXT_FILE)
	}
	fdin = open (incoords, READ_ONLY, TEXT_FILE)

	# Copy input file to output file with rejected coordinates removed.
	n = 0
	while (getline (fdin, Memc[line]) != EOF) {
	    call sscan (Memc[line])
	    call gargd (x)
	    call gargd (y)
	    if (nscan() < 2)
		call putline (fdout, Memc[line])
	    else {
		n = n + 1
		if (!IS_INDEFD(flags[n]))
		    call putline (fdout, Memc[line])
	    }
	}

	# Finish up.
	call close (fdout)
	call close (fdin)
	if (streq (incoords, outcoords)) {
	    call delete (incoords)
	    call rename (Memc[fname], outcoords)
	}
	call sfree (sp)
end


# CM_COMPARED --  Compare values in double array given by pointer.

int procedure cm_compared (arg, x1, x2)

pointer	arg		#I pointer to data
int	x1		#I comparison index
int	x2		#I comparison index

double	y1, y2

begin
	y1 = Memd[arg+x1]
	y2 = Memd[arg+x2]

	if (y1 == y2)
	    return (0)
	else if (IS_INDEFD(y1))
	    return (1)
	else if (IS_INDEF(y2))
	    return (-1)
	else if (y1 < y2)
	    return (-1)
	else
	    return (1)
end


# CM_GETCOORDS -- Get coordinates from a file or a command.

procedure cm_getcoords (image, coords, xptr, yptr, n, mptr, nm)

char	image[ARB]		#I Image to which coordinates apply
char	coords[ARB]		#I Coordinate specification
pointer	xptr			#O Pointer to x coordinates
pointer	yptr			#O Pointer to y coordinates
int	n			#O Number of coordinates
pointer	mptr			#O Pointer to magnitudes
int	nm			#O Number of magnitudes

int	i, j, fd
double	x, y, m
pointer	sp, fname, cmd

bool	strne()
int	strlen(), open(), fscan(), nscan()
errchk	open

begin
	call smark (sp)
	call salloc (fname, SZ_FNAME, TY_CHAR)
	call salloc (cmd, SZ_LINE, TY_CHAR)

	# Set the coordinate file.
	j = 0
	if (coords[1] == '!') {
	    call mktemp ("tmp", Memc[fname], SZ_FNAME)
	    for (i=2; coords[i] != EOS; i=i+1) {
		if (coords[i] == '$') {
		    i = i + 1
		    if (coords[i] == 'I')
			call strcpy (image, Memc[cmd+j], SZ_LINE-j)
		    else if (coords[i] == 'C')
			call strcpy (Memc[fname], Memc[cmd+j], SZ_LINE-j)
		    else
			call error (1,
			   "Syntax error in coordinate specification")
		    j = strlen (Memc[cmd])
		} else {
		    Memc[cmd+j] = coords[i]
		    j = j + 1
		}
	    }
	    call clcmdw (Memc[cmd])
	} else
	    call strcpy (coords, Memc[fname], SZ_FNAME)

	# Get coordinates.
	n = 0
	nm = 0
	fd = open (Memc[fname], READ_ONLY, TEXT_FILE)
	while (fscan (fd) != EOF) {
	    call gargd (x)
	    call gargd (y)
	    call gargd (m)
	    if (nscan() < 2)
		next
	    if (nscan() < 3)
		m = INDEFD
	    if (n == 0) {
		call malloc (xptr, 100, TY_DOUBLE)
		call malloc (yptr, 100, TY_DOUBLE)
		call malloc (mptr, 100, TY_DOUBLE)
	    } else if (mod (n, 100) == 0) {
		call realloc (xptr, n+100, TY_DOUBLE)
		call realloc (yptr, n+100, TY_DOUBLE)
		call realloc (mptr, n+100, TY_DOUBLE)
	    }
	    Memd[xptr+n] = x * 15.
	    Memd[yptr+n] = y
	    Memd[mptr+n] = m
	    n = n + 1
	    if (!IS_INDEFD(m))
		nm = nm + 1
	}
	call close (fd)

	if (strne (coords, Memc[fname]))
	    call delete (Memc[fname])
	call sfree (sp)
end
mscred-5.05-2018.07.09/src/t_mscctran.x000066400000000000000000000421611332166314300171070ustar00rootroot00000000000000include	
include 
include 
include 
include 
include 
include 

# Define some limits on the input file

define	MAX_FIELDS	100		# maximum number of fields in the list
define	TABSIZE		8		# spacing of the tab stops

# Define the supported units

define	WT_UNITSTR	"|hours|native|"
define	WT_UHOURS	1
define	WT_UNATIVE	2

define	WT_WCSSTR	"|logical|tv|physical|world|astrometry|"
define	WT_LOGICAL	1
define	WT_TV		2
define	WT_PHYSICAL	3
define	WT_WORLD	4
define	WT_ASTROM	5

# T_MSCCTRAN -- Transform a list of image coordinates from one coordinate 
# system to another using world coordinate system information stored in
# the header of a reference image.

procedure t_mscctran()

bool	verbose
int	i, csp, imlist,inlist, outlist, limlist, linlist, loutlist
int	icl, ocl, ndim, wcsndim, ncolumns, nunits, inwcs, outwcs, min_sigdigits
pointer	sp, image, columns, units, iwcs, owcs, fmtstr, fmtptrs
pointer	str, name, im, mw, ct, wcs

bool	clgetb()
int	imtopenp(), imtlen(), imtgetim(), fntopnb(), fntlenb(), fntgfnb()
int	open(), mw_stati(), wt_getlabels(), ctoi(), strdic(), clgeti(), nscan()
pointer	immap(), msc_openim(), msc_sctran()
errchk	msc_openim(), mw_gwattrs(), msc_sctran()

begin
	call smark (sp)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (columns, IM_MAXDIM, TY_INT)
	call salloc (units, IM_MAXDIM, TY_INT)
	call salloc (iwcs, SZ_FNAME, TY_CHAR)
	call salloc (owcs, SZ_FNAME, TY_CHAR)
	call salloc (fmtstr, SZ_FNAME, TY_CHAR)
	call salloc (fmtptrs, IM_MAXDIM, TY_POINTER)
	call salloc (str, SZ_FNAME, TY_CHAR)
	call salloc (name, SZ_FNAME, TY_CHAR)

	# Get the input and output image and file lists.
	imlist = imtopenp ("image")
	limlist = imtlen (imlist)
	call clgstr ("input", Memc[str], SZ_FNAME)
	inlist = fntopnb (Memc[str], NO)
	linlist = fntlenb (inlist)
	call clgstr ("output", Memc[str], SZ_FNAME)
	if (Memc[str] == EOS)
	    call strcpy ("STDOUT", Memc[str], SZ_FNAME)
	outlist = fntopnb (Memc[str], NO)
	loutlist = fntlenb (outlist)

	# Get the input coordinate file format.
	call clgstr ("columns", Memc[str], SZ_FNAME)
	ncolumns = 0
	csp = 1
	while (wt_getlabels (Memc[str], csp, Memc[name], SZ_FNAME) != EOF) {
	    i = 1
	    if (ctoi(Memc[name], i, Memi[columns+ncolumns]) <= 0)
		break
	    ncolumns = ncolumns + 1
	}

	# Get the input coordinate units. Fill in any missing information
	# with native units
	call clgstr ("units", Memc[str], SZ_FNAME)
	nunits = 0
	csp = 1
	while (wt_getlabels (Memc[str], csp, Memc[name], SZ_FNAME) != EOF) {
	    i = strdic (Memc[name], Memc[name], SZ_FNAME, WT_UNITSTR)
	    if (i <= 0)
		break
	    Memi[units+nunits] = i
	    nunits = nunits + 1
	}
	do i = nunits + 1, IM_MAXDIM
	    Memi[units+i-1] = WT_UNATIVE

	# Get the input and output transform.
	call clgstr ("inwcs", Memc[iwcs], SZ_FNAME)
	inwcs = strdic (Memc[iwcs], Memc[iwcs], SZ_FNAME, WT_WCSSTR)
	call clgstr ("outwcs", Memc[owcs], SZ_FNAME)
	outwcs = strdic (Memc[owcs], Memc[owcs], SZ_FNAME, WT_WCSSTR)

	# Get the format strings and minimum number of significant digits.
	call clgstr ("formats", Memc[fmtstr], SZ_FNAME)
	min_sigdigits = clgeti ("min_sigdigits")

	# Get the remaining parameters.
	verbose = clgetb ("verbose")

	# Check that the image and output list lengths match. The number
	# of input coordinate lists must be 1 or equal to the number of
	# input images.
	if (limlist < 1 || (linlist > 1 && linlist != limlist)) {
	    call imtclose (imlist)
	    call fntclsb (inlist)
	    call fntclsb (outlist)
	    call error (0,
	        "Incompatable image and input coordinate list lengths.")
	}

	# Check that the image and output list lengths match. The number
	# of output coordinate lists must be 1 or equal to the number of
	# input images.
	if (loutlist > 1 && loutlist != limlist) {
	    call imtclose (imlist)
	    call fntclsb (inlist)
	    call fntclsb (outlist)
	    call error (0,
	        "Incompatable image and output coordinate list lengths.")
	}

	# Loop over the input images.
	while (imtgetim (imlist, Memc[image], SZ_FNAME) != EOF) {

	    # Open the input image.
	    im = immap (Memc[image], READ_ONLY, 0)
	    ndim = IM_NDIM(im)

	    # Open the input coordinate file.
	    if (linlist <= 0)
	        icl = NULL
	    else if (fntgfnb (inlist, Memc[str], SZ_FNAME) != EOF)
	        icl = open (Memc[str], READ_ONLY, TEXT_FILE)
	    else 
		call seek (icl, BOF)

	    # Open the output coordinate file.
	    if (fntgfnb (outlist, Memc[str], SZ_FNAME) != EOF) {
	        ocl = open (Memc[str], NEW_FILE, TEXT_FILE)
		if (ocl == STDOUT)
		    call fseti (ocl, F_FLUSHNL, YES)
	    }

	    # Print optional banner string.
	    if (verbose) {
		call fprintf (ocl, "\n# Image: %s  Wcsin: %s Wcsout: %s\n")
		    call pargstr (Memc[image])
		    call pargstr (Memc[iwcs])
		    call pargstr (Memc[owcs])
	    }

	    # Set up the coordinate transform.
	    mw = NULL
	    iferr {

	        mw = msc_openim (im, wcs)

		call mw_seti (mw, MW_USEAXMAP, NO)
		if (inwcs == WT_TV && outwcs == WT_TV)
		    ct = msc_sctran (wcs, 1, "logical", "logical", 0)
		else if (inwcs == WT_TV)
		    ct = msc_sctran (wcs, 1, "logical", Memc[owcs], 0)
		else if (outwcs == WT_TV)
		    ct = msc_sctran (wcs, 1, Memc[iwcs], "logical", 0)
		else
		    ct = msc_sctran (wcs, 1, Memc[iwcs], Memc[owcs], 0)
		wcsndim = mw_stati (mw, MW_NPHYSDIM)

		call sscan (Memc[fmtstr])
		do i = 1, IM_MAXDIM {
	    	    call malloc (Memi[fmtptrs+i-1], SZ_FNAME, TY_CHAR)
		    call gargwrd (Memc[Memi[fmtptrs+i-1]], SZ_FNAME)
		    if (nscan() != i || Memc[Memi[fmtptrs+i-1]] == EOS) {
			if (outwcs == WT_WORLD || outwcs == WT_ASTROM) {
			    iferr (call mw_gwattrs (mw, i, "format",
			        Memc[Memi[fmtptrs+i-1]], SZ_FNAME))
			        Memc[Memi[fmtptrs+i-1]] = EOS
			} else
			    Memc[Memi[fmtptrs+i-1]] = EOS
		    }
		}

	    } then {

		call erract (EA_WARN)
		if (mw != NULL)
		    call msc_close (wcs)
		mw = NULL
		wcs = NULL
		ct = NULL
	    }

	    # Check that the transform is valid.
	    if (ct == NULL) {

		# Skip the image if the transform is undefined.
		if (verbose) {
		    call fprintf (ocl,
		        "# \tSkipping: Unable to compile requested transform\n")
		}

	    # For input or output tv coordinates the image must be 2D
	    } else if (ndim != 2 && (inwcs == WT_TV || outwcs == WT_TV)) {

		# Skip the image if the transform is undefined.
		if (verbose) {
		    call fprintf (ocl,
		    "# \tSkipping: Image must be 2D for wcs type tv\n")
		}

	    # Check that the number of input columns is enough for images.
	    } else if ((ncolumns < ndim) || (ncolumns < wcsndim && inwcs !=
	        WT_LOGICAL && inwcs != WT_TV)) {

		if (verbose) {
		    call fprintf (ocl,
		        "# \tSkipping: Too few input coordinate columns\n")
		}

	    } else {

	        # Check the dimension of the wcs versus the dimension of the
	        # image and issue a warning if dimensional reduction has taken
	        # place.
	        if (wcsndim > ndim) {
		    if (verbose) {
		        call fprintf (ocl,
		        "# \tWarning: Image has been dimensionally reduced\n")
		    }
	        }
	        if (verbose) {
		    call fprintf (ocl, "\n")
	        }

		# Transform the coordinate file.
		call wt_transform (im, icl, ocl, Memi[columns], Memi[units],
		    ndim, inwcs, outwcs, mw, ct, wcs, Memi[fmtptrs], wcsndim,
		    min_sigdigits)

	    }

	    # Free the format pointers.
	    do i = 1, IM_MAXDIM
	        call mfree (Memi[fmtptrs+i-1], TY_CHAR)

	    # Close the input image.
	    if (mw != NULL)
		call msc_close (wcs)
	    call imunmap (im)

	    # Close the input coordinate file if it is not going to be used.
	    if (linlist == limlist)
		call close (icl)

	    # Close the output coordinate file if it is not going to be
	    # appended to.
	    if (loutlist == limlist)
		call close (ocl)
	}

	# Close the input coordinate file
	if (linlist > 0 && linlist < limlist)
	    call close (icl)
	if (loutlist < limlist)
	    call close (ocl)

	call imtclose (imlist)
	call fntclsb (inlist)
	call fntclsb (outlist)

	call sfree (sp)
end


# WT_TRANSFORM -- Transform the input coordinates from the input coordinate
# system to the output coordinate system.

procedure wt_transform (im, icl, ocl, columns, units, ndim, inwcs, outwcs, mw,
	ct, wcs, fmtptrs, wcsndim, min_sigdigits)

pointer	im			#I the input image descriptor
int	icl			#I the input coordinate file descriptor
int	ocl			#I the output coordinate file descriptor
int	columns[ARB]		#I the input coordinate columns
int	units[ARB]		#I the input coordinate units
int	ndim			#I the number of input coordinates
int	inwcs			#I the input wcs type
int	outwcs			#I the output wcs type
pointer	mw			#I the wcs descriptor
pointer	ct			#I the pointer to the compiled transformation
pointer	wcs			#I the database enhanced pointer
pointer	fmtptrs[ARB]		#I the array of format pointers
int	wcsndim			#I the dimensions of the wcs
int	min_sigdigits		#I the minimum number of significant digits

int	nline, ip, nread, nwrite, max_fields, nfields, offset
pointer	sp, inbuf, linebuf, field_pos, outbuf, voff, vstep, paxno, laxno, incoo
pointer	lincoo, outcoo, nsig
int	getline(), li_get_numd()

begin
	# Allocate working space.
	call smark (sp)
	call salloc (inbuf, SZ_LINE, TY_CHAR)
	call salloc (linebuf, SZ_LINE, TY_CHAR)
	call salloc (field_pos, MAX_FIELDS, TY_INT)
	call salloc (outbuf, SZ_LINE, TY_CHAR)

	call salloc (voff, wcsndim, TY_DOUBLE)
	call salloc (vstep, wcsndim, TY_DOUBLE)
	call salloc (paxno, wcsndim, TY_INT)
	call salloc (laxno, wcsndim, TY_INT)
	call salloc (incoo, wcsndim, TY_DOUBLE)
	call salloc (lincoo, wcsndim, TY_DOUBLE)
	call salloc (outcoo, wcsndim, TY_DOUBLE)
	call salloc (nsig, wcsndim, TY_INT)

	call mw_gaxmap (mw, Memi[paxno], Memi[laxno], wcsndim)
	call wt_laxmap (outwcs, Memi[paxno], wcsndim, Memi[laxno], ndim)
	call wt_vmap (im, Memd[voff], Memd[vstep], ndim)

	# Compute the number of coordinates to be read and written.
	if (inwcs == WT_LOGICAL && ndim < wcsndim)
	    nread = ndim
	else
	    nread = wcsndim
	if (outwcs == WT_LOGICAL && ndim < wcsndim)
	    nwrite = ndim
	else
	    nwrite = wcsndim
	call amovkd (INDEFD, Memd[outcoo], wcsndim)

	max_fields = MAX_FIELDS
	for (nline = 1; getline (icl, Memc[inbuf]) != EOF; nline = nline + 1) {

	    # Skip over leading white space.
	    for (ip = inbuf; IS_WHITE(Memc[ip]); ip = ip + 1)
		;

	    # Pass on comment and blank lines unchanged.
	    if (Memc[ip] == '#') {
                # Pass comment lines on to the output unchanged.
                call putline (ocl, Memc[inbuf])
                next
            } else if (Memc[ip] == '\n' || Memc[ip] == EOS) {
                # Blank lines too.
                call putline (ocl, Memc[inbuf])
                next
            }

	    # Expand tabs into blanks, determine field offsets.
            call strdetab (Memc[inbuf], Memc[linebuf], SZ_LINE, TABSIZE)
            call li_find_fields (Memc[linebuf], Memi[field_pos], max_fields,
                nfields)

	    # Decode the coordinates checking for valid input.
	    do ip = 1, nread {

		if (columns[ip] > nfields) {
		    call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE)
		    call eprintf ("\tNot enough fields in file %s line %d\n")
			call pargstr (Memc[outbuf])
			call pargi (nline)
		    call putline (ocl, Memc[linebuf])
		    break
		}

		offset = Memi[field_pos+columns[ip]-1]
		if (li_get_numd (Memc[linebuf+offset-1],
		    Memd[incoo+ip-1], Memi[nsig+ip-1]) == 0) {
		    call fstats (icl, F_FILENAME, Memc[outbuf], SZ_LINE)
		    call eprintf ("\tBad value in file %s line %d column %d\n")
			call pargstr (Memc[outbuf])
			call pargi (nline)
			call pargi (ip)
		    call putline (ocl, Memc[linebuf])
		    break
		}

	    }

	    # Skip to next line if too few fields were read.
	    if (ip <= nread)
		next

	    # Adjust the input coordinate units if necessary.
	    switch (inwcs) {
	    case WT_TV:
		call wt_tvlogd (Memd[incoo], Memd[incoo], nread, Memd[voff],
		    Memd[vstep])
	    case WT_WORLD, WT_ASTROM:
		call wt_cunits (Memd[incoo], units, nread)
	    default:
		;
	    }

	    # Compute the transform.
	    call wt_ctrand (wcs, Memd[incoo], Memd[lincoo], Memi[paxno],
	        Memd[outcoo], wcsndim, nread)

	    # Adjust the output coordinate units if necessary.
	    switch (outwcs) {
	    case WT_TV:
		call wt_logtvd (Memd[outcoo], Memd[outcoo], wcsndim,
		    Memi[laxno], Memd[voff], Memd[vstep])
	    default:
		;
	    }

	    # Create the output file line.
	    call rg_apack_lined (Memc[linebuf], Memc[outbuf], SZ_LINE,
	        Memi[field_pos], nfields, columns, nread, Memd[outcoo],
	        Memi[laxno], fmtptrs, Memi[nsig], nwrite, min_sigdigits)
		    
	    # Write out the reformatted output line.
	    call putline (ocl, Memc[outbuf])

	}

	call sfree (sp)
end


# WT_LAXMAP (paxno, wcsndim, laxno, ndim)

procedure wt_laxmap (outwcs, paxno, wcsndim, laxno, ndim)

int	outwcs			#I the output wcs
int	paxno[ARB]		#I the physical axis map
int	wcsndim			#I the number of physical axis dimensions
int	laxno[ARB]		#O the physical axis map
int	ndim			#I the number of logical axis dimensions

int	i, j

begin
	if (outwcs == WT_LOGICAL && ndim < wcsndim) {
	    do i = 1, ndim {
	        laxno[i] = 0
	        do j = 1, wcsndim {
		    if (paxno[j] != i)
		        next
		    laxno[i] = j
		    break
	        }
	    }
	    do i = ndim + 1, wcsndim
		laxno[i] = 0
	} else {
	    do i = 1, wcsndim
		laxno[i] = i
	}
end


# WT_VMAP -- Fetch the image i/o section map. Tecnically this routine
# violates a system interface and uses the internal definitions in
# the imio.h file. However this routine is required to support tv coordinates
# which are coordinates with respect to the current section, and not identical
# to section coordinates.

procedure wt_vmap (im, voff, vstep, ndim)

pointer	im			#I the input image descriptor
double	voff[ARB]		#O the array of offsets
double	vstep[ARB]		#O the array of step sizes
int	ndim			#I the number of dimensions

int	i, dim

begin
	do i = 1, ndim {
	    dim = IM_VMAP(im,i)
	    voff[i] = IM_VOFF(im,dim)
	    vstep[i] = IM_VSTEP(im,i)
	}
end


# WT_UNITS -- Correct the units of the input coordinates if necessary.

procedure wt_cunits (incoo, units, ncoo)

double	incoo[ARB]		#I the array of input coordinates
int	units[ARB]		#I the array of units
int	ncoo			#I the number of coordinates

int	i

begin
	do i = 1, ncoo {
	    switch (units[i]) {
	    case WT_UHOURS:
		incoo[i] = 15.0d0 * incoo[i]
	    default:
		;
	    }
	}
end


# WT_TVLOGD -- Linearly transform a vector of coordinates using an
# array of voffsets and scale factors.

procedure wt_tvlogd (incoo, outcoo, ndim, voff, vstep)

double	incoo[ARB]		#I array of input coordinates
double	outcoo[ARB]		#O array of output coordinates
int	ndim			#I number of coordinates
double	voff[ARB]		#I array of zero points
double	vstep[ARB]		#I array of scale factors

int	i

begin
	do i = 1, ndim
	    outcoo[i] = (incoo[i] - voff[i]) / vstep[i]
end


# WT_CTRAND -- Transform the coordinates.

procedure wt_ctrand (wcs, incoo, lincoo, paxno, outcoo, wcsndim, nread)

pointer	wcs			#I pointer to the compiled transform
double	incoo[ARB]		#I array of input coordinates
double	lincoo[ARB]		#U scratch array of input coordinates
int	paxno[ARB]		#I the physical axis map
double	outcoo[ARB]		#O array of output coordinates
int	wcsndim			#I the dimension of the wcs
int	nread			#I the number of input coordinates.

int	i

begin
	if (nread < wcsndim) {
	    do i = 1, wcsndim {
		if (paxno[i] == 0)
		    lincoo[i] = 1.0d0
		else
		    lincoo[i] = incoo[paxno[i]]
	    }
	    if (wcs == NULL)
		call amovd (lincoo, outcoo, wcsndim)
	    else
		call msc_ctrand (wcs, 1, lincoo, outcoo, wcsndim)

	} else {
	    if (wcs == NULL)
		call amovd (incoo, outcoo, wcsndim)
	    else
		call msc_ctrand (wcs, 1, incoo, outcoo, wcsndim)
	}

end


# WT_LOGTVD -- Linearly transform a vector of coordinates using an
# array of voffsets and scale factors.

procedure wt_logtvd (incoo, outcoo, wcsndim, laxno, voff, vstep)

double	incoo[ARB]		#I array of input coordinates
double	outcoo[ARB]		#O array of output coordinates
int	wcsndim			#I number of coordinates
int	laxno[ARB]		#I the logical axis map
double	voff[ARB]		#I array of zero points
double	vstep[ARB]		#I array of scale factors

int	i

begin
	do i = 1, wcsndim {
	    if (laxno[i] != 0)
	        outcoo[laxno[i]] = (incoo[laxno[i]] * vstep[laxno[i]]) +
		    voff[laxno[i]]
	}
end


# WT_GETLABELS -- Get the next label from a list of labels.

int procedure wt_getlabels (list, ip, label, maxch)

char    list[ARB]               #I list of labels
int     ip                      #U pointer in to the list of labels
char    label[ARB]              #O the output label
int     maxch                   #I maximum length of a column name

int     op, token
int     ctotok(), strlen()

begin
        # Decode the column labels.
        op = 1
        while (list[ip] != EOS) {

            token = ctotok (list, ip, label[op], maxch)
            if (label[op] == EOS)
                next
            if ((token == TOK_UNKNOWN) || (token == TOK_CHARCON))
                break
            if ((token == TOK_PUNCTUATION) && (label[op] == ',')) {
                if (op == 1)
                    next
                else
                    break
            }

            op = op + strlen (label[op])
            break
        }

        label[op] = EOS
        if ((list[ip] == EOS) && (op == 1))
            return (EOF)
        else
            return (op - 1)
end

mscred-5.05-2018.07.09/src/t_mscext.x000066400000000000000000000062171332166314300166020ustar00rootroot00000000000000# Copyright(c) 1986 Association of Universities for Research in Astronomy Inc.

include	
include	
include	
include	

define	OUTPUTS		"|none|list|file|"
define	NONE		1		# No output
define	LIST		2		# List output
define	FILE		3		# File output

define	SZ_RANGE	100		# Size of range list
define	SZ_LISTOUT	255		# Size of output list


# T_MSCEXTENSIONS -- Expand a template of FITS files into a list of image
# extensions on the standard output and record the number image extensions
# in a parameter.
#
# This differs from IMEXTENSIONS in that extension zero is not returned
# unless it is a simple image and, in that case, the extension is removed.
# Also a parameter is written indicating if the list contains image extensions.

procedure t_mscextensions()

pointer	input			# List of ME file names
int	output			# Output list (none|list|file)
pointer	index			# Range list of extension indexes
pointer	extname			# Patterns for extension names
pointer extver			# Range list of extension versions
int	lindex			# List index number?
int	lname			# List extension name?
int	lver			# List extension version?
int	dataless		# Include dataless global header?
pointer	ikparams		# Image kernel parameters

pointer	sp, image, listout
int	list, nimages, fd, imext
int	clgwrd(), btoi(), xt_extns(), stropen()
int	imtgetim(), imtlen()
bool	clgetb()
errchk	stropen, fprintf, strclose

begin
	call smark (sp)
	call salloc (input, SZ_LINE, TY_CHAR)
	call salloc (index, SZ_LINE, TY_CHAR)
	call salloc (extname, SZ_LINE, TY_CHAR)
	call salloc (extver, SZ_LINE, TY_CHAR)
	call salloc (ikparams, SZ_LINE, TY_CHAR)
	call salloc (image, SZ_FNAME, TY_CHAR)

	# Task parameters
	call clgstr ("input", Memc[input], SZ_LINE)
	output = clgwrd ("output", Memc[image], SZ_FNAME, OUTPUTS)
	call clgstr ("index", Memc[index], SZ_LINE)
	call clgstr ("extname", Memc[extname], SZ_LINE)
	call clgstr ("extver", Memc[extver], SZ_LINE)
	lindex = btoi (clgetb ("lindex"))
	lname = btoi (clgetb ("lname"))
	lver = btoi (clgetb ("lver"))
	dataless = btoi (clgetb ("dataless"))
	call clgstr ("ikparams", Memc[ikparams], SZ_LINE)

	# Get the list.
	list = xt_extns (Memc[input], "IMAGE", Memc[index], Memc[extname],
	    Memc[extver], lindex, lname, lver, dataless, Memc[ikparams],
	    NO, imext)

	# Format the output and set the number of images.
	switch (output) {
	case LIST:
	    call salloc (listout, SZ_LISTOUT, TY_CHAR)
	    iferr {
		fd = stropen (Memc[listout], SZ_LISTOUT, WRITE_ONLY)
		nimages = 0
		while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) {
		    nimages = nimages + 1
		    if (nimages == 1) {
			call fprintf (fd, "%s")
			    call pargstr (Memc[image])
		    } else {
			call fprintf (fd, ",%s")
			    call pargstr (Memc[image])
		    }
		}
		call strclose (fd)
		call printf ("%s\n")
		    call pargstr (Memc[listout])
	    } then {
		call imtclose (list)
		call sfree (sp)
		call error (1, "Output list format is too long")
	    }
	case FILE:
	    while (imtgetim (list, Memc[image], SZ_FNAME) != EOF) {
		call printf ("%s\n")
		    call pargstr (Memc[image])
	    }
	}
	call clputi ("nimages", imtlen (list))
	call clputb ("imext", (imext==YES))

	call imtclose (list)
	call sfree (sp)
end
mscred-5.05-2018.07.09/src/t_mscgmask.x000066400000000000000000000053151332166314300171020ustar00rootroot00000000000000include	
include	


# T_MSCGMASK -- Get masks for specified images.
# This takes a parent mask and matches it with an image in WCS and outputs
# mask of the same size as the input image.

procedure t_mscgmask ()

int	ilist			# List of input images
int	olist			# List of output masks
int	mlist			# List of parent masks
short	mval			# Mask value
bool	empty			# All masks empty?

int	i, j
long	vin[IM_MAXDIM], vout[IM_MAXDIM]
pointer	sp, input, output, mask, im, pmim, mw, tmp, bufin, bufout

short	clgets()
bool	im_pmlnev()
int	imtopenp(), imtgetim(), imtlen(), strmatch(), imgnls(), impnls()
pointer	immap(), mw_openim(), yt_pmmap()
errchk	strmatch, immap, mw_openim, yt_pmmap, mw_saveim

begin
	call smark (sp)
	call salloc (input, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)
	call salloc (mask, SZ_FNAME, TY_CHAR)

	# Get lists and check if they match.
	ilist = imtopenp ("input")
	olist = imtopenp ("output")
	mlist = imtopenp ("masks")
	mval = clgets ("mval")
	empty = true

	i = imtlen (ilist)
	j = imtlen (olist)
	if (j != i)
	    call error (1, "Input and output lists don't match")
	    
	j = imtlen (mlist)
	if (j == 0 || (j > 1 && j != i))
	    call error (1, "Image and mask lists are incompatible")

	# Extract the masks.
	while (imtgetim (ilist, Memc[input], SZ_FNAME) != EOF) {
	    iferr {
		i = imtgetim (olist, Memc[output], SZ_FNAME)
		if (strmatch (Memc[output], ".pl$") == 0)
		    call strcat (".pl", Memc[output], SZ_FNAME)

		if (imtgetim (mlist, Memc[mask], SZ_FNAME) == EOF) {
		    call imtrew (mlist)
		    i = imtgetim (mlist, Memc[mask], SZ_FNAME)
		}

		im = NULL
		mw = NULL
		pmim = NULL

		tmp = immap (Memc[input], READ_ONLY, 0)
		im = tmp
		tmp = mw_openim (im)
		mw = tmp
		tmp = yt_pmmap (Memc[mask], im, Memc[mask], SZ_FNAME)
		pmim = tmp
		if (tmp == NULL) {
		    tmp = yt_pmmap ("EMPTY", im, Memc[mask], SZ_FNAME)
		    pmim = tmp
		}
		call imunmap (im)
		tmp = immap (Memc[output], NEW_COPY, pmim)
		im = tmp
		call mw_saveim (mw, im)
		call mw_close (mw)

		j = IM_LEN(im,1)
		call amovkl (long(1), vin, IM_MAXDIM)
		call amovkl (long(1), vout, IM_MAXDIM)
		while (impnls (im, bufout, vout) != EOF) {
		    if (im_pmlnev (pmim, vin)) {
			i = imgnls (pmim, bufin, vin)
			do i = 0, j-1 {
			    if (Mems[bufin+i] == 0)
				Mems[bufout+i] = 0
			    else
				Mems[bufout+i] = mval
			}
			empty = false
		    } else {
			call amovl (vout, vin, IM_MAXDIM)
			call aclrs (Mems[bufout], j)
		    }
		}
	    } then
		call erract (EA_WARN)

	    if (mw != NULL)
		call mw_close (mw)
	    if (im != NULL)
		call imunmap (im)
	    if (pmim != NULL)
		call imunmap (pmim)

	}
	call clputb ("empty", empty)

	call imtclose (ilist)
	call imtclose (olist)
	call imtclose (mlist)
	call sfree (sp)
end
mscred-5.05-2018.07.09/src/t_mscimatch.x000066400000000000000000001053761332166314300172550ustar00rootroot00000000000000include	
include	
include	
include 
include	
include	


# T_MSCIMATCH -- Match intensity scales in a set of images.

procedure t_mscimatch ()

int	input		# List of images
int	bpm		# List of bad pixel masks
pointer	measured	# File of measurements
pointer	coords		# File of coordinates
bool	doscale		# Determine scale?
bool	dozero		# Determine zero?
int	box1		# Measurement box 1
int	box2		# Measurement box 2
double	lower		# Lower data threshold
double	upper		# Upper data threshold
int	niterate	# Number of interations
double	sigma		# Sigma clipping factor
bool	interactive	# Interactive fits?
bool	verbose		# Verbose output?

int	i, j, ncoord, nreg, nimages, nimages2, nbpm, fd, fdin, fdout
double	x, y, skyval
pointer	sp, fname, bpmname, sky, data, wts, a, b, ra, dec
pointer	im, mw, pm, ic

bool	clgetb()
int	clgeti(), open(), fscan(), nscan(), access(), imaccess(), nowhite()
int	imtopenp(), imtgetim(), imtrgetim(), imtlen()
double	clgetd(), imgetd()
pointer	immap(), mw_openim(), yt_pmmap()

begin
	call smark (sp)
	call salloc (measured, SZ_FNAME, TY_CHAR)
	call salloc (coords, SZ_FNAME, TY_CHAR)
	call salloc (fname, SZ_FNAME, TY_CHAR)
	call salloc (bpmname, SZ_FNAME, TY_CHAR)

	# Get query parameters.
	input = imtopenp ("input")
	bpm = imtopenp ("bpm")
	call clgstr ("measured", Memc[measured], SZ_FNAME)
	call clgstr ("coords", Memc[coords], SZ_FNAME)
	doscale = clgetb ("scale")
	dozero = clgetb ("zero")
	box1 = clgeti ("box1")
	box2 = clgeti ("box2")
	lower = clgetd ("lower")
	upper = clgetd ("upper")
	niterate = clgeti ("niterate")
	sigma = clgetd ("sigma")
	interactive = clgetb ("interactive")
	verbose = clgetb ("verbose")

	if (!doscale && !dozero)
	    call error (1, "Must have at least one of scale and zero set")

	if (box1 < 1 || box1 >= box2)
	    call error (1, "Invalid box sizes")

	# Count and verify input images.
	# We do this now since the measuring step can be slow.
	nimages = 0
	while (imtgetim (input, Memc[fname], SZ_FNAME) != EOF) {
	    if (imaccess (Memc[fname], READ_ONLY) != YES) {
		call sprintf (Memc[coords], SZ_LINE,
		    "Can't access image `(%s)'")
		    call pargstr (Memc[fname])
		call error (2, Memc[coords])
	    }
	    nimages = nimages + 1
	}
	if (nimages < 2)
	    call error (1, "At least two images are required")
	nimages2 = nimages * nimages
	call imtrew (input)

	# Check bpm.
	nbpm = imtlen (bpm)
	if (nbpm > 1 && nbpm != nimages)
	    call error (2, "Mask list not appropriate for image list")

	# See if there is a measured data file.
	fdin = NULL
	fdout = NULL
	if (nowhite (Memc[measured], Memc[measured], SZ_FNAME) > 0) {
	    if (access (Memc[measured], READ_ONLY, 0) == YES)
		fdin = open (Memc[measured], READ_ONLY, TEXT_FILE)
	    else
		fdout = open (Memc[measured], NEW_FILE, TEXT_FILE)
	}

	if (verbose) {
	    call fseti (STDOUT, F_FLUSHNL, YES)
	    call printf ("MSCIMATCH:\n")
	}

	# If there is no measured data file read the coordinates and measure
	# the regions.  Possibly save the measurements in a file.

	if (fdin == NULL) {
	    if (verbose) {
		call printf ("  Reading region coordinates from %s\n")
		    call pargstr (Memc[coords])
	    }

	    # Read coordinates.
	    ncoord = 0
	    fd = open (Memc[coords], READ_ONLY, TEXT_FILE)
	    while (fscan (fd) != EOF) {
		call gargd (x)
		call gargd (y)
		if (nscan() < 2)
		    next
		if (ncoord == 0) {
		    call malloc (ra, 100, TY_DOUBLE)
		    call malloc (dec, 100, TY_DOUBLE)
		} else if (mod (ncoord, 100) == 0) {
		    call realloc (ra, ncoord+100, TY_DOUBLE)
		    call realloc (dec, ncoord+100, TY_DOUBLE)
		}
		Memd[ra+ncoord] = x
		Memd[dec+ncoord] = y
		ncoord = ncoord + 1
	    }
	    call close (fd)
	    if (ncoord < 1)
		call error (3, "Insufficient number of coordinates")
	    nreg = 2 * ncoord
	} else {
	    if (verbose) {
		call printf ("  Reading measurements from %s\n")
		    call pargstr (Memc[measured])
	    }

	    i = fscan (fdin)
	    call gargi (i)
	    call gargi (ncoord)
	    if (nscan() != 2)
		call error (1, "Syntax error in measurement file")
	    if (i != nimages)
		call error (1,
		    "Number of images does not match measurement file")
	    nreg = 2 * ncoord

	    call malloc (ra, ncoord, TY_DOUBLE)
	    call malloc (dec, ncoord, TY_DOUBLE)
	}

	if (verbose) {
	    call printf ("    %d coordinates read\n")
		call pargi (ncoord)
	}

	# Allocate and initialize memory.
	call salloc (sky, nimages, TY_DOUBLE)
	call salloc (data, nreg*nimages, TY_DOUBLE)
	call salloc (wts, nimages2*nreg, TY_DOUBLE)
	call salloc (a, nimages2*2, TY_DOUBLE)
	call salloc (b, nimages2*2, TY_DOUBLE)

	call amovkd (0D0, Memd[sky], nimages)
	call amovkd (INDEFD, Memd[data], nreg*nimages)
	call amovkd (1D0, Memd[wts], nimages2*nreg)
	call amovkd (1D0, Memd[a], nimages2)
	call amovkd (0D0, Memd[b], nimages2)
	call amovkd (0D0, Memd[a+nimages2], nimages2)
	call amovkd (0D0, Memd[b+nimages2], nimages2)

	if (fdin == NULL) {
	    # Measure regions.
	    if (fdout != NULL) {
		if (verbose) {
		    call printf ("  Writing measurements to %s\n")
			call pargstr (Memc[measured])
		}
		call fprintf (fdout, "%d %d\n")
		    call pargi (nimages)
		    call pargi (ncoord)
	    }
	    do i = 1, nimages {
		# Open image.
		if (imtrgetim (input, i, Memc[fname], SZ_FNAME) == EOF)
		    break
		im = immap (Memc[fname], READ_ONLY, 0)

		if (!dozero) {
		    iferr (skyval = imgetd (im, "skymean"))
			skyval = 0.
		    Memd[sky+i-1] = skyval
		}

		if (verbose) {
		    call printf ("  Measuring regions in %s ...\n")
			call pargstr (Memc[fname])
		}

		# Open mask.
		pm = NULL
		if (nbpm > 0) {
		    if (imtrgetim (bpm, min (i, nbpm), Memc[bpmname],
			SZ_FNAME) == EOF)
			break
		    pm = yt_pmmap (Memc[bpmname], im, Memc[bpmname], SZ_FNAME)
		}
		if (pm != NULL && verbose) {
		    call printf ("  Using bad pixel mask %s ...\n")
			call pargstr (Memc[bpmname])
		}

		# Open WCS.
		mw = mw_openim (im)

		# Measure the regions.
		call imat_measure (im, pm, mw, Memd[ra], Memd[dec], ncoord,
		    Memd[data+(i-1)*nreg], nreg, box1, box2, lower, upper,
		    Memd[sky+i-1], i, fdout, verbose)

		call mw_close (mw)
		if (pm != NULL)
		    call imunmap (pm)
		call imunmap (im)
	    }
	    if (fdout != NULL)
		call close (fdout)
	} else {
	    while (fscan (fdin) != EOF) {
		call gargi (i)
		call gargi (j)
		call gargwrd (Memc[fname], SZ_FNAME)
		if (nscan() != 3)
		    next
		call gargd (Memd[ra+j-1])
		call gargd (Memd[dec+j-1])
		call gargd (x)
		call gargd (y)
		call gargd (skyval)
		call gargd (x)
		call gargd (y)
		if (nscan() != 10)
		    next

		Memd[sky+i-1] = skyval
		Memd[data+(i-1)*nreg+2*(j-1)] = x
		Memd[data+(i-1)*nreg+2*(j-1)+1] = y
	    }
	    call close (fdin)
	}

	if (verbose)
	    call printf ("  Determining scale factors ...\n")

	if (interactive) {
	    call imat_icinit (ic, input)
	    call imat_fit (NULL, Memd[data], Memd[wts], Memd[a], Memd[b],
		nimages, nreg, niterate, sigma, doscale, dozero)
	    call imat_fit (ic, Memd[data], Memd[wts], Memd[a], Memd[b],
		nimages, nreg, niterate, sigma, doscale, dozero)
	    call imat_icfree (ic)
	} else
	    call imat_fit (NULL, Memd[data], Memd[wts], Memd[a], Memd[b],
		nimages, nreg, niterate, sigma, doscale, dozero)

	# Correct for fixed zero.
	if (!dozero) {
	    skyval = Memd[sky] * Memd[a]
	    do i = 1, nimages
		Memd[b+(i-1)*nimages] = skyval -
		    Memd[sky+i-1] * Memd[a+(i-1)*nimages]
	}

	# Output zero values are relative to it's own scale.
	do i = 1, nimages
	    Memd[b+(i-1)*nimages] = Memd[b+(i-1)*nimages] /
		Memd[a+(i-1)*nimages]

	# Print final scale factors.
	do i = 1, nimages {
	    if (imtrgetim (input, i, Memc[fname], SZ_FNAME) == EOF)
		break
	    call printf ("%20s: %6.4f (%.4f) %8.2f (%.2f)\n")
		call pargstr (Memc[fname])
		call pargd (Memd[a+(i-1)*nimages])
		call pargd (Memd[a+(i-1)*nimages+nimages2])
		call pargd (Memd[b+(i-1)*nimages])
		call pargd (Memd[b+(i-1)*nimages+nimages2])
	}

	# Update images.
	if (clgetb ("accept")) {
	    do i = 1, nimages {
		if (imtrgetim (input, i, Memc[fname], SZ_FNAME) == EOF)
		    break
		im = immap (Memc[fname], READ_WRITE, 0)
		call imaddd (im, "mscscale", Memd[a+(i-1)*nimages])
		call imaddd (im, "msczero", Memd[b+(i-1)*nimages])
		call imunmap (im)
	    }
	}

	call imtclose (input)

	call mfree (ra, TY_DOUBLE)
	call mfree (dec, TY_DOUBLE)
	call sfree (sp)
end


procedure t_rand ()

int	nimages		# Number of images
int	ncoord		# Number of coordinates
int	ntrials		# Number of trials
real	noise		# Noise factor
long	seed		# Seed
bool	verbose		# Verbose output?

int	i, j, k, nreg, nimages2, nsum
double	flux1, flux2, sum1, sum2, sum3, sum4
pointer	sp, data, wts, a, b

bool	clgetb()
int	clgeti()
long	clgetl
real	clgetr(), urand()

begin
	call smark (sp)

	# Get query parameters.
	nimages = clgeti ("nimages")
	ncoord = clgeti ("ncoord")
	ntrials = clgeti ("ntrials")
	noise = clgetr ("noise")
	seed = clgetl ("seed")
	verbose = clgetb ("verbose")

	if (nimages < 2)
	    call error (1, "At least two images are required")
	nimages2 = nimages * nimages

	if (verbose) {
	    call fseti (STDOUT, F_FLUSHNL, YES)
	    call printf ("MSCIMATCH:\n")
	}

	if (ncoord < 1)
	    call error (3, "Insufficient number of coordinates")
	nreg = 2 * ncoord

	# Allocate and initialize memory.
	call salloc (data, nreg*nimages, TY_DOUBLE)
	call salloc (wts, nimages2*nreg, TY_DOUBLE)
	call salloc (a, nimages2*2, TY_DOUBLE)
	call salloc (b, nimages2*2, TY_DOUBLE)

	call amovkd (INDEFD, Memd[data], nreg*nimages)
	call amovkd (1D0, Memd[wts], nimages2*nreg)
	call amovkd (1D0, Memd[a], nimages2)
	call amovkd (0D0, Memd[b], nimages2)
	call amovkd (0D0, Memd[a+nimages2], nimages2)
	call amovkd (0D0, Memd[b+nimages2], nimages2)

	# Set data.
	sum1 = 0.
	sum2 = 0.
	sum3 = 0.
	sum4 = 0.
	nsum = 0
	do k = 1, ntrials {
	    do i = 1, ncoord {
		flux1 = 100
		flux2 = flux1 + 1000 * urand (seed)
		do j = 1, nimages {
		    Memd[data+(j-1)*nreg+2*(i-1)] = (flux1 + sqrt (flux1) *
			noise * (2 * urand (seed) - 1.) - 10*(j-1)) / j
		    Memd[data+(j-1)*nreg+2*(i-1)+1] = (flux2 + sqrt (flux2) *
			noise * (2 * urand (seed) - 1.) - 10*(j-1)) / j
		}
	    }

	    if (verbose)
		call printf ("  Determining scale factors ...\n")
	    call imat_fit (NULL, Memd[data], Memd[wts], Memd[a], Memd[b],
		nimages, nreg, 4, double(4.), true, true)

	    do i = 2, nimages {
		sum1 = sum1 + (Memd[a+(i-1)*nimages]/i-1)**2
		sum2 = sum2 + Memd[a+(i-1)*nimages+nimages2]/i
		sum3 = sum3 + (Memd[b+(i-1)*nimages]-10*(i-1))**2
		sum4 = sum4 + Memd[b+(i-1)*nimages+nimages2]
		nsum = nsum + 1
	    }

	    # Print final scale factors.
	    if (k == 1) {
		do i = 1, nimages {
		    call printf ("%d: %6.4f (%.4f) %8.2f (%.2f)\n")
			call pargi (i)
			call pargd (Memd[a+(i-1)*nimages])
			call pargd (Memd[a+(i-1)*nimages+nimages2])
			call pargd (Memd[b+(i-1)*nimages])
			call pargd (Memd[b+(i-1)*nimages+nimages2])
		}
	    }
	}

	call printf ("%8.4f %8.4f %8.4f %8.4f\n")
	    call pargd (sqrt (sum1 / nsum))
	    call pargd (sum2 / nsum)
	    call pargd (sqrt (sum3 / nsum))
	    call pargd (sum4 / nsum)

	call sfree (sp)
end


# IMAT_MEASURE -- Measure the fluxes within boxes and thresholds.

procedure imat_measure (im, pm, mw, ra, dec, ncoords, data, nreg, box1, box2,
	lower, upper, sky, nimage, fd, verbose)

pointer	im		#I IMIO pointer
pointer	pm		#I Mask IMIO pointer
pointer	mw		#I MWCS pointer
double	ra[ncoords]	#I RA coordinates
double	dec[ncoords]	#I DEC coordinates
int	ncoords		#I Number of coordinates
double	data[nreg]	#U Photon counts
int	nreg		#I Number of regions
int	box1		#I Measurement box 1
int	box2		#I Measurement box 2
double	lower		#I Lower data threshold
double	upper		#I Upper data threshold
double	sky		#I Sky to subtract
int	nimage		#I Image number
int	fd		#I Output file pointer
bool	verbose		#I Verbose?

int	i, j, k, n, nthresh
int	nc, nl, nbox1, nbox2, hbox1, hbox2, xc, yc, x1, x2, y1, y2
bool	lcheck, ucheck
double	val, sum1, sum2
pointer	sp, x, y, index, imname, err, ct

bool	im_pmsne2()
pointer	buf, mw_sctran(), imgs2d()

int	imat_comp()
extern	imat_comp

define	skip_	10

begin
	call smark (sp)
	call salloc (x, ncoords, TY_DOUBLE)
	call salloc (y, ncoords, TY_DOUBLE)
	call salloc (index, ncoords, TY_INT)

	# Convert world coordinates to image coordinates and sort by line
	# to optimize image I/O.

	ct = mw_sctran (mw, "world", "logical", 3)
	do i = 1, ncoords {
	    call mw_c2trand (ct, 15*ra[i], dec[i], Memd[x+i-1], Memd[y+i-1])
	    Memi[index+i-1] = i
	}
	call mw_ctfree (ct)
	call gqsort (Memi[index], ncoords, imat_comp, y)

	# Measure.
	nc = IM_LEN(im,1)
	nl = IM_LEN(im,2)
	nbox1 = box1 * box1
	nbox2 = box2 * box2 - nbox1
	hbox1 = box1 / 2
	hbox2 = box2 / 2
	lcheck = (!IS_INDEFD(lower))
	ucheck = (!IS_INDEFD(upper))
	n = 0
	nthresh = 0
	do i = 1, ncoords {
	    j = Memi[index+i-1]
	    xc = nint (Memd[x+j-1])
	    yc = nint (Memd[y+j-1])
	    x1 = xc - hbox2
	    x2 = xc + hbox2
	    y1 = yc - hbox2
	    y2 = yc + hbox2
	    if (x1 < 1 || x2 > nc || y1 < 1 || y2 > nl)
		goto skip_

	    if (pm != NULL)
		if (im_pmsne2 (pm, x1, x2, y1, y2))
		    goto skip_

	    buf = imgs2d (im, x1, x2, y1, y2)
	    sum1 = 0.
	    sum2 = 0.
	    do j = -hbox2, hbox2 {
		do k = -hbox2, hbox2 {
		    val = Memd[buf]
		    buf = buf + 1
		    if (lcheck) {
			if (val < lower) {
			    nthresh = nthresh + 1
			    goto skip_
			}
		    }
		    if (ucheck) {
			if (val > upper) {
			    nthresh = nthresh + 1
			    goto skip_
			}
		    }
		    if (j < -hbox1 || j > hbox1 || k < -hbox1 || k > hbox1)
			sum2 = sum2 + val
		    else
			sum1 = sum1 + val
		}
	    }

	    data[2*i-1] = sum1 / nbox1 - sky
	    data[2*i] = sum2 / nbox2 - sky
	    n = n + 1

skip_	    next
	}

	if (n < 1) {
	    call salloc (imname, SZ_FNAME, TY_CHAR)
	    call salloc (err, SZ_LINE, TY_CHAR)
	    call imstats (im, IM_IMAGENAME, Memc[imname], SZ_FNAME)
	    if (nthresh > 0) {
		call sprintf (Memc[err], SZ_LINE,
		    "No data found `(%s)': check lower and upper limits")
		    call pargstr (Memc[imname])
	    } else {
		call sprintf (Memc[err], SZ_LINE, "No data found `(%s)'")
		    call pargstr (Memc[imname])
	    }
	    call error (4, Memc[err])
	}

	if (verbose) {
	    call printf ("    %d good regions measured\n")
		call pargi (n)
	}

	if (fd != NULL) {
	    call salloc (imname, SZ_FNAME, TY_CHAR)
	    call imstats (im, IM_IMAGENAME, Memc[imname], SZ_FNAME)
	    do i = 1, ncoords {
		if (IS_INDEFD(data[2*i]))
		    next
		j = Memi[index+i-1]
		xc = nint (Memd[x+j-1])
		yc = nint (Memd[y+j-1])
		call fprintf (fd,
		    "%2d %4d %-15s %11.2h %11.1h %4d %4d %.6g %8.6g %8.6g\n")
		    call pargi (nimage)
		    call pargi (i)
		    call pargstr (Memc[imname])
		    call pargd (ra[j])
		    call pargd (dec[j])
		    call pargi (xc)
		    call pargi (yc)
		    call pargd (sky)
		    call pargd (data[2*i-1])
		    call pargd (data[2*i])
	    }
	}

	call sfree (sp)
end


int procedure imat_comp (arg, i, j)

pointer	arg		# Data to compare
int	i, j		# Indices to compare

begin
	if (Memd[arg+i-1] < Memd[arg+j-1])
	    return (-1)
	else if (Memd[arg+i-1] > Memd[arg+j-1])
	    return (1)
	else
	    return (0)
end


# IMAT_FIT -- Determine the scale factors from a set of measurements.
# The measurements are the number of photons in a set of region each
# of which is measured for all images.  If a region was not measured in
# a particular region (such as being off the image) then a value of INDEF
# given.  The relationship between the measurements determined is
#
#	data[i,k] = a[k,j] * data[i,j] + b[k,j]
#
# where j= 1 to nimages, k = 1 to nimages, i = 1 to nreg. 

procedure imat_fit (ic, data, wts, a, b, nimages, nreg, niterate, sigma,
	doscale, dozero)

pointer	ic				#I IC pointer
double	data[nreg,nimages]		#I Photon counts
double	wts[nimages,nimages,nreg]	#U Weights for pairs of measurments
double	a[nimages,nimages,2]		#U Scale factors
double	b[nimages,nimages,2]		#U Zero factors
int	nimages				#I Number of images
int	nreg				#I Number of regions per image
int	niterate			#I Number of iterations
double	sigma				#I Sigma clipping factor
bool	doscale				#I Determine scale?
bool	dozero				#I Determine zero?

int	i, nrej, ndel
pointer	sp, x, y, w

begin
	call smark (sp)
	call salloc (x, nreg, TY_DOUBLE)
	call salloc (y, nreg, TY_DOUBLE)
	call salloc (w, nreg, TY_DOUBLE)

	call imat_fit1 (ic, data, wts, a, b, Memd[x], Memd[y], Memd[w],
	    nimages, nreg, niterate, sigma, doscale, dozero, ndel)
	if (ndel > 0)
	    call imat_fit1 (NULL, data, wts, a, b, Memd[x], Memd[y],
		Memd[w], nimages, nreg, niterate, sigma, doscale, dozero, ndel)
	call imat_scale (a, b, nimages)

	do i = 1, niterate {
	    call imat_rej (NULL, data, wts, a, b, nimages, nreg, sigma, nrej)
	    if (nrej == 0)
		break
	    call imat_fit1 (NULL, data, wts, a, b, Memd[x], Memd[y],
		Memd[w], nimages, nreg, niterate, sigma, doscale, dozero, ndel)
	    call imat_scale (a, b, nimages)
	}

	call sfree (sp)
end


# IMAT_FIT1 -- Fit scale and zero independently for each pair of images.
# This may include iterative rejection based on residual / sqrt (fit).

procedure imat_fit1 (ic, data, wts, a, b, x, y, w, nimages, nreg,
	niterate, sigma, doscale, dozero, ndel)

pointer	ic				#I IC pointer
double	data[nreg,nimages]		#I Photon counts
double	wts[nimages,nimages,nreg]	#U Weights for pairs of measurments
double	a[nimages,nimages,2]		#U Scale factors
double	b[nimages,nimages,2]		#U Zero factors
double	x[nreg], y[nreg], w[nreg]	#I Working arrays for fitting
int	nimages				#I Number of images
int	nreg				#I Number of regions per image
int	niterate			#I Number of iterations
double	sigma				#I Sigma clipping factor
bool	doscale				#I Determine scale?
bool	dozero				#I Determine zero?
int	ndel				#O Number deleted by the user

int	i, j, k, n
double	xmin, xmax, chisqr, coeff[2]
pointer	cv

bool	dos, doz
common	/imatcom/dos, doz
extern	imat_fnc

begin
	ndel = 0
	do k = 1, nimages {
	    do j = 1, nimages {
		if (j == k)
		    next
		n = 0
		do i = 1, nreg {
		    if (IS_INDEFD(data[i,j]) || IS_INDEFD(data[i,k]))
			next
		    n = n + 1
		    x[n] = data[i,j]
		    y[n] = data[i,k]
		    w[n] = wts[j,k,i]
		    if (n == 1) {
			xmin = x[n]
			xmax = x[n]
		    } else {
			xmin = min (xmin, x[n])
			xmax = max (xmax, x[n])
		    }
		}
		if (n < 2)
		    next

		dos = doscale
		doz = dozero
		if (doscale && dozero)
		    call dcvinit (cv, USERFNC, 2, xmin, xmax)
		else
		    call dcvinit (cv, USERFNC, 1, xmin, xmax)
		call dcvuserfnc (cv, imat_fnc)
		if (ic != NULL && k == j+1) {
		    call imat_iclabels (ic, j, k)
		    call imat_fit2 (ic, cv, x, y, w, n, niterate, sigma)
		    n = 0
		    do i = 1, nreg {
			if (IS_INDEFD(data[i,j]) || IS_INDEFD(data[i,k]))
			    next
			n = n + 1
			if (w[n] == 0D0) {
			    wts[j,k,i] = 0D0
			    wts[k,j,i] = 0D0
			    ndel = ndel + 2
			}
		    }
		} else
		    call imat_fit2 (NULL, cv, x, y, w, n, niterate, sigma)
		if (doscale && dozero) {
		    call dcvcoeff (cv, coeff, i)
		    b[k,j,1] = coeff[1]
		    a[k,j,1] = coeff[2]
		    call dcvvector (cv, x, x, n)
		    call dcverrors (cv, y, w, x, n, chisqr, coeff)
		    b[k,j,2] = coeff[1]
		    a[k,j,2] = coeff[2]
		} else if (dozero) {
		    call dcvcoeff (cv, coeff, i)
		    b[k,j,1] = coeff[1]
		    a[k,j,1] = 1
		    call dcvvector (cv, x, x, n)
		    call dcverrors (cv, y, w, x, n, chisqr, coeff)
		    b[k,j,2] = coeff[1]
		    a[k,j,2] = 0
		} else {
		    call dcvcoeff (cv, coeff, i)
		    b[k,j,1] = 0
		    a[k,j,1] = coeff[1]
		    call dcvvector (cv, x, x, n)
		    call dcverrors (cv, y, w, x, n, chisqr, coeff)
		    b[k,j,2] = 0
		    a[k,j,2] = coeff[1]
		}
		call dcvfree (cv)
	    }
	}
end


# IMAT_FNC -- CURFIT user function.

procedure imat_fnc (x, order, k1, k2, basis)

double	x		# array of data points
int	order		# order of polynomial, order = 1, constant
double	k1, k2		# normalizing constants
double	basis[ARB]	# basis functions

bool	dos, doz
common	/imatcom/dos, doz

begin
	if (doz && dos) {
	    basis[1] = 1
	    basis[2] = x
	} else if (doz)
	    basis[1] = 1
	else
	    basis[1] = x
end


# IMAT_FIT2 -- Fit data from a single pair of images with rejection.

procedure imat_fit2 (ic, cv, x, y, w, n, niterate, sigma)

pointer	ic		#I IC pointer
pointer	cv		#I CV pointer (initialized to desired fit)
double	x[n]		#I X values
double	y[n]		#I Y values
double	w[n]		#U Weight values
int	n		#I Number of points
int	niterate	#I Number of iterations
double	sigma		#I Sigma factor

int	i, nit, nrms, nrej
double	rms, fit, dcveval()

begin
	call dcvfit (cv, x, y, w, n, WTS_USER, i)

	do nit = 1, niterate {
	    rms = 0.
	    nrms = 0
	    do i = 1, n {
		if (w[i] <= 0D0)
		    next
		fit = dcveval (cv, x[i])
		if (fit <= 0D0)
		    next
		rms = rms + ((y[i] - fit) / sqrt (fit)) ** 2
		nrms = nrms + 1
	    }
	    if (nrms == 0)
		break
	    rms = sigma * sqrt (rms / nrms)

	    nrej = 0
	    do i = 1, n {
		if (w[i] <= 0D0)
		    next
		fit = dcveval (cv, x[i])
		if (fit <= 0D0)
		    next
		if (abs ((y[i] - fit) / sqrt (fit)) > rms) {
		    w[i] = 0.
		    nrej = nrej + 1
		}
	    }
	    if (nrej == 0)
		break
	    call dcvfit (cv, x, y, w, n, WTS_USER, i)
	}

	call imat_ic1 (ic, x, y, w, n)
end


# IMAT_SCALE -- Independent scale factors for each pair of images are
# combined into a set of self-consistent scale factors using the relations
#
#    a[k,i] = a[k,j] * a[j,i]
#    b[k,i] = a[k,j] * b[j,i] + b[k,j]

procedure imat_scale (a, b, nimages)

double	a[nimages,nimages,2]	#U Scale factors
double	b[nimages,nimages,2]	#U Zero factors
int	nimages			#I Number of images

int	j, k, n 
double	val, sig, mean, err, stddev
pointer	sp, scale, zero, sstddev, zstddev

begin
	call smark (sp)
	call salloc (scale, nimages, TY_DOUBLE)
	call salloc (zero, nimages, TY_DOUBLE)
	call salloc (sstddev, nimages, TY_DOUBLE)
	call salloc (zstddev, nimages, TY_DOUBLE)

	do k = 1, nimages {

	    # a[k,1]
	    val = a[k,1,1]
	    sig = a[k,1,2]
	    mean = val
	    stddev = val**2
	    err = sig**2

	    # a[k,1] = 1 / a[1,k]
	    call imat_eprop ("/", 1D0, 0D0, a[1,k,1], a[1,k,2], val, sig)
	    mean = mean + val
	    stddev = stddev + val**2
	    err = err + sig**2

	    n = 2
	    do j = 2, nimages {
		if (j == k)
		    next

		# a[k,1] = a[k,j] * a[j,1]
		call imat_eprop ("*", a[k,j,1], a[k,j,2], a[j,1,1], a[j,1,2],
		    val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# a[k,1] = a[k,j] / a[1,j]
		call imat_eprop ("/", a[k,j,1], a[k,j,2], a[1,j,1], a[1,j,2],
		    val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# a[k,1] = a[j,1] / a[j,k]
		call imat_eprop ("/", a[j,1,1], a[j,1,2], a[j,k,1], a[j,k,2],
		    val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# a[k,1] = 1 / (a[j,k] * a[1,j])
		call imat_eprop ("*", a[j,k,1], a[j,k,2], a[1,j,1], a[1,j,2],
		    val, sig)
		call imat_eprop ("/", 1D0, 0D0, val, sig, val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		n = n + 4
	    }

	    # Factor of nimages is currently a fudge factor until
	    # I understand the systematics.
	    mean = mean / n
	    stddev = nimages * (stddev - n * mean * mean) / (n - 1)
	    err = nimages * err / n**2

	    Memd[scale+k-1] = mean
	    if (stddev < 0.)
		Memd[sstddev+k-1] = sqrt (err)
	    else
		Memd[sstddev+k-1] = sqrt (err + stddev)
	}

	do k = 1, nimages {

	    # b[k,1]
	    val = b[k,1,1]
	    sig = b[k,1,2]
	    mean = val
	    stddev = val**2
	    err = sig**2

	    # b[k,1] = -b[1,k] / a[1,k]
	    call imat_eprop ("/", -b[1,k,1], b[1,k,2], a[1,k,1], a[1,k,2],
		val, sig)
	    mean = mean + val
	    stddev = stddev + val**2
	    err = err + sig**2

	    # b[k,1] = -b[1,k] * a[k,1]
	    call imat_eprop ("*", -b[1,k,1], b[1,k,2], a[k,1,1], a[k,1,2],
		val, sig)
	    mean = mean + val
	    stddev = stddev + val**2
	    err = err + sig**2

	    n = 3
	    do j = 2, nimages {
		if (j == k)
		    next

		# b[k,1] = b[j,1] * a[k,j] + b[k,j]
		call imat_eprop ("*", b[j,1,1], b[j,1,2], a[k,j,1], a[k,j,2],
		    val, sig)
		call imat_eprop ("+", val, sig, b[k,j,1], b[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = (b[j,1] - b[j,k]) / a[j,k]
		call imat_eprop ("-", b[j,1,1], b[j,1,2], b[j,k,1], b[j,k,2],
		    val, sig)
		call imat_eprop ("/", val, sig, a[j,k,1], a[j,k,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = -b[1,j] / a[1,j] * a[k,j] + b[k,j]
		call imat_eprop ("/", -b[1,j,1], b[1,j,2], a[1,j,1], a[1,j,2],
		    val, sig)
		call imat_eprop ("*", val, sig, a[k,j,1], a[k,j,2], val, sig)
		call imat_eprop ("+", val, sig, b[k,j,1], b[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = (-b[1,j] / a[1,j] - b[j,k]) / a[j,k]
		call imat_eprop ("/", -b[1,j,1], b[1,j,2], a[1,j,1], a[1,j,2],
		    val, sig)
		call imat_eprop ("-", val, sig, b[j,k,1], b[j,k,2], val, sig)
		call imat_eprop ("/", val, sig, a[j,k,1], a[j,k,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = b[j,1] / a[j,k] + b[k,j]
		call imat_eprop ("/", b[j,1,1], b[j,1,2], a[j,k,1], a[j,k,2],
		    val, sig)
		call imat_eprop ("+", val, sig, b[k,j,1], b[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = (b[j,1] - b[j,k]) * a[k,j]
		call imat_eprop ("-", b[j,1,1], b[j,1,2], b[j,k,1], b[j,k,2],
		    val, sig)
		call imat_eprop ("*", val, sig, a[k,j,1], a[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = -b[1,j] / a[1,j] / a[j,k] + b[k,j]
		call imat_eprop ("/", -b[1,j,1], b[1,j,2], a[1,j,1], a[1,j,2],
		    val, sig)
		call imat_eprop ("/", val, sig, a[j,k,1], a[j,k,2], val, sig)
		call imat_eprop ("+", val, sig, b[k,j,1], b[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = (-b[1,j] / a[1,j] - b[j,k]) * a[k,j]
		call imat_eprop ("/", -b[1,j,1], b[1,j,2], a[1,j,1], a[1,j,2],
		    val, sig)
		call imat_eprop ("-", val, sig, b[j,k,1], b[j,k,2], val, sig)
		call imat_eprop ("*", val, sig, a[k,j,1], a[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = -b[1,j] * a[j,1] * a[k,j] + b[k,j]
		call imat_eprop ("*", -b[1,j,1], b[1,j,2], a[j,1,1], a[j,1,2],
		    val, sig)
		call imat_eprop ("*", val, sig, a[k,j,1], a[k,j,2], val, sig)
		call imat_eprop ("+", val, sig, b[k,j,1], b[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = (-b[1,j] * a[j,1] - b[j,k]) / a[j,k]
		call imat_eprop ("*", -b[1,j,1], b[1,j,2], a[j,1,1], a[j,1,2],
		    val, sig)
		call imat_eprop ("-", val, sig, b[j,k,1], b[j,k,2], val, sig)
		call imat_eprop ("/", val, sig, a[j,k,1], a[j,k,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = -b[1,j] * a[j,1] / a[j,k] + b[k,j]
		call imat_eprop ("*", -b[1,j,1], b[1,j,2], a[j,1,1], a[j,1,2],
		    val, sig)
		call imat_eprop ("/", val, sig, a[j,k,1], a[j,k,2], val, sig)
		call imat_eprop ("+", val, sig, b[k,j,1], b[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		# b[k,1] = (-b[1,j] * a[j,1] - b[j,k]) * a[k,j]
		call imat_eprop ("*", -b[1,j,1], b[1,j,2], a[j,1,1], a[j,1,2],
		    val, sig)
		call imat_eprop ("-", val, sig, b[j,k,1], b[j,k,2], val, sig)
		call imat_eprop ("*", val, sig, a[k,j,1], a[k,j,2], val, sig)
		mean = mean + val
		stddev = stddev + val**2
		err = err + sig**2

		n = n + 12
	    }

	    # Factor of nimages is currently a fudge factor until
	    # I understand the systematics.
	    mean = mean / n
	    stddev = nimages * (stddev - n * mean * mean) / (n - 1)
	    err = nimages * err / n**2

	    Memd[zero+k-1] = mean
	    if (stddev < 0.)
		Memd[zstddev+k-1] = sqrt (err)
	    else
		Memd[zstddev+k-1] = sqrt (err + stddev)
	}

	call imat_fix (Memd[scale], Memd[zero], Memd[sstddev], Memd[zstddev],
	    a, b, nimages)

	call sfree (sp)
end


# IMAT_EPROP -- Error propagation.

procedure imat_eprop (op, x, sx, y, sy, z, sz)

char	op
double	x, sx
double	y, sy
double	z, sz

double	ymin, val, sig

begin
	switch (op) {
	case '+':
	    val = x + y
	    sig = sqrt (sx**2 + sy**2)
	case '-':
	    val = x - y
	    sig = sqrt (sx**2 + sy**2)
	case '*':
	    val = x * y
	    sig = sqrt ((y * sx) ** 2 + (x * sy) ** 2)
	case '/':
	    ymin = max (1D-3, y)
	    val = x / ymin
	    sig = sqrt ((sx ** 2 + (x / ymin * sy) ** 2) / ymin ** 2)
	}
	z = val
	sz = sig
end


# IMAT_FIX -- Given a single set of scale factors relative to one image
# fix the scale factors for all pairs of images.

procedure imat_fix (scale, zero, sstddev, zstddev, a, b, nimages)

double	scale[nimages]		#I Scale factors
double	zero[nimages]		#I Zero factors
double	sstddev[nimages]	#I Standard deviation of scale factors
double	zstddev[nimages]	#I Standard deviation of zero factors
double	a[nimages,nimages,2]	#O Scale factors
double	b[nimages,nimages,2]	#O Zero factors
int	nimages			#I Number of images

int	j, k

begin
	do k = 1, nimages {
	    do j = 1, nimages {
		if (j == k)
		    next
		a[k,j,1] = scale[k] / scale[j]
		call imat_eprop ("/", scale[k], sstddev[k], scale[j],
		    sstddev[j], a[k,j,1], a[k,j,2])

		# b[k,j] = zero[k] - a[k,j] * zero[j]
		call imat_eprop ("*", zero[j], zstddev[j], a[k,j,1],
		    a[k,j,2], b[k,j,1], b[k,j,2])
		call imat_eprop ("-", zero[k], zstddev[k], b[k,j,1],
		    b[k,j,2], b[k,j,1], b[k,j,2])
	    }
	}
end


# IMAT_REJ -- Use the residuals from all pairs of images taken together
# to sigma clip.

procedure imat_rej (ic, data, wts, a, b, nimages, nreg, sigma, nrej)

pointer	ic				#I IC pointer
double	data[nreg,nimages]		#I Photon counts
double	wts[nimages,nimages,nreg]	#U Weights for pairs of measurments
double	a[nimages,nimages,2]		#I Scale factors
double	b[nimages,nimages,2]		#I Zero factors
int	nimages				#I Number of images
int	nreg				#I Number of measurements per image
double	sigma				#I Sigma clipping factor
int	nrej				#O Number of data points rejected

int	i, j, k, nrms
double	rms, resid

begin
    	call imat_rms (data, wts, a, b, nimages, nreg, rms, nrms)
	if (nrms == 0)
	    return

	rms = sigma * rms
	do k = 1, nimages {
	    do j = 1, nimages {
		if (j == k)
		    next
		do i = 1, nreg {
		    if (IS_INDEFD(data[i,j]) || IS_INDEFD(data[i,k]))
			next
		    if (wts[j,k,i] <= 0D0)
			next
		    if (data[i,k] <= 0D0)
			next
		    resid = (data[i,k] - a[k,j,1] * data[i,j] - b[k,j,1]) /
			sqrt (data[i,k])
		    if (abs (resid) > rms) {
			wts[j,k,i] = 0.
			nrej = nrej + 1
		    }
		}
	    }
	}

	call imat_ic2 (ic, data, wts, a, b, nimages, nreg)
end


# IMAT_RMS -- Compute the RMS over all pairs of images excluding previously
# rejected pairs of measurements.  The residuals are given by
#
#    residual = (data[i,k] - (a[k,j] * data[i,j] - b[k,j])) / sqrt (data[i,k])

procedure imat_rms (data, wts, a, b, nimages, nreg, rms, nrms)

double	data[nreg,nimages]		#I Photon counts
double	wts[nimages,nimages,nreg]	#I Weights for pairs of measurments
double	a[nimages,nimages,2]		#I Scale factors
double	b[nimages,nimages,2]		#I Zero factors
int	nimages				#I Number of images
int	nreg				#I Number of measurements per image
double	rms				#O RMS
int	nrms				#O Number of values in RMS

int	i, j, k
double	resid

begin
	rms = 0.
	nrms = 0
	do k = 1, nimages {
	    do j = 1, nimages {
		if (j == k)
		    next
		do i = 1, nreg {
		    if (IS_INDEFD(data[i,j]) || IS_INDEFD(data[i,k]))
			next
		    if (wts[j,k,i] <= 0D0)
			next
		    if (data[i,k] <= 0D0)
			next
		    resid = (data[i,k] - a[k,j,1] * data[i,j] - b[k,j,1]) /
			sqrt (data[i,k])
		    rms = rms + resid ** 2
		    nrms = nrms + 1
		}
	    }
	}
	if (nrms > 0)
	    rms = sqrt (rms / nrms)

	#call printf ("nrms = %d, rms = %g\n")
	#    call pargi (nrms)
	#    call pargd (rms)
end


# IMAT_ICINIT -- Initialize ICG_FIT.

procedure imat_icinit (ic, input)

pointer	ic		#O ICG_FIT pointer
int	input		#I List of input images

int	inlist
pointer	gp, gt
common	/imat_ic/ gp, gt, inlist

pointer	gopen(), gt_init()

begin
	gp = gopen ("stdgraph", NEW_FILE, STDGRAPH)
	gt = gt_init ()
	call ic_open (ic)
	call ic_pstr (ic, "function", "chebyshev")
	call ic_puti (ic, "order", 2)
	call ic_puti (ic, "key", 1)
	inlist = input
end


# IMAT_ICFREE -- Free ICG_FIT.

procedure imat_icfree (ic)

pointer	ic		#O ICG_FIT pointer

int	inlist
pointer	gp, gt
common	/imat_ic/ gp, gt, inlist

begin
	if (ic == NULL)
	    return

	call ic_closed (ic)
	call gt_free (gt)
	call gclose (gp)
end


# IMAT_ICLABELS -- Set labels for ICG_FIT.

procedure imat_iclabels (ic, i, j)

pointer	ic		#I ICG_FIT pointer
int	i, j		#I Image indices

int	k, imtrgetim()
pointer	sp, label, imname1, imname2

int	inlist
pointer	gp, gt
common	/imat_ic/ gp, gt, inlist

begin
	if (ic == NULL)
	    return

	call smark (sp)
	call salloc (label, SZ_LINE, TY_CHAR)
	call salloc (imname1, SZ_FNAME, TY_CHAR)
	call salloc (imname2, SZ_FNAME, TY_CHAR)

	k = imtrgetim (inlist, i, Memc[imname1], SZ_LINE)
	k = imtrgetim (inlist, j, Memc[imname2], SZ_LINE)

	call sprintf (Memc[label], SZ_LINE, "Counts of %s vs %s")
	    call pargstr (Memc[imname2])
	    call pargstr (Memc[imname1])
	call gt_sets (gt, GTTITLE, Memc[label])
	call ic_pstr (ic, "xlabel", Memc[imname1])
	call ic_pstr (ic, "ylabel", Memc[imname2])
end

	
# IMAT_IC1 -- Routine to call ICG_FIT with a set of values.
# This can be called for a particular pair of images or for residuals from
# all pairs of images.

procedure imat_ic1 (ic, x, y, w, n)

pointer	ic		#I ICG_FIT pointer
double	x[n]		#I X values
double	y[n]		#I Y values
double	w[n]		#I Weight values
int	n		#I Number of points

int	i, j
pointer	sp, index, x1, y1, w1, cv

int	inlist
pointer	gp, gt
common	/imat_ic/ gp, gt, inlist

int	imat_comp()
extern	imat_comp

begin
	if (ic == NULL)
	    return

	call smark (sp)
	call salloc (index, n, TY_INT)
	call salloc (x1, n, TY_DOUBLE)
	call salloc (y1, n, TY_DOUBLE)
	call salloc (w1, n, TY_DOUBLE)

	do i = 1, n {
	    Memi[index+i-1] = i
	    Memd[x1+i-1] = x[i]
	}
	call gqsort (Memi[index], n, imat_comp, x1)
	do i = 0, n-1 {
	    j = Memi[index+i]
	    Memd[x1+i] = x[j]
	    Memd[y1+i] = y[j]
	    Memd[w1+i] = w[j]
	}
	call icg_fitd (ic, gp, "gcur", gt, cv, Memd[x1], Memd[y1], Memd[w1], n)

	do i = 0, n-1 {
	    j = Memi[index+i]
	    w[j] = Memd[w1+i]
	}

	call dcvfree (cv)
	call sfree (sp)
end


# IMAT_IC2 -- Routine to call ICG_FIT with residuals over all pairs of images.

procedure imat_ic2 (ic, data, wts, a, b, nimages, nreg)

pointer	ic				#I ICG_FIT pointer
double	data[nreg,nimages]		#I Photon counts
double	wts[nimages,nimages,nreg]	#I Weights for pairs of measurments
double	a[nimages,nimages,2]		#I Scale factors
double	b[nimages,nimages,2]		#I Zero factors
int	nimages				#I Number of images
int	nreg				#I Number of measurements per image

int	i, j, k, n
pointer	sp, x, y, w

begin
	if (ic == NULL)
	    return

	call smark (sp)
	call salloc (x, nimages*nimages*nreg, TY_DOUBLE)
	call salloc (y, nimages*nimages*nreg, TY_DOUBLE)
	call salloc (w, nimages*nimages*nreg, TY_DOUBLE)

	n = 0
	do k = 1, nimages {
	    do j = 1, nimages {
		if (j == k)
		    next
		do i = 1, nreg {
		    if (IS_INDEFD(data[i,j]) || IS_INDEFD(data[i,k]))
			next
		    if (data[i,k] <= 0D0)
			next
		    Memd[x+n] = data[i,j]
		    Memd[y+n] = (data[i,k] - a[k,j,1] * data[i,j] - b[k,j,1]) /
			sqrt (data[i,k])
		    Memd[w+n] = wts[j,k,i]
		    n = n + 1
		}
	    }
	}

	call imat_ic1 (ic, Memd[x], Memd[y], Memd[w], n)

	call sfree (sp)
end
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/t_mscpmask.x�������������������������������������������������������������0000664�0000000�0000000�00000002046�13321663143�0017111�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include	


# T_MSCPMASK -- Convert mscimage mask.
# This is a plio workaround replacement task for imexpr.

procedure t_mscpmask ()

pointer	input			# Input image
pointer	output			# Output image

int	i, j
real	val
pointer	sp, in, out, inbuf, outbuf
pointer	immap(), imgl2r(), impl2i()

begin
	call smark (sp)
	call salloc (input, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)

	# Get file names.
	call clgstr ("input", Memc[input], SZ_FNAME)
	call clgstr ("output", Memc[output], SZ_FNAME)

	# Map images.  It is assumed the caller has specified
	# a mask output type.
	in = immap (Memc[input], READ_ONLY, 0)
	out = immap (Memc[output], NEW_COPY, in)
	IM_PIXTYPE(out) = TY_INT

	# Copy the pixels.  This assumes 2D images.
	do i = 1, IM_LEN(in,2) {
	    inbuf = imgl2r (in, i)
	    outbuf = impl2i (out, i)
	    do j = 0, IM_LEN(in,1)-1 {
		val = abs (Memr[inbuf+j])
		if (val < 1.)
		    Memi[outbuf+j] = 0
		else
		    Memi[outbuf+j] = val / 10010 + 1
	    }
	}

	# Finish up.
	call imunmap (out)
	call imunmap (in)
	call sfree (sp)
end
������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/t_msctmplt.x�������������������������������������������������������������0000664�0000000�0000000�00000043162�13321663143�0017142�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include 
include 
include 
include 
include 

# T_MSCTEMPLATE -- Make an empty template image into which the input images
# can be transformed based on their WCS.  The image will be just large enough
# to include all the input images (based only on the image corners).  The
# output image WCS is either the first input WCS or that of a reference
# image.   The WCS reference coordinate value is shifted by an integer number
# of pixels to preserve the same logical coordinate reference pixel; i.e. the
# tangent point is tied to an image pixel and not to a point on the sky.
# When a reference image is given the output image WCS is such that an
# integer shift in the two image axes is all that is needed to align the
# images.

procedure t_msctemplate ()

int	input		# List of images
pointer output		# Output image
pointer ref		# Reference image
real	blank		# Blank value
int	border		# Border width
pointer proj		# WCS projection
int	pixtype		# Pixel type
int	bufsize		# I/O buffer size in Mb

short	blanks
int	i, nimages, refim, xshift, yshift, axes[2]
double	r[2], wcsref[2,3], lterm[2,3], r2, r2min, temp[2,2]
double	x, y, wx, wy, xmin, xmax, ymin, ymax
double	wxmin[4], wxmax[4], wymin[4], wymax[4]
pointer sp, image, attrib, out, im, mw, wcs, mwref, tmp

bool	strne(), streq()
real	clgetr()
int	clgeti(), clgwrd(), imtopenp(), imtgetim(), imtrgetim()
pointer	nowhite(), imaccess(), msc_openim(), msc_sctran()
pointer immap(), mw_openim(), mw_open(), impl2r(), impl2s()
errchk	immap
errchk	mw_openim, msc_open, msc_openim, mw_saveim, mw_gwtermd, mw_swtermd
errchk	msc_sctran, msc_c2trand

data	axes/1,2/

begin
	call smark (sp)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)
	call salloc (ref, SZ_FNAME, TY_CHAR)
	call salloc (proj, SZ_FNAME, TY_CHAR)
	call salloc (attrib, SZ_FNAME, TY_CHAR)

	# Get task parameters.
	input = imtopenp ("input")
	call clgstr ("output", Memc[output], SZ_FNAME)
	call clgstr ("reference", Memc[ref], SZ_FNAME)
	blank = clgetr ("blank")
	border = clgeti ("border")
	call clgstr ("projection", Memc[proj], SZ_FNAME)
	pixtype = clgwrd ("pixtype", Memc[attrib], SZ_FNAME, "|short|real|")
	#bufsize = max (1024., 1E6 * clgetr ("im_bufsize"))
	bufsize = 65000.

	switch (pixtype) {
	case 1:
	    pixtype = TY_SHORT
	    blanks = blank
	case 2:
	    pixtype = TY_REAL
	}

	# Check the output image is specified and does not exist.
	# Check if a reference image is specified.  It is an error if it
	# is specified and does not exist unless it is the same as the
	# output image.

	out = NULL
	mwref = NULL
	if (nowhite (Memc[output], Memc[output], SZ_FNAME) == 0)
	    call error (1, "No output image specified")
	if (imaccess (Memc[output], 0) == YES)
	    call error (1, "Output image already exists")
	if (nowhite (Memc[ref], Memc[ref], SZ_FNAME) > 0) {
	    if (strne (Memc[ref], Memc[output])) {
		im = immap (Memc[ref], READ_ONLY, 0)
		mwref = mw_openim (im)
		call imunmap (im)
	    }
	}

	# Determine the world coordinate limits.  Set the reference image
	# to the image closest to it's tangent point if no reference image is
	# specified.  It is a warning if an input images cannot be accessed.
	# It is a fatal error if the output image can't be created as a copy
	# of the first accessible input image.

	wxmin[1] = MAX_DOUBLE; wxmax[1] = -MAX_DOUBLE;
	wymin[2] = MAX_DOUBLE; wymax[2] = -MAX_DOUBLE
	nimages = 0
	r2min = MAX_DOUBLE
	while (imtgetim (input, Memc[image], SZ_FNAME) != EOF) {
	    iferr {
		im = NULL; mw = NULL; wcs = NULL

		tmp = immap (Memc[image], READ_ONLY, 0); im = tmp
		tmp = msc_openim (im, wcs); mw = tmp
		tmp = msc_sctran (wcs, 1, "logical", "astrometry", 3)
		tmp = msc_sctran (wcs, 2, "astrometry", "world", 3)
		tmp = msc_sctran (wcs, 3, "astrometry", "logical", 3)

		# Find closest image to it's own tangent point.
		call msc_c2trand (wcs, 3, 0D0, 0D0, xmin, ymin)
		x = max (1D0, min (double(IM_LEN(im,1)), xmin))
		y = max (1D0, min (double(IM_LEN(im,2)), ymin))
		r2 = (x - xmin)**2 + (y - ymin)**2
		if (r2 < r2min) {
		    refim = nimages + 1
		    r2min = r2
		}

		# Find limits.  Use astrometry coordinates to avoid problems
		# at poles and prime meridian.
		xmin = 1; xmax = IM_LEN(im,1)
		ymin = 1; ymax = IM_LEN(im,2)
		call msc_c2trand (wcs, 1, xmin, ymin, x, y)
		call msc_c2trand (wcs, 2, x, y, wx, wy)
		if (x < wxmin[1]) {
		    wxmin[1] = x; wxmin[2] = y; wxmin[3] = wx; wxmin[4] = wy
		}
		if (x > wxmax[1]) {
		    wxmax[1] = x; wxmax[2] = y; wxmax[3] = wx; wxmax[4] = wy
		}
		if (y < wymin[2]) {
		    wymin[1] = x; wymin[2] = y; wymin[3] = wx; wymin[4] = wy
		}
		if (y > wymax[2]) {
		    wymax[1] = x; wymax[2] = y; wymax[3] = wx; wymax[4] = wy
		}
		call msc_c2trand (wcs, 1, xmax, ymin, x, y)
		call msc_c2trand (wcs, 2, x, y, wx, wy)
		if (x < wxmin[1]) {
		    wxmin[1] = x; wxmin[2] = y; wxmin[3] = wx; wxmin[4] = wy
		}
		if (x > wxmax[1]) {
		    wxmax[1] = x; wxmax[2] = y; wxmax[3] = wx; wxmax[4] = wy
		}
		if (y < wymin[2]) {
		    wymin[1] = x; wymin[2] = y; wymin[3] = wx; wymin[4] = wy
		}
		if (y > wymax[2]) {
		    wymax[1] = x; wymax[2] = y; wymax[3] = wx; wymax[4] = wy
		}
		call msc_c2trand (wcs, 1, xmin, ymax, x, y)
		call msc_c2trand (wcs, 2, x, y, wx, wy)
		if (x < wxmin[1]) {
		    wxmin[1] = x; wxmin[2] = y; wxmin[3] = wx; wxmin[4] = wy
		}
		if (x > wxmax[1]) {
		    wxmax[1] = x; wxmax[2] = y; wxmax[3] = wx; wxmax[4] = wy
		}
		if (y < wymin[2]) {
		    wymin[1] = x; wymin[2] = y; wymin[3] = wx; wymin[4] = wy
		}
		if (y > wymax[2]) {
		    wymax[1] = x; wymax[2] = y; wymax[3] = wx; wymax[4] = wy
		}
		call msc_c2trand (wcs, 1, xmax, ymax, x, y)
		call msc_c2trand (wcs, 2, x, y, wx, wy)
		if (x < wxmin[1]) {
		    wxmin[1] = x; wxmin[2] = y; wxmin[3] = wx; wxmin[4] = wy
		}
		if (x > wxmax[1]) {
		    wxmax[1] = x; wxmax[2] = y; wxmax[3] = wx; wxmax[4] = wy
		}
		if (y < wymin[2]) {
		    wymin[1] = x; wymin[2] = y; wymin[3] = wx; wymin[4] = wy
		}
		if (y > wymax[2]) {
		    wymax[1] = x; wymax[2] = y; wymax[3] = wx; wymax[4] = wy
		}

		nimages = nimages + 1
	    } then
		call erract (EA_WARN)

	    if (mw != NULL)
		call msc_close (wcs)
	    if (im != NULL)
		call imunmap (im)
	}

	# Create the empty output image using reference WCS.
	# The size of the output image is that just enclosing all the input
	# images.  Shift the reference point by an integer number of logical
	# pixels.

	if (nimages > 0) {
	    iferr {
		im = NULL; mw = NULL; wcs = NULL; out = NULL

		i = imtrgetim (input, refim, Memc[image], SZ_FNAME)
		tmp = immap (Memc[image], READ_ONLY, 0); im = tmp
		tmp = immap (Memc[output], NEW_COPY, im); out = tmp
		call imseti (out, IM_BUFSIZE, bufsize)
		if (mwref == NULL)
		    mwref = mw_openim (im)

		mw = mw_open (NULL, 2)
		call mw_gsystem (mwref, Memc[attrib], SZ_FNAME)
		call mw_newsystem (mw, Memc[attrib], 2)
		if (nowhite (Memc[proj], Memc[attrib], SZ_FNAME) == 0)
		    call mw_gwattrs (mwref, 1, "wtype", Memc[attrib], SZ_FNAME)
		if (streq (Memc[attrib], "tnx") ||
		    streq (Memc[attrib], "zpx") ||
		    streq (Memc[attrib], "zpn"))
		    call strcpy ("tan", Memc[attrib], SZ_LINE)
		call mw_swtype (mw, axes, 2, Memc[attrib], "")
		call mw_gwattrs (mwref, 1, "axtype", Memc[attrib], SZ_FNAME)
		call mw_swattrs (mw, 1, "axtype", Memc[attrib])
		call mw_gwattrs (mwref, 2, "axtype", Memc[attrib], SZ_FNAME)
		call mw_swattrs (mw, 2, "axtype", Memc[attrib])
		call mw_gwtermd (mwref, r, wcsref[1,3], wcsref, 2)
		call mw_gltermd (mwref, lterm, lterm[1,3], 2)
		call mwvmuld (lterm, r, temp, 2)
		call aaddd (temp, lterm[1,3], r, 2)
		call mwinvertd (lterm, temp, 2)
		call amovd (wcsref, lterm, 4)
		call mwmmuld (lterm, temp, wcsref, 2)
		call mw_swtermd (mw, r, wcsref[1,3], wcsref, 2)
		call mw_close (mwref)

		# Find pixel limints in new WCS using world coordinates.
		call msc_open (mw, wcs)
		tmp = msc_sctran (wcs, 1, "world", "logical", 3)
		xmin = MAX_DOUBLE; xmax = -MAX_DOUBLE
		ymin = MAX_DOUBLE; ymax = -MAX_DOUBLE
		call msc_c2trand (wcs, 1, wxmin[3], wxmin[4], x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)
		call msc_c2trand (wcs, 1, wxmax[3], wxmax[4], x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)
		call msc_c2trand (wcs, 1, wymin[3], wymin[4], x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)
		call msc_c2trand (wcs, 1, wymax[3], wymax[4], x, y)
		xmin = min (x, xmin); xmax = max (x, xmax)
		ymin = min (y, ymin); ymax = max (y, ymax)

		xshift = nint (1.5 - xmin + border)
		yshift = nint (1.5 - ymin + border)
		r[1] = r[1] + xshift
		r[2] = r[2] + yshift
		call mw_swtermd (mw, r, wcsref[1,3], wcsref, 2)

		IM_PIXTYPE(out) = pixtype
		IM_NDIM(out) = 2
		IM_LEN(out,1) = nint (xmax + xshift + 0.5 + border)
		IM_LEN(out,2) = nint (ymax + yshift + 0.5 + border)
		iferr (call imdelf (out, "wcssol"))
		    ;
		call mw_saveim (mw, out)

		switch (IM_PIXTYPE(out)) {
		case TY_SHORT:
		    if (blanks == 0)
			do i = 1, IM_LEN(out,2)
			    call aclrs (Mems[impl2s(out,i)], IM_LEN(out,1))
		    else
			do i = 1, IM_LEN(out,2)
			    call amovks (blanks, Mems[impl2s(out,i)],
				IM_LEN(out,1))
		case TY_REAL:
		    if (blank == 0.)
			do i = 1, IM_LEN(out,2)
			    call aclrr (Memr[impl2r(out,i)], IM_LEN(out,1))
		    else
			do i = 1, IM_LEN(out,2)
			    call amovkr (blank, Memr[impl2r(out,i)],
				IM_LEN(out,1))
		}
	    } then
		call erract (EA_WARN)

	    if (wcs != NULL)
	       call msc_close (wcs)
	    else if (mw != NULL)
		call mw_close (mw)
	    if (mwref != NULL)
		call mw_close (mwref)
	    if (out != NULL)
		call imunmap (out)
	    if (im != NULL)
		call imunmap (im)
	}

	call imtclose (input)
	call sfree (sp)
end


# T_MSCWTEMPLATE -- Make WCS template.
# The output image WCS is either the first input WCS or that of a reference
# image.   The WCS reference coordinate value is shifted by an integer number
# of pixels to preserve the same logical coordinate reference pixel; i.e. the
# tangent point is tied to an image pixel and not to a point on the sky.
# When a reference image is given the output image WCS is such that an
# integer shift in the two image axes is all that is needed to align the
# images.

procedure t_mscwtemplate ()

int	input		# List of images
pointer output		# Output image
int	wcssource	# WCS source
pointer ref		# Reference image
double	ra		# RA
double	dec		# DEC
double	scale		# Scale
double	rot		# Rotation
pointer proj		# WCS projection
bool	verbose		# Verbose?

bool	needref
int	i, nimages, refim, axes[2]
double	x, y, xref, yref, r2, r2min, r[2], wcsref[2,3], lterm[2,3]
pointer sp, image, attrib, out, im, mw, wcs, mwref, tmp

bool	clgetb(), strne(), streq()
int	clgwrd(), imtopenp(), imtgetim(), imtrgetim(), nowhite(), imaccess()
double	clgetd()
pointer immap(), impl1s(), mw_openim(), mw_open(), msc_openim(), msc_sctran()
errchk	immap, impl1s
errchk	mw_openim, mw_open, msc_openim, mw_saveim, msc_sctran, msc_c2trand

data	axes/1,2/

begin
	call smark (sp)
	call salloc (image, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)
	call salloc (ref, SZ_FNAME, TY_CHAR)
	call salloc (proj, SZ_FNAME, TY_CHAR)
	call salloc (attrib, SZ_FNAME, TY_CHAR)

	# Get task parameters.
	input = imtopenp ("input")

	call clgstr ("output", Memc[output], SZ_FNAME)
	if (nowhite (Memc[output], Memc[output], SZ_FNAME) == 0)
	    call error (1, "No output image specified")
	if (imaccess (Memc[output], 0) == YES)
	    call error (1, "Output image already exists")

	verbose = clgetb ("verbose")

	wcssource = clgwrd ("wcssource", Memc[attrib], SZ_FNAME,
	    "|image|parameters|")
	switch (wcssource) {
	case 1:
	    call clgstr ("reference", Memc[ref], SZ_FNAME)
	    call clgstr ("projection", Memc[proj], SZ_FNAME)
	    i = nowhite (Memc[proj], Memc[proj], SZ_FNAME)

	    needref = true
	case 2:
	    ra = clgetd ("ra")
	    dec = clgetd ("dec")
	    scale = clgetd ("scale")
	    rot = clgetd ("rotation")
	    call clgstr ("projection", Memc[proj], SZ_FNAME)

	    if (!IS_INDEFD(ra))
		ra = ra * 15
	    if (!IS_INDEFD(scale))
		scale = scale / 3600.
	    if (!IS_INDEFD(rot))
		rot = DEGTORAD(rot)
	    i = nowhite (Memc[proj], Memc[proj], SZ_FNAME)

	    needref = (IS_INDEFD(ra) || IS_INDEFD(dec) || IS_INDEFD(scale))
	    needref = (needref || IS_INDEFD(rot) || Memc[proj] == EOS)
	    if (needref)
		call clgstr ("reference", Memc[ref], SZ_FNAME)

	default:
	    call error (1, "Unrecognized WCS source")
	}


	# Get reference WCS image if needed.
	if (needref) {

	    # Check if a reference WCS image is specified.  It is an
	    # error if it is specified and does not exist unless it is the
	    # same as the output image.

	    mwref = NULL
	    if (nowhite (Memc[ref], Memc[ref], SZ_FNAME) > 0) {
		if (strne (Memc[ref], Memc[output])) {
		    if (verbose) {
			call printf ("WCS reference image is %s\n")
			    call pargstr (Memc[ref])
		    }
		    im = immap (Memc[ref], READ_ONLY, 0)
		    mwref = mw_openim (im)
		    call imunmap (im)
		}
	    }

	    # If there is no WCS reference specified set it to the image
	    # closest to it's tangent point.  It is a warning if an input
	    # image cannot be accessed.

	    if (mwref == NULL) {
		nimages = 0
		r2min = MAX_DOUBLE
		while (imtgetim (input, Memc[image], SZ_FNAME) != EOF) {
		    iferr {
			im = NULL; mw = NULL; wcs = NULL

			tmp = immap (Memc[image], READ_ONLY, 0); im = tmp
			tmp = msc_openim (im, wcs); mw = tmp
			tmp = msc_sctran (wcs, 1, "astrometry", "logical", 3)

			# Find closest image to it's own tangent point.
			call msc_c2trand (wcs, 1, 0D0, 0D0, xref, yref)
			x = max (1D0, min (double(IM_LEN(im,1)), xref))
			y = max (1D0, min (double(IM_LEN(im,2)), yref))
			r2 = (x - xref)**2 + (y - yref)**2
			if (r2 < r2min) {
			    refim = nimages + 1
			    r2min = r2
			}
			nimages = nimages + 1
		    } then
			call erract (EA_WARN)

		    if (mw != NULL)
			call msc_close (wcs)
		    if (im != NULL)
			call imunmap (im)
		}

		if (nimages == 0)
		    call error (1, "No input images found")

		i = imtrgetim (input, refim, Memc[image], SZ_FNAME)
		if (verbose) {
		    call printf ("WCS reference image is %s\n")
			call pargstr (Memc[image])
		}
		im = immap (Memc[image], READ_ONLY, 0)
		mwref = mw_openim (im)
		call imunmap (im)
	    }
	}

	# Set WCS from parameters.
	if (wcssource == 2) {
	    if (needref) {
		call mw_gwtermd (mwref, r, wcsref[1,3], wcsref, 2)
		call mw_gltermd (mwref, lterm, lterm[1,3], 2)
		call mwvmuld (lterm, r, r, 2)
		call aaddd (r, lterm[1,3], r, 2)
		call mwinvertd (lterm, lterm, 2)
		call mwmmuld (wcsref, lterm, wcsref, 2)
		call mw_gwattrs (mwref, 2, "axtype", Memc[attrib], SZ_FNAME)
		if (streq (Memc[attrib], "RA")) {
		    x = wcsref[1,3]
		    wcsref[1,3] = wcsref[2,3]
		    wcsref[2,3] = x
		    x = wcsref[1,1]
		    wcsref[1,1] = wcsref[2,2]
		    wcsref[2,2] = x
		    x = wcsref[1,2]
		    wcsref[1,2] = wcsref[2,1]
		    wcsref[2,1] = x
		}
		if (IS_INDEFD(ra))
		    ra = wcsref[1,3]
		if (IS_INDEFD(dec))
		    dec = wcsref[2,3]
		if (IS_INDEFD(scale))
		    scale = sqrt (abs(wcsref[1,2] * wcsref[2,1]) +
			abs (wcsref[1,1] * wcsref[2,2]))
		if (IS_INDEFD(rot))
		    rot = atan2 (-wcsref[2,1], wcsref[2,2])
		if (Memc[proj] == EOS)
		    call mw_gwattrs (mwref, 1, "wtype", Memc[proj], SZ_FNAME)

		call mw_close (mwref)
	    }

	    if (verbose) {
		call printf ("Output WCS parameters:\n")
	    call printf ("    RA=%.2H, DEC=%.1h")
		call pargd (ra)
		call pargd (dec)
	    call printf (", SCALE=%.3g arcsec/pixel, ROTATION=%.4g degrees\n")
		call pargd (scale*3600.)
		call pargd (RADTODEG(rot))
	    }

	    wcsref[1,1] = -scale * cos (rot)
	    wcsref[1,2] = -scale * sin (rot)
	    wcsref[2,1] = -scale * sin (rot)
	    wcsref[2,2] = scale * cos (rot)
	    wcsref[1,3] = ra
	    wcsref[2,3] = dec
	    r[1] = 0.
	    r[2] = 0.

	    mwref = mw_open (NULL, 2)
	    call mw_newsystem (mwref, "image", 2)
	    call mw_swtype (mwref, axes, 2, Memc[proj], "")
	    call mw_swattrs (mwref, 1, "axtype", "ra")
	    call mw_swattrs (mwref, 2, "axtype", "dec")
	    call mw_swtermd (mwref, r, wcsref[1,3], wcsref, 2)
	}


	# Create WCS template image.  This is an 2D image with 1 pixel.
	# The only change to the reference WCS is to set the projection
	# type.  The tnx, zpx, and zpn projections are converted to tan.

	iferr {
	    mw = NULL; out = NULL

	    # Set WCS.

	    mw = mw_open (NULL, 2)
	    call mw_gsystem (mwref, Memc[attrib], SZ_FNAME)
	    call mw_newsystem (mw, Memc[attrib], 2)
	    if (nowhite (Memc[proj], Memc[attrib], SZ_FNAME) == 0)
		call mw_gwattrs (mwref, 1, "wtype", Memc[attrib], SZ_FNAME)
	    if (streq (Memc[attrib], "tnx") ||
	        streq (Memc[attrib], "zpx") ||
	        streq (Memc[attrib], "zpn"))
		call strcpy ("tan", Memc[attrib], SZ_LINE)
	    call mw_swtype (mw, axes, 2, Memc[attrib], "")
	    call mw_gwattrs (mwref, 1, "axtype", Memc[attrib], SZ_FNAME)
	    call mw_swattrs (mw, 1, "axtype", Memc[attrib])
	    call mw_gwattrs (mwref, 2, "axtype", Memc[attrib], SZ_FNAME)
	    call mw_swattrs (mw, 2, "axtype", Memc[attrib])
	    call mw_gwtermd (mwref, r, wcsref[1,3], wcsref, 2)
	    call mw_gltermd (mwref, lterm, lterm[1,3], 2)
	    call mwvmuld (lterm, r, r, 2)
	    call aaddd (r, lterm[1,3], r, 2)
	    call mwinvertd (lterm, lterm, 2)
	    call mwmmuld (wcsref, lterm, wcsref, 2)
	    call mw_swtermd (mw, r, wcsref[1,3], wcsref, 2)

	    # Create WCS template image.
	    tmp = immap (Memc[output], NEW_IMAGE, 0); out = tmp
	    IM_NDIM(out) = 2
	    IM_LEN(out,1) = 1
	    IM_LEN(out,2) = 1
	    IM_PIXTYPE(out) = TY_INT
	    Mems[impl1s(out)] = 0
	    call mw_saveim (mw, out)
	    call imunmap (out)
	    call mw_close (mw)
	    call mw_close (mwref)
	} then {
	    call erract (EA_WARN)
	    if (mw != NULL)
		call mw_close (mw)
	    if (mwref != NULL)
		call mw_close (mwref)
	    if (out != NULL) {
		call imunmap (out)
		iferr (call delete (Memc[output]))
		    ;
	    }
	}

	call imtclose (input)
	call sfree (sp)
end
��������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/t_mscuniq.x��������������������������������������������������������������0000664�0000000�0000000�00000002740�13321663143�0016753�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include	


# T_MSCUNIQ -- This task is a utility used in the CCDPROC script.
# It takes a list of images and extracts the first occurance of each rootname.

procedure t_mscuniq ()

int	i, n, fin, fout, open(), fscan(), nscan()
pointer	sp, fname, str, list
bool	streq()
errchk	open

begin
	call smark (sp)
	call salloc (fname, SZ_FNAME, TY_CHAR)
	call salloc (str, SZ_LINE, TY_CHAR)

	iferr {
	    call clgstr ("input", Memc[fname], SZ_FNAME)
	    fin = NULL
	    i = open (Memc[fname], READ_ONLY, TEXT_FILE); fin = i
	    call clgstr ("output", Memc[fname], SZ_FNAME)
	    fout = NULL
	    i = open (Memc[fname], NEW_FILE, TEXT_FILE); fout = i

	    n = 0
	    while (fscan (fin) != EOF) {
		call gargwrd (Memc[fname], SZ_FNAME)
		call gargstr (Memc[str], SZ_LINE)
		if (nscan() < 1)
		    next
		call imgcluster (Memc[fname], Memc[fname], SZ_FNAME)
		do i = 0, n-1 {
		    if (streq (Memc[fname], Memc[Memi[list+i]]))
			break
		}
		if (i < n)
		    next

		if (n == 0)
		    call malloc (list, 10, TY_POINTER)
		else if (mod (n, 10) == 0)
		    call realloc (list, n+10, TY_POINTER)

		call salloc (Memi[list+n], SZ_FNAME, TY_CHAR)
		call strcpy (Memc[fname], Memc[Memi[list+n]], SZ_FNAME)
		n = n + 1

		call fprintf (fout, "%s %s\n")
		    call pargstr (Memc[fname])
		    call pargstr (Memc[str])
	    }
	} then
	    call erract (EA_WARN)

	if (n > 0)
	    call mfree (list, TY_POINTER)
	if (fout != NULL)
	    call close (fout)
	if (fin != NULL)
	    call close (fin)
	call sfree (sp)
end
��������������������������������mscred-5.05-2018.07.09/src/t_mscwcs.x���������������������������������������������������������������0000664�0000000�0000000�00000016371�13321663143�0016600�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include	
include	
include	
include	
include	

# T_MSCWCS -- Adjust the WCS for shift, scale, and rotation.

procedure t_mscwcs ()

pointer	images			# List of Mosaic images
double	ra_shift		# RA shift (arc sec)
double	dec_shift		# Dec shift (arc sec)
double	ra_mag			# RA magnification
double	dec_mag			# Dec magnification
double	ra_rot			# RA rotation change
double	dec_rot			# Dec rotation change
int	fwd			# Forward transformation?
int	ngrid			# Number of grid points
int	xxo, xyo, yxo, yyo	# CCMAP orders

int	extlist
pointer	sp, image
pointer	mw

bool	clgetb()
int	clgeti(), btoi(), errcode()
double	clgetd()
int	xt_imextns(), imtgetim()
pointer	wcs_trans()
errchk	wcs_trans, wcs_adjust

begin
	call smark (sp)
	call salloc (images, SZ_LINE, TY_CHAR)
	call salloc (image, SZ_FNAME, TY_CHAR)

	call clgstr ("images", Memc[images], SZ_LINE)
	ra_shift = clgetd ("ra_shift")
	dec_shift = clgetd ("dec_shift")
	ra_mag = clgetd ("ra_mag")
	dec_mag = clgetd ("dec_mag")
	ra_rot = clgetd ("ra_rot")
	dec_rot = clgetd ("dec_rot")
	fwd = btoi (clgetb ("forward"))

	ngrid = clgeti ("ngrid")
	xxo = clgeti ("xxorder")
	xyo = clgeti ("xyorder")
	yxo = clgeti ("yxorder")
	yyo = clgeti ("yyorder")

	mw = wcs_trans (ra_shift, dec_shift, ra_mag, dec_mag, ra_rot, dec_rot)

	extlist = xt_imextns (Memc[images], "0-", "", "", YES, NO, NO, "", NO)
	while (imtgetim (extlist, Memc[image], SZ_FNAME) != EOF) {
	    iferr (call wcs_adjust (Memc[image], mw, fwd, ngrid,
		xxo, xyo, yxo, yyo)) {
		switch (errcode()) {
		case SYS_MWNDIM:
		    ;
		default:
		    call erract (EA_WARN)
		}
	    }
	}
	call imtclose (extlist)

	if (mw != NULL)
	    call mw_close (mw)

	call sfree (sp)
end


# WCS_TRANS - Compute transformation to astrometry coordinates consisting of
# a shift, magnification, and rotation.

pointer procedure wcs_trans (ra_shift, dec_shift, ra_mag, dec_mag,
	ra_rot, dec_rot)

double	ra_shift		#I RA shift (arc sec)
double	dec_shift		#I Dec shift (arc sec)
double	ra_mag			#I RA magnification
double	dec_mag			#I Dec magnification
double	ra_rot			#I RA rotation (deg)
double	dec_rot			#I Dec rotation (deg)

double	r[2], w[2], cd[2,2]
pointer	mw, mw_open()

begin
	r[1] = 0.
	r[2] = 0.
	w[1] = ra_shift
	w[2] = dec_shift
	cd[1,1] = ra_mag * cos (DEGTORAD(ra_rot))
	cd[2,1] = dec_mag * sin (DEGTORAD(dec_rot))
	cd[1,2] = -ra_mag * sin (DEGTORAD(ra_rot))
	cd[2,2] = dec_mag * cos (DEGTORAD(dec_rot))

	mw = mw_open (NULL, 2)
	call mw_newsystem (mw, "world", 2)
	call mw_swtype (mw, 1, 1, "linear", "")
	call mw_swtype (mw, 2, 1, "linear", "")
	call mw_swtermd (mw, r, w, cd, 2)

	return (mw)
end


# WCS_ADJUST - Create a database by sampling the image WCS and calling CCMAP.

procedure wcs_adjust (image, mw, fwd, ngrid, xxo, xyo, yxo, yyo)

char	image[ARB]		#I Image to adjust
pointer	mw			#I Astrometry coordinate transformation
int	fwd			#I Forward transformation?
int	ngrid			#I Number of grid points
int	xxo, xyo, yxo, yyo	#I CCMAP orders

int	i, j, nxgrid, nygrid, fd
double	r[2], w[2], cd[2,2], shift[2], a[2]
pointer	sp, fname, pname, proj, cmd
pointer	im, mw1, wcs, ct

bool	fp_equald()
int	open(), stropen()
pointer	immap(), mw_openim(), msc_openim(), msc_sctran(), mw_sctran()
errchk	immap, mw_openim, msc_openim, open

begin
	call smark (sp)
	call salloc (fname, SZ_FNAME, TY_CHAR)
	call salloc (pname, SZ_FNAME, TY_CHAR)
	call salloc (proj, SZ_FNAME, TY_CHAR)
	call salloc (cmd, 2*SZ_LINE, TY_CHAR)

	# Check for simple shift.
	call mw_gwtermd (mw, r, shift, cd, 2)
	if (fp_equald(cd[1,1],1D0) && fp_equald(cd[2,1],0D0) &&
	    fp_equald(cd[1,2],0D0) && fp_equald(cd[1,1],1D0)) {
	    im = immap (image, READ_WRITE, 0)
	    mw1 = mw_openim (im)
	    call mw_gwtermd (mw1, r, w, cd, 2)
	    if (fwd == YES) {
		w[1] = w[1] + shift[1] / 3600. / cos (DEGTORAD(w[2]))
		w[2] = w[2] + shift[2] / 3600.
	    } else {
		w[2] = w[2] - shift[2] / 3600.
		w[1] = w[1] - shift[1] / 3600. / cos (DEGTORAD(w[2]))
	    }
	    call mw_swtermd (mw1, r, w, cd, 2)
	    call mw_saveim (mw1, im)
	    call msc_close (wcs)
	    call imunmap (im)
	    call sfree (sp)
	    return
	}

	im = immap (image, READ_WRITE, 0)
	mw1 = msc_openim (im, wcs)
	ct = msc_sctran (wcs, 1, "logical", "physical", 3)
	ct = msc_sctran (wcs, 2, "physical", "astrometry", 3)
	ct = msc_sctran (wcs, 3, "astrometry", "world", 3)
	if (fwd == YES)
	    ct = mw_sctran (mw, "physical", "world", 3)
	else
	    ct = mw_sctran (mw, "world", "physical", 3)

	if (IM_LEN(im,1) < IM_LEN(im,2)) {
	    nxgrid = max(1,
		nint (sqrt(real(ngrid)*IM_LEN(im,1)/IM_LEN(im,2))+0.5))
	    nygrid = max (1, nxgrid * IM_LEN(im,2) / IM_LEN(im,1))
	} else {
	    nygrid = max(1,
		nint (sqrt(real(ngrid)*IM_LEN(im,2)/IM_LEN(im,1))+0.5))
	    nxgrid = max (1, nygrid * IM_LEN(im,1) / IM_LEN(im,2))
	}
	nxgrid = max (xxo+1, yxo+1, nxgrid)
	nygrid = max (xyo+1, yyo+1, nygrid)

	call mktemp ("tmp$iraf", Memc[fname], SZ_FNAME)
	fd = open (Memc[fname], NEW_FILE, TEXT_FILE)
	do j = 1, nygrid {
	    do i = 1, nxgrid {
		r[1] = nint (1. + (i - 1) * (IM_LEN(im,1) - 1.) / (nxgrid - 1.))
		r[2] = nint (1. + (j - 1) * (IM_LEN(im,2) - 1.) / (nygrid - 1.))
		call msc_c2trand (wcs, 1, r[1], r[2], r[1], r[2])
		call msc_c2trand (wcs, 2, r[1], r[2], a[1], a[2])
		call mw_c2trand (ct, a[1], a[2], w[1], w[2])
		call msc_c2trand (wcs, 3, w[1], w[2], w[1], w[2])
		call fprintf (fd, "%g %g %g %g\n")
		    call pargd (r[1])
		    call pargd (r[2])
		    call pargd (w[1])
		    call pargd (w[2])
	    }
	}
	call close (fd)

	call mw_gwattrs (mw1, 1, "wtype", Memc[proj], SZ_FNAME)
	if (Memc[proj] == 'z') {
	    call mktemp (Memc[proj], Memc[pname], SZ_FNAME)
	    fd = open (Memc[pname], NEW_FILE, TEXT_FILE)
	    call fprintf (fd, "%s\n")
	        call pargstr (Memc[proj])
	    do i = 0, 9 {
		call sprintf (Memc[cmd], SZ_LINE, "projp%d")
		    call pargi (i)
		ifnoerr (call mw_gwattrs (mw1, 1, Memc[cmd],
		    Memc[proj], SZ_FNAME)) {
		    call fprintf (fd, "%s %s\n")
			call pargstr (Memc[cmd])
			call pargstr (Memc[proj])
		}
	    }
	    call close (fd)
	    call strcpy (Memc[pname], Memc[proj], SZ_FNAME)
	} else
	    Memc[pname] = EOS

	call mw_gwtermd (mw1, r, w, cd, 2)
	call mw_c2trand (ct, 0D0, 0D0, w[1], w[2])
	call mw_ctfree (ct)
	call msc_c2trand (wcs, 3, w[1], w[2], w[1], w[2])
	call msc_close (wcs)
	iferr (call imdelf (im, "wcssol"))
	    ;
	call imunmap (im)

	fd = stropen (Memc[cmd], 2*SZ_LINE, NEW_FILE)
	call fprintf (fd,
	    "ccmap input=%s database='dev$null' sol='' im=%s results=''")
	    call pargstr (Memc[fname])
	    call pargstr (image)
	call fprintf (fd, " xc=1 yc=2 lngc=3 latc=4")
	call fprintf (fd, " xmin=INDEF xmax=INDEF ymin=INDEF ymax=INDEF")
	call fprintf (fd, " lngu=degrees latu=degrees insys=j2000")
	call fprintf (fd,
	    " refp=user lngref=%g latref=%g refsys=INDEF lngrefu='' latrefu=''")
	    call pargd (w[1])
	    call pargd (w[2])
	call fprintf (fd, " proj=%s fitg=general func=polynomial")
	    call pargstr (Memc[proj])
	call fprintf (fd,
	    " xxorder=%d xyorder=%d yxorder=%d yyorder=%d xxt=%s yxt=%s")
	    call pargi (xxo)
	    call pargi (xyo)
	    call pargi (yxo)
	    call pargi (yyo)
	    call pargstr ("half")
	    call pargstr ("half")
	call fprintf (fd,
	    " rej=INDEF upd=yes pixsys=physical verb=no inter=no")
	call close (fd)

	call clcmdw (Memc[cmd])

	call delete (Memc[fname])
	if (Memc[pname] != EOS)
	    call delete (Memc[pname])

	call sfree (sp)
end
�����������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������mscred-5.05-2018.07.09/src/t_patfit.x���������������������������������������������������������������0000664�0000000�0000000�00000122770�13321663143�0016571�0����������������������������������������������������������������������������������������������������ustar�00root����������������������������root����������������������������0000000�0000000������������������������������������������������������������������������������������������������������������������������������������������������������������������������include	
include	

define	OUTTYPES	"|none|fit|diff|ratio|flat|pfit|pdiff|pratio|pflat|\
			 |sfit|sdiff|sratio|sflat|"
define	NONE	1
define	FIT	2
define	DIFF	3
define	RATIO	4
define	FLAT	5
define	PFIT	6
define	PDIFF	7
define	PRATIO	8
define	PFLAT	9
define	SFIT	11
define	SDIFF	12
define	SRATIO	13
define	SFLAT	14

define	INIT	1		# Initialize accumulations
define	ACCUM	2		# Accumulate statistics
define	RESULT	3		# Compute result

# Accumulation elements
define	A	1
define	B	2
define	P	3
define	Q	4
define	W	5
define	V	6
define	AW	7
define	BW	8
define	PW	9
define	QW	10
define	AV	11
define	BV	12
define	PV	13
define	QV	14
define	N	15
define	NMEAN	14
define	SZ_SUM	15


# T_PATFIT -- Fit a pattern image to a data image.
# The input and output may be MEF files in which case the fit is done over
# all the extensions.

procedure t_patfit ()

pointer	inlist			# List of input files
pointer	outlist			# List of output files
pointer	patlist			# List of pattern files
pointer	wtlist			# List of weight files
int	ncblk, nlblk		# Weight blocking factors
pointer	bkglist			# List of background files
pointer	bkgplist		# List of pattern  background files
pointer	bkgwlist		# List of weight  background files
pointer	inmlist			# List of mask files for input
pointer	patmlist		# List of mask files for pattern
pointer	extfit			# Extension names to fit
pointer	extout			# Extension names to output
pointer	outtype			# Type of output
pointer	logname			# Name for log output
pointer	logfile			# Logfile
bool	verbose			# Verbose?

int	i, j, type, logfd[2]
pointer	sp, input, output, pattern, weight, bkg, bkgpat, bkgwt, mask, patmask, temp

bool	clgetb(), streq()
int	clgeti(), clgwrd(), imtlen(), imtgetim(), nowhite(), open()
pointer	imtopenp()
errchk	patfit1, imdelete, imrename, open

begin
	call smark (sp)
	call salloc (input, SZ_FNAME, TY_CHAR)
	call salloc (output, SZ_FNAME, TY_CHAR)
	call salloc (pattern, SZ_FNAME, TY_CHAR)
	call salloc (weight, SZ_FNAME, TY_CHAR)
	call salloc (bkg, SZ_FNAME, TY_CHAR)
	call salloc (bkgpat, SZ_FNAME, TY_CHAR)
	call salloc (bkgwt, SZ_FNAME, TY_CHAR)
	call salloc (mask, SZ_FNAME, TY_CHAR)
	call salloc (patmask, SZ_FNAME, TY_CHAR)
	call salloc (extfit, SZ_LINE, TY_CHAR)
	call salloc (extout, SZ_LINE, TY_CHAR)
	call salloc (outtype, SZ_FNAME, TY_CHAR)
	call salloc (logname, SZ_FNAME, TY_CHAR)
	call salloc (logfile, SZ_FNAME, TY_CHAR)
	call salloc (temp, SZ_LINE, TY_CHAR)

	# Get parameters.
	inlist = imtopenp ("input")
	outlist = imtopenp ("output")
	patlist = imtopenp ("pattern")
	wtlist = imtopenp ("weight")
	ncblk = clgeti ("ncblk")
	nlblk = clgeti ("nlblk")
	bkglist = imtopenp ("background")
	bkgplist = imtopenp ("bkgpattern")
	bkgwlist = imtopenp ("bkgweight")
	inmlist = imtopenp ("masks")
	patmlist = imtopenp ("patmasks")
	call clgstr ("extfit", Memc[extfit], SZ_FNAME)
	call clgstr ("extout", Memc[extout], SZ_FNAME)
	type = clgwrd ("outtype", Memc[outtype], SZ_FNAME, OUTTYPES)
	call clgstr ("logname", Memc[logname], SZ_FNAME)
	call clgstr ("logfile", Memc[logfile], SZ_FNAME)
	verbose = clgetb ("verbose")

	if (type == 0)
	    call error (1, "Unknown output type")

	# Check lists.
	j = imtlen (inlist)
	if (j > 0) {
	    if (type != NONE) {
		i = imtlen (outlist)
		if (i > 0 && i != j)
		    call error (1, "Output list doesn't match input list")
	    }
	    i = imtlen (patlist)
	    if (i == 0)
		call error (2, "No pattern specified")
	    else if (i > 1 && i != j)
		call error (3, "Pattern list doesn't match input list")
	    i = imtlen (wtlist)
	    if (i > 1 && i != j)
		call error (4, "Weight list doesn't match input list")
	    i = imtlen (bkglist)
	    if (i > 1 && i != j)
		call error (5, "Input background list doesn't match input list")
	    i = imtlen (bkgplist)
	    if (i > 1 && i != j)
		call error (6,
		    "Pattern background list doesn't match input list")
	    i = imtlen (bkgwlist)
	    if (i > 1 && i != j)
		call error (7,
		    "Weight background list doesn't match input list")
	    i = imtlen (inmlist)
	    if (i > 1 && i != j)
		call error (8, "Input mask list doesn't match input list")
	    i = imtlen (patmlist)
	    if (i > 1 && i != j)
		call error (9, "Pattern mask list doesn't match input list")
	}

	# Setup log output.
	if (nowhite (Memc[logfile], Memc[logfile], SZ_LINE) != 0)
	    logfd[1] = open (Memc[logfile], APPEND, TEXT_FILE)
	else
	    logfd[1] = NULL
	if (verbose)
	    logfd[2] = STDOUT
	else
	    logfd[2] = NULL

	# Initialize file names.
	Memc[input] = EOS;  Memc[output] = EOS; Memc[pattern] = EOS
	Memc[weight] = EOS; Memc[bkg] = EOS;    Memc[bkgpat] = EOS
	Memc[bkgwt] = EOS;  Memc[mask] = EOS;   Memc[patmask] = EOS

	# Process input to output.
	while (imtgetim (inlist, Memc[input], SZ_FNAME) != EOF) {
	    if (type != NONE) {
		if (imtgetim (outlist, Memc[output], SZ_FNAME) == EOF)
		    call strcpy (Memc[input], Memc[output], SZ_FNAME)
	    } else
		Memc[output] = EOS
	    if (imtgetim (patlist, Memc[temp], SZ_LINE) != EOF)
	        call strcpy (Memc[temp], Memc[pattern], SZ_LINE)
	    if (imtgetim (wtlist, Memc[weight], SZ_LINE) == EOF)
	        call strcpy (Memc[pattern], Memc[weight], SZ_LINE)
	    if (imtgetim (bkglist, Memc[temp], SZ_FNAME) != EOF)
	        call strcpy (Memc[temp], Memc[bkg], SZ_LINE)
	    if (imtgetim (bkgplist, Memc[temp], SZ_FNAME) != EOF)
	        call strcpy (Memc[temp], Memc[bkgpat], SZ_LINE)
	    if (imtgetim (bkgwlist, Memc[temp], SZ_FNAME) != EOF)
	        call strcpy (Memc[temp], Memc[bkgwt], SZ_LINE)
	    if (imtgetim (inmlist, Memc[temp], SZ_FNAME) != EOF)
	        call strcpy (Memc[temp], Memc[mask], SZ_LINE)
	    if (imtgetim (patmlist, Memc[temp], SZ_FNAME) != EOF)
	        call strcpy (Memc[temp], Memc[patmask], SZ_LINE)

	    call strcpy (Memc[output], Memc[temp], SZ_LINE)
	    if (streq (Memc[input], Memc[output]))
		call mktemp ("tmp", Memc[temp], SZ_FNAME)

	    iferr {
		call patfit1 (Memc[input], Memc[output], Memc[temp],
		    Memc[pattern], Memc[weight], ncblk, nlblk, Memc[bkg],
		    Memc[bkgpat], Memc[bkgwt], Memc[mask], Memc[patmask],
		    Memc[extfit], Memc[extout], Memc[outtype],
		    Memc[logname], logfd)
		if (!streq (Memc[output], Memc[temp])) {
		    call imdelete (Memc[output])
		    call imrename (Memc[temp], Memc[output])
		}
	    } then {
		call erract (EA_WARN)
		iferr (call imdelete (Memc[temp]))
		    ;
	    }
	}

	# Finish up.
	do i = 1, 2 {
	    if (logfd[i] != NULL || logfd[i] == STDERR)
		call close (logfd[i])
	}
	call imtclose (patmlist)
	call imtclose (inmlist)
	call imtclose (bkgwlist)
	call imtclose (bkgplist)
	call imtclose (bkglist)
	call imtclose (wtlist)
	call imtclose (patlist)
	call imtclose (outlist)
	call imtclose (inlist)
	call sfree (sp)
end


# PATFIT1 -- Fit a pattern image to a data image.
# The input and output may be MEF files in which case the fit is done over
# all the extensions.

procedure patfit1 (input, output, temp, pattern, weight, ncblk, nlblk,
	bkg, bkgpat, bkgwt, mask, patmask, extfit, extout, outtype,
	logname, logfd)

char	input[ARB]		#I Input filename
char	output[ARB]		#I Output filename
char	temp[ARB]		#I Temporary output filename
char	pattern[ARB]		#I Pattern filename
char	weight[ARB]		#I Weight filename
int	ncblk, nlblk		#I Weight blocking factors
char	bkg[ARB]		#I Input background filename
char	bkgpat[ARB]		#I Pattern background filename
char	bkgwt[ARB]		#I Weight background filename
char	mask[ARB]		#I Mask filename
char	patmask[ARB]		#I Pattern mask filename
char	extfit[ARB]		#I Extensions names to fit
char	extout[ARB]		#I Extensions names to output
char	outtype[ARB]		#I Output type
char	logname[ARB]		#I Log name for keyword
int	logfd[ARB]		#I Log file descriptors

int	i, j, nc, nl, meflist1, meflist2, imext, type
real	s, f
double	scale, flatscale, flatbkg, stat[SZ_SUM]
pointer	sp, inext, outext, tempext, patext, wtext, ghdr
pointer	bkgext, bkgpext, bkgwext, mext, patmext, str
pointer	in, out, pat, wt, bkin, bkpat, bkwt, pm, pmpat, tmp
pointer	inbuf, outbuf, patbuf, bkinbuf, bkpatbuf

bool	streq()
int	xt_extns(), imtgetim(), strldxs(), strdic(), imaccess()
pointer	immap(), yt_pmmap(), map_open()
pointer	imgl2r(), impl2r(), map_glr()
errchk	immap, yt_pmmap, map_open, patfit2

begin
	call smark (sp)
	call salloc (inext, SZ_FNAME, TY_CHAR)
	call salloc (outext, SZ_FNAME, TY_CHAR)
	call salloc (tempext, SZ_FNAME, TY_CHAR)
	call salloc (patext, SZ_FNAME, TY_CHAR)
	call salloc (wtext, SZ_FNAME, TY_CHAR)
	call salloc (ghdr, SZ_FNAME, TY_CHAR)
	call salloc (bkgext, SZ_FNAME, TY_CHAR)
	call salloc (bkgpext, SZ_FNAME, TY_CHAR)
	call salloc (bkgwext, SZ_FNAME, TY_CHAR)
	call salloc (mext, SZ_FNAME, TY_CHAR)
	call salloc (patmext, SZ_FNAME, TY_CHAR)
	call salloc (str, SZ_FNAME, TY_CHAR)

	# Set output type.
	type = strdic (outtype, Memc[str], SZ_FNAME, OUTTYPES)
	if (type == 0)
	    call error (10, "Unknown output type")

	# Write log output.
	do i = 1, 2 {
	    if (logfd[i] == NULL || logfd[i] == STDERR)
		next
	    call sysid (Memc[str], SZ_LINE)
	    call fprintf (logfd[i], "%s: %s\n")
		call pargstr (logname)
		call pargstr (Memc[str])
	    call fprintf (logfd[i], "  input = %s\n")
		call pargstr (input)
	    call fprintf (logfd[i], "  pattern = %s\n")
		call pargstr (pattern)
	    call fprintf (logfd[i], "  weight = %s\n")
		call pargstr (weight)
	    if (ncblk > 1) {
		call fprintf (logfd[i], "  ncblk = %d\n")
		    call pargi (ncblk)
	    }
	    if (nlblk > 1) {
		call fprintf (logfd[i], "  nlblk = %d\n")
		    call pargi (nlblk)
	    }
	    if (bkg[1] != EOS) {
		call fprintf (logfd[i], "  input background = %s\n")
		    call pargstr (bkg)
	    } else
		call fprintf (logfd[i], "  input background =