diff options
Diffstat (limited to 'noao/rv')
122 files changed, 32599 insertions, 0 deletions
diff --git a/noao/rv/README b/noao/rv/README new file mode 100644 index 00000000..e03fa15b --- /dev/null +++ b/noao/rv/README @@ -0,0 +1,5 @@ + 9/30/91 + + This directory contains the source for the Radial Velocity +analysis package. Package PSET support code as well as the source +for the cross-correlation task, FXCOR, are included. diff --git a/noao/rv/Revisions b/noao/rv/Revisions new file mode 100644 index 00000000..b1a59deb --- /dev/null +++ b/noao/rv/Revisions @@ -0,0 +1,1628 @@ +.help revisions May92 noao.rv +.nf + +rvrvcor.x + Modified so UTMIDDLE now properly accepts a DATE-OBS-like + timestamp. Also modified so the date is properly incremented + in the case the midpoint observation crosses midnight (7/20/10) + +rvrvcor.x + An earlier change used stridx() but was passing in a singly-quoted + character, this caused a runtime error when checking string values + on Sun systems. (9/26/08) + +======== +V2.14.1 +======== + +rvrvcor.x + Changed the rv_parse_timed() procedure to permit DATE-OBS strings. + This is used to parse the time from UT/UTMIDDLE keywords, the change + allows these to be in DATE-OBS format rather than restrict them + to being sexigesimal strings. (7/25/08) + +======== +V2.14 +======== + +filtpars.x + Fixed an error in the filtpars code where missing braces meant + that a command such as ":cutoff" would not work when filtering + is enabled (4/6/07) + +rvfgauss.x +rvfuncs.x + Merged in old changes to include an update to do the Gaussian + fitting using double precision. (3/15/07) + +rvwrite.x + Increased the HJD output to 5 decimals (8/15/06) + +======== +V2.12.2a +======== + +doc/fxcor.hlp + Added an example for setting a zero heliocentric correction for + the template image. (7/1/04) + +======= +V2.12.2 +======= + +doc/fxcor.hlp + Added an example about saving the CCF which explains how to + save a linearized CCF for large spectra. Also removed the + obsolete 'time requirements' section. (9/15/03) + +wrtccf.x + Fixed a bug in the text CCF output so it writes the velocity + computed specifically for each point rather than the approximation + as done before. (9/15/03) + +wrtccf.x + Added CTYPE1='velocity' and CUNIT1='km/s' keywords to the CCF + output image so it will display in velocity units (8/19/03) + +rvrebin.x + In very rare cases the code could overrun a stack array and + cause a segvio. This array wasn't actually being used in the + routine and so the code was removed (8/15/03) + +rvidlines/idvhelio.x + The previous change would trash the year, month, and day when + parsing the UT. This is fixed. (2/6/03, Valdes) + +======= +V2.12.1 +======= +===== +V2.12 +===== + +doc/rvidlines.hlp + Expanded on what keywords from KEYWPARS are used and how. + (2/12/02, Valdes) + +rvidlines/idvhelio.x + The specified UT keyword is now used rather than the time given in + the date keyword. To use the time in the date keyword, the UT + keyword can be set to be the same as the date keyword and the + UT will be parsed out of the string. So the UT keyword can be + either a time value or a date/time string value. This is consistent + with changes in ASTUTIL. + (2/12/02, Valdes) + +splitplot.x + Fixed a bug in moving the correlation X data to the plotting array + which would sometimes cause the ccf plot to not be drawn correctly. + (10/18/00) + +rvsumplot.x + Move the 'fit did not converge' message to a more readable location + on the plot. (10/18/00) + +fftutil.x + Fixed a typo that was causing the fftmode plots to be computed + using the entire spectrum instead of taking into account the + sample regions specified. (08/22/00) + +fftmode.x +prepspec.x +splitplot.x +rvfftcorr.x + Additional fixes to the filter overlay plotting code. Also revealed + a problem in the display of the FFT plots. (08/22/00) + +fftmode.x + Fixed a bug in the filter overlay plotting (8/17/00) + +rvwrite.x + Changed the output of the HJD to use modulo 10000 rather than + constants such as 2450000. (3/30/00) + +coloncmds.x +doc/fxcor.hlp + Changed the behavior of the :apnum command so that it won't reset + the sample regions. This was originally done to protect against + bogus sample regions in echelle data where moving through orders + would invalidate the regions, but harms multispec users who must + reset the regions manually. Updated help page (3/23/00) + +======= +V2.11.3 +======= + +rvrvcor.x + Fixed a bug where the DATE-OBS in the for CCYY-MM-DD wasn't checking + for an INDEFD UT causing an overflow (12/23/99) + +rvidlines/idmap.x + The SFREE added earlier was in the wrong place causing 1D images + to abort with a salloc underflow. (10/12/99, Valdes) + +======= +V2.11.2 +======= + +mkpkg +rvidlines/mkpkg + Fixed missing/extra file dependencies (9/20/99) + +aplist.x +rvidlines/idmap.x + Fixed some problems picked up with SPPLINT. (7/28/99) + +rv.cl +rv.hd +x_rv.x +rvcorrect.par - +t_rvcorrect.x - +doc/rvcorrect.x - + The RVCORRECT task was a duplicate of the ASTUTIL package. To + avoid code confusion sources were removed from the RV package and + the task is now defined to be the ASTUTIL version. + (5/27/99) + +Revisions +rvpackage.spc +keywpars.par +rvflags.h +keywpars.x + Files were reviewed for Y2K compliance, no changes necessary. + (5/27/99) + +keywpars.hlp + Documentation updated about use of dtm_decode. + (5/27/99) + +rvwparam.x + The timestamp string written for the output log header was changed + to use a 4-digit year. Does not affect formatting of output tables. + (5/27/99) + +rvrvcor.x +doc/fxcor.hlp + Changed to use dtm_decode to parse date-obs field. If a time is + included in the date string it has precedence over UT when computing + observation midpoint and not using UTMIDDLE keyword. (5/27/99) + +Time from + date-obs is used (if available) as the beginning time of the obs- + ervation if there is no UT keyword present and we're not using the + UTMIDDLE keyword to get the midpoint time. Documentation updated. + (5/27/99) + +rvidlines/idvhelio.x +rvidlines/rvidlines.hlp + Modified to use dtm_decode to decode both the old and new + FITS date string. If a time is included in the date string + it has precedence over UT. (5/19/99, Valdes) + +rvwrite.x + Fixed a bug in the output of the HJD to screen and txt (5/4/99) + +fftutil.x + Increased max allowable exponent from 15 to 31 (5/3/99) + +rvvfit.x + Fixed a bug in the output of deblended velocities (4/22/99) + +deblend.x + Fixed a prompt error for the 't' keystroke. (4/8/99) + +t_rvcorrect.x + Added code the catch a bad DATE-OBS keyword and print an informative + error (2/21/99) + +fftmode.x + Fixed a bug in the one-plot options. (2/21/99) + +rv.hd + Modified to remove the 'rv' definition which was interfering + with selecting the package help (1/27/99) + +rvcorrect.par + Removed the KEYPARS pset from the parameter file. The pset is + still available to the task, but it's presence interferes with + the task when used in CL mode since the 'ut' parameter is no + longer queried and the pset value is used, resulting in an + illegal number error when getting the value (4/22/98) + +rvgetim.x + When pixcorr was set the data were still being rebinned in the + SMW code, fixed this. (4/2/98) + +splitplot.x + Fixed a bug in the plotting of object spectrum in the summary + plot (4/2/98) + +rvcursor.x + calls to rv_do_save() had an unused 'type' arg which conflicted + with usage in coloncmds.x. Since this was unused it was removed + (3/27/98) + +rvrebin.x + rv_getim() was being used as a subroutine, should be an int + function. (3/27/98) + +deblend.x + Fixed a type conversion problems causing an overflow when the + computed velocities are INDEF (2/17/98) + +rvidlines/ididentify.x + There was a parenthesis placement error in an id_zshift call. + (2/5/98, Valdes) + +rvwrite.x + Fixed HJD output as an offset from 2450000 for more recent dates. + (1/5/98) + ++====== +V2.11.1 ++====== + +rvdrawfit.x + Fixed a typo causing an incorrect array allocation (8/25/97) + +rvplot.x +fftmode.x +rvsample.x + Removed the checks to see if the obj/temp image names are the + same to decide if we're making a single or split plot. With only + a single plot it's not possible to set different sample regions + when autocorrelating. (7/24/97) + +fftmode.x + Deleted unused pointers from fft_plot() routine (7/24/97) + +splitplot.x +rvplot.x +rvsample.x +specmode.x + Minor fix to plotting of sample regions (7/24/97) + +fftmode.x +splitplot.x + Fixed a fwe minor plotting bugs for power spectra (7/7/97) + +rvfgauss.x + Changed check_converge() to rv_check_converge() to avoid name + conflict with FITS kernel. (5/20/97) + +rvidlines/mkpkg +rvidlines/idlinelist.x +rvidlines/idlog.x +rvidlines/t_reidentify.x +rvidlines/idvelocity.x +rvidlines/idgraph.x +rvidlines/ididentify.x +rvidlines/reidentify.x +rvidlines/idrms.x + Modified to work in input spectrum units. (3/13/97, Valdes) + +rvgetim.x + Input spectra which are dispersion corrected are converted to + Angstrom units on input. Thus the spectra can be in other + recognized units. (3/13/97, Valdes) + +rvstrings.x +rvwrite.x + The nam_tempcode procedure had an unnecessary pointer arg. (3/6/97) + +rvwrite.x + Added an extra space for the HJD output. Since the JD rolled over + 245000 the number of decimal places decreased by 1, this is now + restored (10/21/96) + +contin.x + The normalized reference spectrum was being copied from the object + spectrum when the image names were the same as a form of optimization. + This could fail in cases where the 'n' key was used to move through + a list to get the next object an the object spectrum was previously + rebinned at a different dispersion causing artificial shifts in + the data. The code was modified to always compute a normalization + to avoid this (9/12/96) + +rvcorrect.par +doc/rvcorrect.hlp + Forgot to add the keypars pset for this task (8/26/96) + +rvlinefit.x + Removed an extraneous sfree call causing a salloc underflow if + a certain error condition happens. (8/13/96) + +specmode.x + Fixed a bug where the spectrum mode could get confused on future + plots on specmode. (8/8/96) + +rvfgauss.x + A couple of *_old varables were declared but never used. (7/17/96) + +rvrvcor.x + Fixed a bug in the rv correction code where the default kpno + observatory was always being used in cases where the image + did not have an OBSERVAT keyword, instead of using the obs + supplied by the task parameter (6/26/96) + +rvgetim.x + Commented out the check for a max number of points since this + no longer appears to be needed. (5/14/96) + +rvfgauss.x + Fixed a rare bug that can cause a floating overflow when a fit + converges to a nonsensical large gaussian. Added a trap for + a very large sigma in a computed fit. (7/26/95) + +rvplot.x + Fixed an old bug in which the code to draw a single plot in + spectrum mode was actually recursive. This would result in an + infinite loop if the obj/temp were the same image and the 'i' + key was used. Wrote code for a single plot for both the input + and normalized single plots (3/10/95) + +======= +V2.10.4 +======= + +rvidlines/idvhelio.x + Changed error action to a single warning to allow for the case + of missing header keywords. (10/20/94, Valdes) + +rvbatch.x + Fixed a bug where the RV_TEMPNUM wasn't being set before the + rv_data_check() procedure was called. If the data were rebinned + this corrupted the RV_TEMPVEL() pointer. (10/13/94) + +======= +V2.10.3 +======= + +rvbatch.x + Fixed a bug where the image wasn't being update in batch mode (7/18/94) + +rvsample.x + Fixed a bug erasing the sample regions with 'u' (5/19/94) + +splitplot.x + Fixed a bug affecting filter overlay of FFT plots. (4/24/94) + +rvidlines/mkpkg + The mkpkg was not complete in it's dependencies. Did a mkmlist + to insure all dependencies are checked. (4/23/94, Valdes) + +t_fxcor.x + The imtclose() calls when shutting down would fail if the file + lists had changed during the task. Changed this to close the + structure pointers instead. (2/22/94) + +rvgetim.x + Added a check on the dispersion units. + (2/18/94, Valdes) + +rvfftcorr.x + The "prepared spectrum" plot wasn't showing the spectrum with the + effects of the filtering. Filtering is normally done after the + FFT but it made sense that the user should see the centered, apodized + and filtered spectrum being correlated. (2/15/94) + +mkpkg +asttools/ - + Deleted the duplicate asttools source and made use of the noao package + library. (8/25/93) + +mkpkg +rv.cl +rv.hd +x_rv.x +rv.men +rvidlines/* + +rvidlines.par + +rvreidlines.par + +doc/rvidlines.hlp + +doc/rvreidlines.hlp + + Added the new tasks RVIDLINES and RVREIDLINES for determining + velocities from spectral lines. This task is similar to the + IDENTIFY task for determining dispersion solutions. + (8/24/93, Valdes) + +rvinit.x +zzdebug.x +rvfgauss.x +rvdebug.par + The type of the rvdebug.other parameter was changed but I forgot to + update the files that were still treating this as a boolean. Also + removed and option for using an old version of the lorentzian fitting. + (8/12/93) + +rvcorrel.x + Changed the computation of the antisymmetric noise function. The + full discussion is in the RV mail logs but basically the previous + algorithm was computing the differences incorrectly about the peak, + which is obvious for the case of a shift of zero. The new algorithm + is correct (even though the endpoints look funny). For consistancy + the old agorithm is still available by setting rvdebug.other to a + positive value. Setting rvdebug.other to -1 gets you the old alg- + orithm with a bug fix to it. (8/7/93) + +rvanplot.x + Added 'sigma' to the text output. (8/7/93) + +rvvfit.x + Fixed a typo in the definition of c[3] as the Sigma of the Gaussian + fit when it's really the Sigma^2 of the fit. It correctly used in + the computation of width elsewhere in the code (7/9/93) + +mkpkg +t_fxcor.x +rvgetim.x +rvrebin.x +rvimutil.x +coloncmds.x +dispcor.x - +dispcor.com - + Changed the way the data rebinning to get a common dispersion is + handled. Previously the V2.9 DISPCOR code was used but this ran + into problems when trying to rebin a log spectrum to a different + dispersion with many more points. What happens now is that the + original image is read but then interpolated to the requested disp- + ersion rather than the log equivalent of what's in the header. This + This has the advantage that no spectrum is interpolated more than + once prior to correlation. (6/29/93) + +rvplot.x + Fixed a typo in the specmode.'i' plot annotation (6/21/93) + +numrep.x +rvbatch.x +rvrvcor.x +rvwrite.x +rvfparab.x +rvimutil.x +rvwparam.x +rvcolon .x +rvcursor.x +coloncmds.x +readtlist.x +rvdrawfit.x +rvfitfunc.x +rvstrings.x +splitplot.x + Cleaned up "foo set but not used" messages reported by SPPLINT (5/13/93) + +mkpkg +specmode.x +rvlinefit.x + + Implemented a new specmode keystroke command, 'v', which is basically + an rip-off of the SPLOT 'k' keystroke that fits a gaussian to a + line, asks for a standard wavelength and then computes a velocity + for that single line. For the moment this will be an undocumented + command since it will be part of other enhancements to specmode + in the next release. (5/12/93) + +rvgetim.x + The X coordinate array wasn't being initialized with the proper + coords (5/11/93) + +rvrebin.x + The rebinned spectrum was being normalized using the entire spec- + trum as the sample. Any changes made interactively or samples + selected were ignored. This didn't make sense so I commented this + out so the fit is done using the same samples it would in any other + case. (5/10/93) + +rvwrite.x + Changed the FWHM output to .txt files so it prints velocity if + present, otherwise it's the pixel width. The "km/s" units label + was removed from the column heading. (5/7/93) + +rvrebin.x + Fixed a type declaration problem causing compilation errors under + AUX. (5/6/93) + +rvwrite.x + The "Rebined WPC" field was being printed as some bogus value + for pixel correlation. Changed to print INDEF. (5/5/93) + +rvcont.h +contin.x +continpars.x + Set it up so that a :markrej command stays in effect until reset + by another command. Requested by Daryl. (5/5/93) + +specmode.x +doc/fxcor.hlp +lib/scr/specmode.key + Added a new 'b' keystroke command to set the sample region for + both spectra simultaneously. (5/5/93) + +rvwrite.x + In the case where redshifts are being printed an INDEF value was + being converted to a redshift before printing. Added a bunch of + if (IS_INDEF())s so that an INDEF redshift would be printed. + (5/5/93) + +rvrvcor.x + Reset the RV_PRINTZ flag in the case where missing header info + prevented a full velocity computation. VREL was still being con- + verted but it was always printed as a velocity, never a redshift. + (5/5/93) + +rvsample.x + Fixed a small problem w/ erasing sample regions. (4/30/93) + +rvbatch.x + Fixed a bug in which the .txt file header was being written before + the final WPC was computed. This meant that the WPC and vel-per-pixel + values were wrong for batch runs if either spectrum had to be re- + binned prior to the correlation. (4/29/93) + +rvrvcor.x + The MJD was being computed incorrectly. As defined in the Astronomical + Almanac it's the JD - 240 0000.5. (4/16/93) + +rvvfit.x + Fixed a bug in the output of MJD to .log files. (4/14/93) + +rvfilter.x + Fixed a bug in the square filter code. (4/7/93) + +doc/fxcor.hlp + Added notes for the new package params. (3/31/93) + +keywpars.x +rvcomdef.h +rvkeywords.h +keywpars.par +doc/fxcor.hlp +doc/keywpars.hlp + Removed the W0 and WPC fields from KEYWPARS. Also made a note in the + help pages about how the UT of the heliocentric correction is + found. (3/29/93) + +mkpkg +x_rv.x +rvcorrect.par + +rvcorrect.com + +t_rvcorrect.x + + Made a duplicate of the RVCORRECT task for the RV package. This + task is identical to the one in ASTUTIL but it makes use of the + KEYWPARS header keyword translation pset. (3/23/93) + +wrtccf.x +rvpackage.h + Fixed a bug in writing out the correlation function to an image + or text file. Also removed an unused RV_AXIS macro (3/15/93) + +deblend.x +splitplot.x + Fixed some INDEF type conversions that were causing problems on + the A/UX port. Conversion of INDEF is illegal but has only just + now been caught because INDEFR == INDEFD on other systems (3/15/93) + +rvrebin.x +rvdatacheck.x +rvfftcorr.x + An integer zero point coordinate offset was computed and applied in + rv_fftcorr but the fractional part was ignored. This would produce + a final velocity error of up to a pixel in those cases where the + wavelength origins were not the same between the object and + template spectra. This error shows up in tests with DOPCOR which + introduces just such a zero point shift. + + o Moved the setting of w0 and npts from force_rebin to force_which. + Force_which is now the main point for checking and resetting + compatibility between the object and template spectral WCS. + The key part of the fix was to adjust w0 so that it is an + integer number of pixels shift from the w0 of the target + spectrum. The integer part of the shift is then handled by + rvfftcorr.x + + o The checking of the WCS in rv_data_check was moved to force_rebin + (which then calls force_which). Rv_data_check now simply calls + force_rebin every time. + + o Added a nint in rv_fftcorr to make sure that no funny roundoff + occurs in setting integer pixel shift zero point offset. + + ishift = nint ((RV_OW0(rv) - RV_GLOB_W1(rv)) / RV_OWPC(rv)) + (3/1/93, Valdes) + +mkpkg +rv.par +rvgetim.x +aplist.x +rvmwcs.h - +rvmwcs.x - +getdisp.x - +doc/fxcor.hlp + 1. Added dispaxis and nsum to the package parameters. These are used + with 2D and 3D spectra which are now supported. + 2. The spectrum header information and data are obtained through + the smw/shdr routines from ONEDSPEC. This supports linear, + log-linear, non-linear, equispec, multispec, 1D, 2D, and 3D + spectral formats. + (2/25/93, Valdes) + +coloncmds.x +deblend.x +fftmode.x +rv.par +rvanplot.x +rvcolon.x +rvcomdef.h +rvdrawfit.x +rvfitfunc.x +rvflags.h +rvinit.x +rvpackage.h +rvplot.x +rvsample.x +rvstrings.x +rvsumplot.x +splitplot.x + Added support for color overlay vectors and text (12/14/93) + +rvplot.x +deblend.x +rvsample.x +rvdrawfit.x +rvfitfunc.x +splitplot.x + Changed the gseti() calls to use symbolic names when changing + line and polymarker types. (12/11/92) + +rvplot.x +fftmode.x +rvanplot.x +rvsumplot.x +splitplot.x + Removed the bold font definitions from gtext() calls. (12/7/92) + +rvrvcor.x + Renamed procedure rv_correct() to rv_corr() to avoid possible name + clashes at a later date. (10/13/92) + +rv0$rv0.par + Added an "observatory" package parameter to allow the parameter + indirection used by the RVCORRECT task. Until now that task + couldn't be run. (10/13/92) + +rvrebin.x + Had to clear a stack array since grabage was being used in the + second correlation. I really need to go through all of the code + and fix this once and for all (9/1/92) + +deblend.x +rvfitfunc.x +rvrvcor.x + Cleaned up some INDEF expressions so there is no type conversion + going on. This can caused problems on the VXUX systems (9/1/92) + +rvwrite.x + Cleaned up some INDEF equality tests to us IS_INDEF() macro (9/1/92) + +rvcorrel.x + Changed the decared dimension of the data array from 'npts' to + 'ARB'. (8/26/92) + +rvfgauss.x +rvfparab.x + Added some debugging output to print weight info (8/26/92) + +aplists.x +getdisp.x +rvgetim.x +rvrebin.x +prepspec.x + Made a simpler debug test macro for readability (8/26/92) + +prepspec.x + The sample region masking could fail if one of the spectra were + smaller than the other. The masking code assumed the whole global + wavelength array was being passed in, but in fact only the data + array was being passed. Also fixed a typo when initializing the + array, too many points were being moved. (8/25/92) + +rvgetim.x + The values of RV_X1 and RV_X2 were confused w/ log and linear values + for data w/ lambda dispersion. (8/24/92) + +splitplot.x + Removed the sample regions markers from the prepared spectrum + plot (8/24/92) + +rvfilter.x + There was a small "glitch" in the computed Welch or Hanning filters + caused by an extra filter value being computed. (8/24/92) + +fftutil.x + Changed some procedure arguments named 'data' to 'v' since this causes + a compiler error on the RS/6000. Original complaint was for + fft_fixwrap() but as also present in fft_cosbell(). (8/13/92) + +rvcursor.x +rvfgauss.x + Cleaned up some missing sfree() calls before error returns. (8/9/92) + +t_fxcor.x +rvsample.x + Fixed a bug in the code that parses the sample parameters. The loop + could possibly skip past the EOS in the string, and if there is garbage + in the buffer (as could happen when the task in the process cache) it + could lead to incorrectly counting the number of ranges and cause a + memory fault. I fixed the parser bug and cleared the array before + it was filled. Reported by Oegerle. (8/7/92) + +rvsample.x + Fixed a typo in which RV_ERANGE was not being freed (typo was RV_SRANGE + in mfree). Found w/ SPPTOOLS. (8/5/92) + +rvcursor.x +coloncmds.x + The procedure cmd_write() was declared as an int procedure but not + returning anything. Caused a compiler error on DSUX Dec fortran. + Also changed rv_query_save() in rvcursor.x since it was returning + something but it's return value was never used. (8/5/92) + +rvrvcor.x +help/keywpars.hlp + Fixed a typo in the explanation of the date field for DATE-OBS and + made the error comment when it's parsed incorrectly more clear (7/31/92) + +rvmwcs.x + Updated with yet another "old-format" special case fix (7/29/92) + +rvrvcor.x + Fixed a memory leak caused by not unmapping images when there was + an error return from rv_correct(). The task would grow in memory + continuously until it finally ran out and died. (7/28/92) + +---------------- +V2.10.1 Released + +rvmwcs.x + Updated with latest changes to onedspec$smw.x. (5/29/92) + +aplists.x + Fixed a bug in the ordering of if-clauses that prevented a check + against an aperture list trying to be applied to onedspec images. + (5/29/92) + +rvinit.x +t_fxcor.x + Removed all of the stubs for reading observatory parameters from + the image header keyword OBSERVAT. The observatory database tools + now used will check the image header automatically to accomplish + the same thing. This code was also prone to bugs since it would + be possible to pass the wrong pointer the the obsopen procedure. + (5/29/92) + +rvinit.x + Fixed a segvio when the obervatory parameter set to "image" (5/26/92) + +rvmwcs.x + Fixed a bug caused by the MWCS changes in which an image with no + dispersion info a all could not be read. (5/7/92) + +aplists.x + Fixed a bug wherein the apertures would not be found since the + verify loop looked at all the rows in an image even though that + may be greater than the number of apertures requested. (5/4/92) + +------------------------------- +Package frozen for 2.10 release (5/2/92) + +rvdatacheck.x + Added a check to see if, when the dispersion for the two spectra + are the same, the difference between starting wavelengths is the + same. If not, then we must rebin so that the difference is an + integral of the WPC, otherwise we could end up with up to a +/- one + pixel error. (4/27/92) + +rvsinc.x + Fixed a bug where the sinc fit would get into an infinite loop + if the points in the fit lay above the half power point of the + peak. The fix was to return fwhm=INDEF in this case. (4/22/92) + +rvfitfunc.x + The sinc fit wasn't being redrawn if no fwhm was found. (4/22/92) + +splitplot.x + Fixed a bug with contin=none and the 't' keystroke in fft mode not + labelling the original template correctly. (4/20/92) + +fftmode.x +splitplot.x + Fixed a bug where the filter overlay wasn't being done correctly + (4/20/92) + +rvgetim.x + Fixed a bug with the template being a onedspec and having a different + aperture number than a onedspec object. The template wasn't being + rebinned. (4/16/92) + +fftmode.x + Fixed a bug with the 'i' key not working on single plots (3/24/92) + +rvmwcs.x + Made change to recognize data with APFORMAT='onedspec'. + (2/21/92, FV) + +rvrvcor.x + Modified the routine rv_correct() so it no longer uses the obsimcheck() + procedure which was removed from xtools$obsdb.x. Now uses obsimopen() + (2/8/92) + +rvbatch.x +doc/fxcor.hlp + Changed the wincenter parameter so that it takes into account a template + velocity if present so the window will be centered on the expected + velocity of the peak and not the relative velocity. If no template + vel is present, the peak is centered on the relative velocity as before. + Requested by oegerle@stsci.edu (1/16/92) + +rvwrite.x +doc/fxcor.hlp + Changed the format of the template code string since template names + greater than 40 chars would trip a bug in sprintf and cause the + write to fail with a "No write permission of file (StringFile)". + For image names greater than 30 chars only the rightmost part of + the string is printed. (1/14/92) + +rv.par +rvinit.x +rvflags.h +dispcor.x +rvrebin.x +rvpackage.h +doc/fxcor.hlp + Made the rebinning interpolator a package parameter after it was + found that the sinc interpolator had disadvantages for certain types + of data. The default is once again poly5. (1/10/92) + +rvcorrel.x + Added debug output to error calculations. (1/10/92) + +rvsinc.x + 1) The value of the background wasn't being picked up when changed + 2) MAXITER exceeded message wasn't going through error printing + code. (1/10/92) + +coloncmds.x + Redo the correlation after setting a new template velocity so we + pick it up in the results. (1/10/92) + +rvfgauss.x + 1) Silenced the convergence checking messages. + 2) Cleared arrays before input to NLFIT. Was part of tracking a bug + found in nlacpts() but should be done anyway. (1/9/92) + +rvfitfunc.x + Fixed a real/double arg type error found w/ spplint. (1/6/92) + +rvpackage.h + Removed any constraint from MAXTEMPS and set it to algorithm max of + 702. Need to change this is template caching if re-implemented. + (1/6/92) + +coloncmds.x + Fixed the :tnum command to work with the new template naming scheme. + Also fixed a small bug already there. (1/6/92) + +contin.x +getdisp.x +rvgetim.x +rvcomdef.h +continpars.x +continpars.par +doc/continpars.hlp + Implemented a new 'replace' parameter for CONTINPARS to allow the + rejected points to be replaced by the fit points. Useful for re- + moving emmission lines or cosmic ray events. Requested by Oegerle. + (1/3/92) + +rvwrite.x +rvpackage.h +rvstrings.x +readtlist.x + Increased the number of MAXTEMPS to 200. The algorithm codes the + templates as A,...Z,AA,AB... so the max can be increased to almost + 700 by changing the declaration in rvpackage.h. Requested by Oegerle + & Hill (1/2/92) + +mkpkg +rvinit.x +rvmwcs.x + +rvmwcs.h + +getdisp.x +aplists.x +rvpackage.h + Added support for new ONEDSPEC MWCS dispersion headers. Nonlinear + cannot be rebinned and an error will be returned. Other log and + linear formats can be read. This change should be backward compatible + (12/31/91) + +rvfgauss.x +rvfparab.x + Changed calling sequence to nlerrors() to agree with the math$nlfit + library calling sequence. Was causing an error on f68881 machines. + (10/11/91) + +----------------------------------------------------------------------- +Package was installed in V2.10 noao package. 093091 +----------------------------------------------------------------------- + +rvpackage.h + Updated package date. 091091 + +dispcor.x + V210: Changed default interpolant to be II_SINC. 091091 + +rvwrite.x +rvwriteln.x - + V210: Consolidated procedures into one logical file. 091091 + +rvfgauss.x +rvfparab.x + V210: Changed NLFIT calls to be library version of single precision. + 091091 + +t_fxcor.x +rv0$rv0.cl +rv0$rv0.hd +rv0$rv0.par +observatory.x - +observatory.par - + V210: Moved the obs_get_pars() procedure into inline code in + rv_clpars(). Removed Observatory pset from package and use the + NOAO observatory task instead. 091091 + +rvsinc.x +numrep.x + Moved the brent() procedure to rvsinc.x since it explicitly + calls the sinc interpolator and ther routines in numrep.x + may be provided by an xtools file in V2.10. 090491 + +deblend.x + Removed Marquardt fitting code duplicated in xtools. 090491 + +rvparam.x + Reset default maxwidth to 21 as in the par file. 090391 + +rvfitfunc.x + Fixed a bug that was not getting the correct points for a 'y' + fit. Also fixed a bug that was changing the width parameter + and so in a list of stars it was possible to change the params + being used without the user knowing it. The symptom was run- + ning a list of stars, and then randomly picking out individual + correlations without being able to reproduce the results. 090391 + +complex.x +rvfilter.x + Fixed a bug causing filter plots to be scaled incorrectly. 090291 + +rvbatch.x + Made an error message printable only from interactive mode. 082991 + +rvfgauss.x +rvfitfunc.x + Added some checks for a proper convergence to avoid a FOE if + the fit ended because of max iterations or with bogus answers. + Fixes a bug reported by DSprayberry at UA. 082991 + +rvfgauss.x + Fixed a type mismatch with the width of the fit region causing + a FDZ in the weight fitting calc. Only part of another problem. + 082991 + +coloncmds.x + Fixed a typo in the output of dispersion info. 082091 + +fftutil.c + Power spectra were computed with log(), not log10() as is used + throughout the rest of the package. Fixed. 082091 + +fftmode.x + - Fixed another segvio as below, but for the 'g' key. + - Fixed a bug in fft_inverse which was reporting the wrong + frequency with the 'i' keystroke. 071291 + +rvsinc.x + Fixed a bug causing the ccf height to be computed wrongly. 071291 + +fftmode.x + Fixed a segvio caused when pixcorr+ and continuum="none". 071091 + +coloncmds.x + Fixed a bug caused by pixcorr+ trying to convert INDEF to an + int when doing a ":wincenter" or ":window" call. 071091 + +rvwriteln.x + Fixed a bug causing the fwhm to be output in pixels for a short + .txt file. 070291 + +doc/fxcor.hlp + Added a note that the "original" spectra are splotted on a linear + wavelength scale and a slope may be noticed because of rebinning + effects. 070291 + +rvcomdef.h +rvcolon.x +coloncmds.x +doc/fxcor.hlp +../lib/scr/fxcor.key + Implemented a ":comment" command to add a comment to the output + logs. Requested by Daryl. 070191 + +rvfuncs.x +rvfgauss.x +rvfitfunc.x + Changed the functional form of the Lorentzian to make it a bit + more stable. Previously it was the form of the normalized function + but that didn't apply. 062891 + +prepspec.x + Fixed bug with specifying decimal samples on a pixel corr. 063091 + +asttools/asthjd.x +asttools/asttimes.x + Changed a constant in the JD calculation that fixes a 0.5 day + bug on AOS systems. Also fixed some confused parameters to the + procedure ast_hjd(). 062591 + +rvrvcor.x + Added a check for the pixcorr parameter to abort a Vh calculation + if it's not needed. 062591 + +fftutil.x + Changed explicit argument dimensions to ARB. This was causing + a "variable dimension error" on VMS systems. 061991 + +rvsample.x +rvutil.x + Fixed a problem with sample region for pixel-only correlations. + 061891 + +coloncmds.x + Fixed some confusion with the ":filter" commands. 061791 + +rvfitfunc.x + Changed height calculation so it's the estimate of the correlation + value and not the height of the function. 061791 + +rvdrawfit.x + Made the function erasing a bit smarter so that the FWHM indicator + is erased the same way it was drawn. On xterms, a line was being + drawn across the whole screen because it didn't support graphics + erase. 061491 + +fftmode.x + Fixed two typos: One causing the 'f' keystroke to act like the + 'p' keystroke, and another causing the fft plots to be incorrectly + calculated. 061491 + +rvsample.x +specmode.x + Added some more functionality to the sample regions code, including + a new 'u' keystroke that will automatically de-select a sample + region. Also, sample may now be merged or expanded by using the + 's' keystroke. 061491 + +prepspec.x + Fixed a bug causing the sample regions to accidently be apodized + for the filter plots. 061391 + +t_fxcor.x +rvcursor.x +coloncmds.x + Added some checks so that the filter parameter cannot be changed + (specifically, turned on) before filter values have been set. + Previously the task would get in a confused state because the + data check prior to the correlation would fail and there was no + recovery. 061191 + +t_fxcor.x +splitplot.x +rvsample.[xh] + Added code so that samples specified as pixels will still be plotted + if dispersion info is present and the user hasn't requested a + pixel-only correlation. 061191 + +splitplot.x + Fixed a samples ranges plotting bug on summary plots. 061191 + +------------------------------ +Package updated on local systems for testing. 060591 + +wxcor.h +rvwriteln.x + Added the rebin parameter to the output codes. 060591 + +readtlist.x +rvimutil..x + Optimized a bit to remove extra rv_getim() calls that were only + used to get template velocities. 060491 + +rvfitfunc.x +rvfftcorr.x + Fixed a memory bug being tripped up when images with differing + sizes are passed in the list. Also made sure correlation array + is big enough after the rebinning, previously is could have been + off by a few elements. 060491 + +rvflags.h +fxcor.par +t_fxcor.x +rvcolon.x +rvparam.x +rvcomdef.h +rvpackage.h +rvstrings.x +coloncmds.x +doc/fxcor.hlp +rv0$lib/scr/fxcor.key + Implemented a new "rebin" parameter to give user control over + which spectrum is rebinned. 060391 + +rvwriteln.x +doc/fxcor.hlp + Added output of rebinned dispersion to logs when it differs from + previous so user can be aware of rebinning changes. Since data + are always rebinned to the lowest dispersion, log entries should + be minimized although interpolation errors may increase. The help + page was also modified to alert useras to this fact. 060291 + +contin.x +rvplot.x +fftmode.x +rvrebin.x +specmode.x +readtlist.x + Fixed usages of RV_(R)NPTS macros so the are consistent with the + spectra used. Since relaxing the constraint that the rebinned npts + match we need to make sure both object and templates are allowed to + be arbitrary lengths, and that code know what the lengths should + be. 060291 + +rvsinc.x +numrep.x +rvflags.h +rvfgauss.x +rvfparab.x +rv0$rv0.par +rvpackage.h + Made fitting tolerances and max iterations a package param. 053091 + +rv0$rv0.par +rvpackage.h +rvrvcor.x + Made the z_threshold a package parameter so that users have control + over the threshold at which output is printed as redshift z values + rather than velocities. 052391 + +rvinit.x +rvplot.x +rvutil.x +fftutil.x +fxcor.par +rvcolon.x +rvflags.h +rvparam.x +rvrvcor.x +rvwrite.x +t_fxcor.x +prepspec.x +rvcomdef.h +rvfilter.x +rvfparab.x +rvsample.h + +rvsample.x + +specmode.x +rvpackage.h +coloncmds.x +rvfftcorr.x +rvsumplot.x +splitplot.x +rvdatacheck.x + Implemented multiple and independent sample regions. This involved + the addition of a new structure containing the ranges information. + This structure can be accessed directly by referencing the struct + pointer, or the structure for either object or template can be + accessed with the main rv struct pointer by using macros. Work + routines are passed only the sample struct pointer and calling + routines figure out which spectra the sample applies to and pass in + the appropriate pointer. 052191-052391 + +rvutil.x +rvcursor.x +specmode.x + Fixed a GIO wcs bug causing endpoint marking keystrokes to get + confused. 052091 + +fxcor.par +doc/fxcor.hlp + Changed default maxwidth to 21. 051891 + +rvsinc.x + +rvvfit.x +rvplot.x +rvflags.h +fxcor.par +rvdrawfit.x +rvstrings.x +rvfitfunc.x +doc/fxcor.hlp + Began implementation of a sinc interpolator and Brent peak finding + algorithm. 051791 + +rvbatch.x + Fixed bug that was turning off object continuum subtraction. 051791 + +rvutil.x + Fixed a small bug with using the 's' to specify a sample. Range + was being checked against the log of the wavelength causing the + range to be e.g. 3.09-5400. 051691 + +rvgetim.x +rvrebin.x +splitplot.x + Fixed rebinning bug causing spectra to somtimes be truncated if + the difference in dispersion was great enough. That is, the + number of data points was being fixed rather than being allowed + to vary so that the same wavelength region was covered. In the + process I also fixed a small plotting bug for spectrum plots. 051691 + +rvsumplot.x +rvfitfunc.x + Fixed drawing of FWHM indicator for parabolic fits. This was + reported as a bug but in fact the indicator was never drawn. + Since we want the FWHM to be computed from the coefficients and + not an empirical calculation, this is the way it is drawn although + it looks like it is underestimated. 051491 + +rvcolon.x +specmode.x +rvcomdef.h +coloncmds.x +rv0$lib/scr/fxcor.key +rv0$src/doc/fxcor.hlp + Changed the ":wpc" command to be ":disp" so it prints out all + dispersion information. 051491 + +rvcolon.x +rvcomdef.h +coloncmds.x +rv0$lib/scr/fxcor.key +rv0$src/doc/fxcor.hlp + Implemented a ":printz" command to toggle redshift output. 051491 + +rvbatch.x + Added more bounds checking to window computation. If a window was + set too large or the center was outside the ccf bounds, a segvio + would occur. 051491 + +aplists.x + Fixed bug with onedspec images returning an ERR apnum. 051491 + +wxcor.h +rvflags.h +rvpackage.h +rvwriteln.x + Implemented output of redshift z values when relative velocity + exceeds a threshold (set at 0.2). (User request) 051491 + +rvvfit.x +rvbatch.x +rvparam.x +rvwrite.x +t_fxcor.x +rverrmsg.x +coloncmds.x +rvwriteln.x +rvstrings.x + Implemented the "verbose" parameter as an enumerated string to + suppress metacode or log files (User request). 051391 + +deblend.x +dispcor.x +getdisp.x +rvparam.x +rvrebin.x +continpars.x + Cleanup up some more type inconsistencies found by SPPLINT. 051391 + +rvgetim.x + Fixed typo causing template aperture to be incorrectly printed + in logs if only 1-D. 051291 + +rvimutil.x + Fixed bug so that aperture lists are updated for each new image. + If aperture="*" and the apertures in the image varies, the original + last was always being used causing an "Aperture out of range" + message. 051291 + +rvdrawfit.x + Changed line type of fitted function to be dashed so it's dis- + tinquished from the ccf (user request). 051091 + +rvcorrel.x + Removed an extra factor of 2 from the computation of the anti- + symmetric noise component in rv_antisym(). This was causing + an incorrect value of the T&D R to be computed. 050191 + +rvkeywords.h + Changed size of the 'struct' to be 16. This clears up a memory bug + that has been present in the system since dirt but has only recently + made my life miserable. 051091 + +fxcor.par + Changed boolean parameters declared as quoted "yes"/"no" to be + true boolean values yes/no. 050991 + +wrtccf.x +rvplot.x +aplists.x +rvparam.x +fftmode.x +rvparam.x +zzdebug.x +rvimutil.x +specmode.x +filtpars.x +coloncmds.x +rvdrawfit.x +continpars.x + Fixed some argument type mismatches and number of arguments. This + may have been the cause of the long-time "Salloc Undeflow" error. + All of these were caught using the public domain "f2c" program + in combination with UNIX "lint" on the resulting C code. 050291 + +rvinit.x + Fixed typo indentation which was making the logic look different + than it actually was. 042991 + +rvgetim.x + Returned from rv_ap2line() after determining format was ONEDSPEC + rather than continue to parse APNUM keywords which may be different + values. 042991 + +rvbatch.x + Fixed bug causing template velocities to be confused in batch + mode with a template list. 042691 + +wxcor.h + Straightened out alignment of HGHT and VFWHM columns. 042591 + +rvdrawfit.x + Fixed bug causing fitting function and ccf to not be drawn in + batch mode. 042591 + +rvpackage.h +rvdrawfit.x +rvcursor.x + Added code to avoid the 'erasing' of a possible residual plot when + refitting a peak. On xterm windows this shows up as a draw and + further messes up the plot. 042191 + +rvrvcor.x + Removed calculation and reset of "verror" from the procedure. The + actual error from the T&D computations is done in the fitting + routines always called prior to the rv_rvcorrect() procedure and this + was just trashing a correct error. By deleting the reset of + verror = INDEF, we retain a velocity error estimate for the relative + vel when a full heliocentric correction can't be computed. 042291 + +fftmode.x +specmode.x +rvxcomdef.h +coloncmds.x + Added output for ":wpc" command to print rebinned wpc. 042191 + +splitplot.x + Fixed typo preventing points in summary plot ccf being plotted. 042191 + +/arc/ftp/iraf.old/rv0.tar.Z + Fixed RV_VREL bug in archive since support for high redshift work is + lacking and it seemed like an important fix (a 'no-no'). 4/17 22:23 + +doc/continpars.hlp + Added a note on where to look for syntax of "c_sample". 040491 + +doc/fxcor.hlp + Changed wording of rebinning order to reflect implementation. 040491 + +rvrvcor.x + Changed argument to rv_shift2vel() so shift is real and not double. + This was causing incorrect VREL values to be printed. 040491 + +------------------------------------------------------------------------------- +Package frozen and archived for Beta Release. 040191 +------------------------------------------------------------------------------- + +fftmode.x +rvcolon.x +rvfilter.x +specmode.x +coloncmds.x + Cleaned up some missing sfree() calls. 032091 + +contin.x +rvbatch.x +rvgetim.x +rvrebin.x +rvcursor.x +coloncmds.x +readtlist.x + Changed calls to do_continuum() so they pass int flags rather than + a character in order to avoid confusion and problems with chars/int + getting confused. 031991 + +rvbatch.x + Fixed bug in window params when center is specified. 031991 + +rvbatch.x + Fixed duplicate continuum subtraction being done in batch mode. 031591 + +rvplot.x + Fixed min/max compiler bug under VMS. 031491 + +fftmode.x +specmode.x + Fixed bug with the stridx() function having an int argument when a + char is requested. Since the integer*4 keystroke gets passed into + a integer*2 argument, the info in the high two bytes is lost. 031491 + +rv0$lib/scr/fftmode.key + Added to 'o' and 't' commands to menu. 031491 + +rvbatch.x +coloncmds.x +contin.x + Removed 'b' option to do_continuum(), and removed salloc declarations + in continuum() since there was no sfree and they weren't being used + anyway. 031391 + +rvdatacheck.x +splitplot.x + Fixed mixed-type arguments to min/max causing problems on the + VMS 5.4 compilers. 031291 + +rvutil.x +rvflags.h + Removed disp() function. Also fixed a bug in the rv_shiftspec() + procedure causing bad approximations for large redshifts in the + 'd' keystroke in specmode. 031291 + +rvvfit.x + Expanded output on .log file to 24 chars for image names. Added + note to docs saying image names may be truncated. 031191 + +getdisp.x + Saved data format for later use in output log. 031191 + +specmode.x + Added 'd' keystroke to not be remembered from SPECMODE. Fixed + bug with 'q' key being remembered. 031191 + +rvplot.x +rvutil.x +rvvfit.x +wrtccf.x +rvbatch.x +rvrvcor.x +rvsumplot.x +coloncmds.x +rvdrawfit.x +rvwriteln.x +splitplot.x + Made the calculation of the relative velocity uniform throughout + the code. The relativistic (1+z) form is now used since things + like plot scales and so on were slightly off at high redshift. + Talked w/ Silva baout this and he agrees. 030891 + +splitplot.x + Changed calculation of plot velocity scaling so it agrees w/ cursor + readout at high redshifts. This was previously done as shift*deltav + which is only an approximation. 030791 + +------------------------------------------------------------------------ +Updated noao systems with latest version prior to final release. 030791 +------------------------------------------------------------------------ + +rv0$rv0.cl + Expanded min_lenuserarea to 40000 to avoid problems encountered + by John Hill with large 2-D images. Code taken from nessie$nessie.cl + script. 030491 + +wxcor.h +rvwrite.x +rvwparam.x +rvwriteln.x + Added height to output and reorganized fields. 030291 + +rvwrite.x +specmode.x +coloncmds.x +rvwriteln.x + Changed output of sample regions so it's only written to logs + when the results are written. 030191 + +coloncmds.x + Fixed bug with ":output" not working. 030191 + +rvcursor.x +splitplot.x +coloncmds.x +doc/fxcor.hlp +rv0$lib/scr/fxcor.key + Implemented ymin/ymax commands to set ccf plot scaling. 030191 + +rvinit.x + Fixed typo initializing RV_WINR. Added y1,y2 inits. 030191 + +rvfitfunc.x + Added checks to the center1d fit to see if it returns an INDEF + shift. A user reported floating overflows, which was tracked to + the threshold level being set too high for his data. 022891 + +rvplot.x + Fixed bug with 'z' not working on pixel-correlation plots. 022291 + +rv0$lib/scr/fxcor.key +doc/fxcor.hlp +rvcursor.x, splitplot.x + Changed 'c' keystroke to be a cursor readout to help solve the problem + of users trying to use 'C' to get cursor position. Also added note in + the help page that 'C' is not recommended because of confused GIO w/ + multiple WCSs. Renamed 'c' to 'm'. 022291 + +titles.x + Removed fplot_title() and pplot_title() - not used. 022291 + +specmode.x + Fixed bug causing 's' to be recognized as a 'sample' command when + specmode was entered the 1st time and the last key was a sample sel- + ection. Leaving specmode and re-entering with 's' from ccf mode + caused odd behavior. Only occured with continuum=none. 021591 + +rv0$src/doc/fxcor.hlp, rv0$lib/scr/fxcor.key +rvpackage.h, rvcomdef.h t_fxcor.x, getdisp.x, aplists.x, coloncmds.x + Added a new parameter "pixcorr" which controls whether or not the + dispersion info in the header is used to rebin the data. If set to + 'y', then data are not rebinned and no velocities may be computed. + 021591 + +coloncmds.x + Fixed typo causing ":contin" to no take new value. 021591 + +splitplot.x + Fixed bug causing the top FFT plot to be incorrectly scaled. 021391 + +rvvfit.x + Fixed output of vel error when no dispersion info present. 020891 + +rvdatacheck.x + Added check for dispersion info when calculating deltav. 020891 + +getdisp.x + Added code to get CD_1 if CDELT1 not present, and made sure that + w0/wpc are not uninitialized. 020891 + +rvranges.x + Fixed bug that prevented range strings from being properly decoded. + The parsing loop wasn't being executed and the rangecount flag was + never reset from ALL_SPECTRUM. 020891 + +rvranges.x +rvdatacheck.x + Added more checks for rangecount and dc-flag values so regions would + be interpreted inthe right units. 020891 + +specmode.x + Fixed duplicate greactivate() call for ":show". 020891 + +------------------------------------------------------------------------------- + February 1, 1991 Test Version Released +------------------------------------------------------------------------------- +.endhelp diff --git a/noao/rv/aplists.x b/noao/rv/aplists.x new file mode 100644 index 00000000..6e5927e2 --- /dev/null +++ b/noao/rv/aplists.x @@ -0,0 +1,264 @@ +include <smw.h> +include "rvpackage.h" +include "rvflags.h" + + +# RV_APNUM_RANGE - Given a string in 'ranges' format decode it and +# load the apnum array in the header. + +int procedure rv_apnum_range (rv, apnum) + +pointer rv #I RV struct pointer +char apnum[SZ_LINE] #I APNUM range string + +pointer sp, ranges, image, aplist +pointer im, smw +int i, number, naps, stat + +pointer immap(), smw_openim() +int get_next_number(), imaccess() +int imtrgetim(), decode_ranges(), rv_verify_aps() +bool streq() +errchk immap, swm_openim, imaccess, rv_aplist, realloc, rv_verify_aps + +begin + if (streq(apnum,"") || streq(apnum," ")) { + call rv_errmsg ("Aperture list specified as a NULL string") + return (ERR_READ) + } + + call smark (sp) + + # If a wildcard template is given read the image otherwise + # expand the template list. + + if (apnum[1] == '*') { + call salloc (image, SZ_FNAME, TY_CHAR) + if (imtrgetim (RV_OBJECTS(rv), RV_IMNUM(rv), Memc[image], + SZ_FNAME) == EOF) { + call rv_errmsg ("Error getting object image `%s'.") + call pargstr (Memc[image]) + call sfree (sp) + return (ERR_READ) + } + if (imaccess (Memc[image], 0) == YES) { + im = immap (Memc[image], READ_ONLY, 0) + smw = smw_openim (im) + } else { + call rv_errmsg ("Object image does not exist.") + call sfree (sp) + return (ERR_READ) + } + + call rv_aplist (smw, aplist, naps) + + call smw_close (smw) + call imunmap (im) + + } else { + call salloc (ranges, 3*SZ_APLIST, TY_INT) + if (decode_ranges (apnum, Memi[ranges], SZ_APLIST, naps) == ERR) { + call sfree (sp) + call rv_errmsg ("Error decoding APNUM range string.") + return (ERR_READ) + } + + call malloc (aplist, naps, TY_INT) + number = 0 + i = 0 + while (get_next_number (Memi[ranges], number) != EOF) { + Memi[aplist+i] = number + i = i + 1 + } + } + + # Now that we've parsed the aperture parameter, let's make sure it's + # legal for the images we're given. If it is then we copy the new info + # into the struct, otherwise return ERR_READ. + + stat = rv_verify_aps (rv, apnum, Memi[aplist], naps) + if (stat == OK) { + call realloc (RV_APLIST(rv), 4*naps, TY_INT) + call realloc (RV_APPARAM(rv), SZ_LINE, TY_CHAR) + + call amovi (Memi[aplist], APLIST(rv,1), naps) + call strcpy (apnum, APPARAM(rv), SZ_LINE) + RV_APNUM(rv) = APLIST(rv,1) + RV_OAPNUM(rv) = APLIST(rv,1) + NUMAPS(rv) = naps + CURAPNUM(rv) = 1 + } + + call mfree (aplist, TY_INT) + call sfree (sp) + return (stat) +end + + +# RV_VERIFY_APS - Scan the object and template image lists and verify that +# list of apertures selected is valid for the two current images. +# +# NOTE: As this is currently implemented, we are restricted to either match- +# ing aperture pairs directly, or allowing only 1-D templates. This will +# change in a future release once separate aperture lists are maintained for +# both the object and the template images. + +int procedure rv_verify_aps (rv, apnum, aplist, naps) + +pointer rv #I RV struct pointer +char apnum[SZ_LINE] #I Aperture parameter string +int aplist[ARB] #I List of selected apertures +int naps #I Number of apertures. + +pointer sp, oimage, timage, aplist1 +pointer imo, smwo, imt, smwt, optr, tptr +int i, legal, onum, tnum, onspec, tnspec + +pointer immap(), smw_openim() +int rv_apmatch() +int imaccess(), imtrgetim() +errchk immap, smw_openim, imaccess, rv_aplist, realloc + +define exit_ 99 + +begin + call smark (sp) # let's get some storage space + call salloc (oimage, SZ_FNAME, TY_CHAR) + call salloc (timage, SZ_FNAME, TY_CHAR) + + onum = RV_IMNUM(rv) # initialize stuff + optr = RV_OBJECTS(rv) + tnum = RV_TEMPNUM(rv) + tptr = RV_TEMPLATES(rv) + + # Map the images so we can read the headers. + if (imtrgetim (optr, onum, Memc[oimage], SZ_FNAME) == EOF) { + call rv_errmsg ("Error getting object image `%s'.") + call pargstr (Memc[oimage]) + call sfree (sp) + return (ERR_READ) + } + if (imaccess(Memc[oimage],0) == YES) { + imo = immap (Memc[oimage], READ_ONLY, 0) + smwo = smw_openim (imo) + } else { + call sfree (sp) + call rv_errmsg ("Object image does not exist.") + return (ERR_READ) + } + + if (imtrgetim (tptr, tnum, Memc[timage], SZ_FNAME) == EOF) { + call rv_errmsg ("Error getting template image `%s'.") + call pargstr (Memc[timage]) + call sfree (sp) + return (ERR_READ) + } + if (imaccess(Memc[timage],0) == YES) { + imt = immap (Memc[timage], READ_ONLY, 0) + smwt = smw_openim (imt) + } else { + call sfree (sp) + call rv_errmsg ("Template image does not exist.") + return (ERR_READ) + } + + # Now verify that the aperture lists are correct for the two images. + # The check is done only against the current object/temp image pairs + # since the routine is only called in an instance of a new image. + aplist1 = NULL + legal = OK + onspec = SMW_NSPEC(smwo) + tnspec = SMW_NSPEC(smwt) + if (onspec == 1 && tnspec == 1 && apnum[1] != '*') { + call rv_errmsg( + "Aperture list cannot be applied to onedspec images.") + legal = ERR_READ + } else if (onspec == 1 && tnspec > 1) { + call rv_errmsg ( + "Aperture list cannot be applied to template image.") + legal = ERR_READ + } else if (onspec > 1) { + # Check object aperture list to see if the requested apertures are + # in the image list. + call rv_aplist (smwo, aplist1, onspec) + do i = 1, naps { + if (rv_apmatch(aplist[i], Memi[aplist1], onspec) == ERR) { + call rv_errmsg ( + "Requested aperture not present in object image.") + legal = ERR_READ + goto exit_ + } + } + + # If we have a two dimensional template do the same thing. + if (tnspec > 1) { + call mfree (aplist1, TY_INT) + call rv_aplist (smwt, aplist1, tnspec) + do i = 1, naps { + if (rv_apmatch(aplist[i], Memi[aplist1], tnspec) == ERR) { + call rv_errmsg ( + "Requested aperture not present in object image.") + legal = ERR_READ + goto exit_ + } + } + } + } + +exit_ call mfree (aplist1, TY_INT) # clean up + call smw_close (smwo) + call smw_close (smwt) + call imunmap (imo) + call imunmap (imt) + call sfree (sp) + return (legal) +end + + +# RV_APLIST -- Get a list of apertures from an SMW pointer. +# This routine allocates an integer array pointer which must be freed +# by the calling program. + +procedure rv_aplist (smw, aplist, naps) + +pointer smw #I SMW pointer +pointer aplist #O Aperture list pointer +int naps #O Number of apertures + +int i, ap, beam, dtype, nw +real aplow[2], aphigh[2] +double w1, dw, z +pointer coeff +errchk malloc, smw_gwattrs + +begin + naps = SMW_NSPEC(smw) + call malloc (aplist, naps, TY_INT) + + coeff = NULL + do i = 1, naps { + call smw_gwattrs (smw, i, 1, ap, beam, dtype, w1, dw, nw, z, + aplow, aphigh, coeff) + Memi[aplist+i-1] = ap + } + call mfree (coeff, TY_CHAR) +end + + +# RV_APMATCH - Given an aperture number see if it is in the given list. + +int procedure rv_apmatch (apnum, aplist, naps) + +int apnum #I Requested aperture +int aplist[ARB] #I Aperture list +int naps #I Number of apertures + +int i + +begin + do i = 1, naps { + if (apnum == aplist[i]) + return (OK) + } + return (ERR) +end diff --git a/noao/rv/coloncmds.x b/noao/rv/coloncmds.x new file mode 100644 index 00000000..d5ff10e1 --- /dev/null +++ b/noao/rv/coloncmds.x @@ -0,0 +1,1416 @@ +include <ctype.h> +include <fset.h> +include <error.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" +include "rvsample.h" + +# COLON_CMDS - Utility file for common colon commands. Usually, just +# routines to get/set parameter values. Task specific stuff is left in +# the appropriate colon command source file. + + +# CMD_ADD_COMMENT - Add a comment to the output logs. + +procedure cmd_add_comment (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf +int i +char c + +begin + if (RV_TXFD(rv) == NULL) { + call rv_errmsg ("No output log yet opened.") + return + } + + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Now read the line and build up the buffer. + call scanc (c) + if (c == '\n' || c == EOS) { + call rv_errmsg ("Usage: ':comment <string>'") + call sfree (sp) + return + } else { + i = 0 + while (c != '\n' && c != EOS && i < SZ_LINE) { + Memc[buf+i] = c + i = i + 1 + call scanc (c) + } + Memc[buf+i] = '\0' + call fprintf (RV_TXFD(rv), "# %s\n") + call pargstr (Memc[buf]) + } + + call sfree (sp) +end + + +# CMD_APLIST - Set/Show the aperture list to process. + +procedure cmd_aplist (rv, written) + +pointer rv #I RV struct pointer +bool written #I Data write flag + +pointer sp, buf +int stat, rv_apnum_range() +errchk realloc + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + call rv_do_save (rv, written) + stat = rv_apnum_range (rv, Memc[buf+1]) + } else { + call printf ("Aperture list = `%s'") + call pargstr (APPARAM(rv)) + } + + call sfree (sp) +end + + +# CMD_APNUM - Get/Set the APNUM. + +procedure cmd_apnum (rv, written) + +pointer rv #I RV struct pointer +bool written #I Data write flag + +int i, ival, found +int rv_getim(), nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + found = NO # position the aplist pointer + do i = 1, NUMAPS(rv) { + if (ival == APLIST(rv,i)) { + CURAPNUM(rv) = i + found = YES + } + } + if (found == NO) { # check if it's legal + call rv_errmsg ( + "Apnum not in current list. Reset list with `:apertures'") + return + } + call rv_do_save (rv, written) + RV_APNUM(rv) = ival + } else { + call printf ("APNUM = %d") + call pargi (RV_APNUM(rv)) + return + } + + # Get the new apertures. + OBJCONT(rv) = NO + IS_DBLSTAR(rv) = NO + #SR_COUNT(RV_OSAMPLE(rv)) = ALL_SPECTRUM + #SR_COUNT(RV_RSAMPLE(rv)) = ALL_SPECTRUM + if (rv_getim(rv, IMAGE(rv), OBJECT_SPECTRUM, INDEF, INDEF, INDEFI) == + ERR_READ) + return + REFCONT(rv) = NO + if (rv_getim(rv, RIMAGE(rv), REFER_SPECTRUM, INDEF, INDEF, INDEFI) == + ERR_READ) + return + + RV_NEWXCOR(rv) = YES +end + + +# CMD_APODIZE - Get/Set the apodize percentage. + +procedure cmd_apodize (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + RV_APODIZE(rv) = rval + RV_NEWXCOR(rv) = YES + } else { + call printf ("Apodize percentage = %g") + call pargr (RV_APODIZE(rv)) + } +end + + +# CMD_AUTODRAW - Set/Show the autodraw flag. + +procedure cmd_autodraw (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + RV_AUTODRAW(rv) = btoi (bval) + } else { + call printf ("autodraw = `%b'") + call pargb (itob(RV_AUTODRAW(rv))) + } +end + + +# CMD_AUTOWRITE - Set/Show the autowrite flag. + +procedure cmd_autowrite (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + RV_AUTOWRITE(rv) = btoi (bval) + } else { + call printf ("autowrite = `%b'") + call pargb (itob(RV_AUTOWRITE(rv))) + } +end + + +# CMD_BACKGROUND - Set/Show the fitting background. + +procedure cmd_background (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + call rv_erase_fit (rv, false) + RV_BACKGROUND(rv) = rval + RV_FITDONE(rv) = NO + } else { + call printf ("Background = %g") + call pargr (RV_BACKGROUND(rv)) + } +end + + +# CMD_CONT - Do the continuum normalization. + +procedure cmd_cont (rv) + +pointer rv #I RV struct pointer + +pointer sp, cmd +int stat, spc_cursor() + +begin + call smark (sp) + call salloc (cmd, SZ_FNAME, TY_CHAR) + + call gargstr (Memc[cmd], SZ_FNAME) + if (Memc[cmd] == EOS) { + # The default action (i.e. command is ":cont") is to do + # the continuum fitting from both the current bin spectrum + # and the current template spectrum. + call do_continuum (rv, OBJECT_SPECTRUM) + RV_GTYPE(rv) = NORM_PLOT + if (RV_CONTINUUM(rv) == TEMP_ONLY || RV_CONTINUUM(rv) == BOTH) + call do_continuum (rv, REFER_SPECTRUM) + + } else { + # Now parse the argument to find out what to do. + switch (Memc[cmd+1]) { + case 'o': # do object only + call do_continuum (rv, OBJECT_SPECTRUM) + case 't': # do template only + call do_continuum (rv, REFER_SPECTRUM) + default: + call rv_errmsg ( + "Ambigous argument. Choose one of 'object|template'.") + } + } + if (RV_INTERACTIVE(rv) == YES) + stat = spc_cursor (rv) + + call sfree (sp) +end + + +# CMD_CONTINUUM - Set/Show which spectra get continuum subtracted. + +procedure cmd_continuum (rv) + +pointer rv #I RV struct pointer + +pointer sp, cont, bp +int contin, cod_which() + +begin + call smark (sp) + call salloc (bp, SZ_FNAME, TY_CHAR) + call salloc (cont, SZ_FNAME, TY_CHAR) + + call gargstr (Memc[cont], SZ_FNAME) # get a new file name + if (Memc[cont] != EOS) { + contin = cod_which (Memc[cont+1]) + if (contin == 0) { + call rv_errmsg ("Unknown value. Choose one of `%s'") + call pargstr ("|both|none|object|template|") + call sfree (sp) + return + } + RV_CONTINUUM(rv) = contin + if (RV_CONTINUUM(rv) == BOTH || RV_CONTINUUM(rv) == OBJ_ONLY) + call do_continuum (rv, OBJECT_SPECTRUM) + if (RV_CONTINUUM(rv) == BOTH || RV_CONTINUUM(rv) == TEMP_ONLY) + call do_continuum (rv, REFER_SPECTRUM) + RV_NEWXCOR(rv) = YES + } else { + call nam_which (RV_CONTINUUM(rv), Memc[bp]) + call printf ("continuum = `%s'") + call pargstr (Memc[bp]) + } + call sfree (sp) +end + + +# CMD_CORRECTION - Compute a velocity correction from a pixel shift. + +procedure cmd_correction (rv) + +pointer rv #I RV struct pointer + +double vobs, vcor, verr, rv_shift2vel() +real rval, sigma +int stat, nscan(), rv_rvcorrect() + +begin + call gargr (rval) + sigma = 0.0 + if (nscan() == 2) { + if (RV_DCFLAG(rv) != -1) { + stat = rv_rvcorrect (rv, rval, sigma, vobs, vcor, verr) + call printf ( + "Shift = %.4f ==> vrel = %.4f vobs = %.4f vhelio = %.4f") + call pargr (rval) + call pargd (rv_shift2vel(rv,rval)) + call pargd (vobs) + call pargd (vcor) + call flush (STDOUT) + } else { + call rv_errmsg ("No dispersion information for computation.") + } + } else + call rv_errmsg ("Usage: ':correction <shift>'") +end + + +# CMD_DELTAV - Print the velocity dispersion to the screen. + +procedure cmd_deltav (rv) + +pointer rv #I RV struct pointer + +begin + call printf ("Velocity dispersion = %7.2f Km/sec/pixel") + call pargr (RV_DELTAV(rv)) +end + + +# CMD_FILTER - Set/Show the current FFT filter value. + +procedure cmd_filter (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf, bp +int tmp, filt +int rv_chk_filter(), cod_which() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + filt = cod_which (Memc[buf+1]) + if (filt == 0) { + call rv_errmsg ("Unknown value. Choose one of `%s'") + call pargstr ("|both|none|object|template|") + call sfree (sp) + return + } + tmp = RV_FILTER(rv) + RV_FILTER(rv) = filt + if (filt == BOTH || filt == OBJ_ONLY) { + if (rv_chk_filter(rv,OBJECT_SPECTRUM) != OK) { + RV_FILTER(rv) = tmp + call rv_errmsg ( + "Filter values not yet set or ambiguous.") + call sfree (sp) + return + } + } else if (filt == BOTH || filt == TEMP_ONLY) { + if (rv_chk_filter(rv,REFER_SPECTRUM) != OK) { + RV_FILTER(rv) = tmp + call rv_errmsg ( + "Filter values not yet set or ambiguous.") + call sfree (sp) + return + } + } + RV_FILTER(rv) = filt + RV_NEWXCOR(rv) = YES + } else { + call nam_which (RV_FILTER(rv), Memc[bp]) + call printf ("filter = `%s'") + call pargstr (Memc[bp]) + } + + call sfree (sp) +end + + +# CMD_FITFUNC - Set/Show the current correlation fitting function. + +procedure cmd_fitfunc (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf, bp +int func, strdic() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + func = strdic(Memc[buf+1],Memc[buf+1], SZ_FNAME, RV_CFTYPES) + if (func == 0) { + call rv_errmsg ("Unknown function. Choose one of `%s'") + call pargstr ("|gaussian|lorentzian|parabola|center1d|") + call sfree (sp) + return + } + call rv_erase_fit (rv, false) + RV_FITFUNC(rv) = func + RV_FITDONE(rv) = NO + call rv_erase_fit (rv, true) + } else { + call nam_fitfunc (rv, Memc[bp]) + call printf ("Fitting Function = `%s'") + call pargstr (Memc[bp]) + } + call sfree (sp) +end + + +# CMD_HEIGHT - Get/Set the fitting height. + +procedure cmd_height (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + call rv_erase_fit (rv, false) + RV_FITHGHT(rv) = rval + RV_FITDONE(rv) = NO + } else { + call printf ("Height = %g") + call pargr (RV_FITHGHT(rv)) + } +end + + +# CMD_IMUPDATE - Set/Show the image header update flag. + +procedure cmd_imupdate (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + RV_IMUPDATE(rv) = btoi (bval) + } else { + call printf ("imupdate = `%b'") + call pargb (itob(RV_IMUPDATE(rv))) + } +end + + +# CMD_LINECOLOR - Set/Show the overlay vector line color. + +procedure cmd_linecolor (rv) + +pointer rv #I RV struct pointer + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + RV_LINECOLOR(rv) = ival + RV_NEWGRAPH(rv) = YES + } else { + call printf ("Line color = %d") + call pargi (RV_LINECOLOR(rv)) + } +end + + +# CMD_MAXWIDTH - Get/Set the maximum fitting width. + +procedure cmd_maxwidth (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + if (rval > RV_CCFNPTS(rv)) { + call rv_errmsg ("Maxwidth must be less than %d.") + call pargi (RV_CCFNPTS(rv)) + } else { + call rv_erase_fit (rv, false) + RV_MAXWIDTH(rv) = rval + RV_FITDONE(rv) = NO + } + } else { + call printf ("maxwidth = %g") + call pargr (RV_MAXWIDTH(rv)) + } +end + + +# CMD_MINWIDTH - Get/Set the minimum fitting width. + +procedure cmd_minwidth (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + if (rval < 3.) { + call rv_errmsg ("Minwidth must be greater than 3.") + } else { + call rv_erase_fit (rv, false) + RV_MINWIDTH(rv) = rval + RV_FITDONE(rv) = NO + } + } else { + call printf ("minwidth = %g") + call pargr (RV_MINWIDTH(rv)) + } +end + + +# CMD_NEXT - Get the next input spectrum. + +int procedure cmd_next (rv, infile, rinfile, written, cmdstr) + +pointer rv #I RV struct pointer +pointer infile, rinfile #I File list pointers +bool written #I Have data been written? +char cmdstr[SZ_FNAME] #I Command string + +pointer sp, cmd +int code +int next_ap(), next_spec(), next_temp() + +define exit_ 99 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + code = OK + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + call gargstr (Memc[cmd], SZ_FNAME) + switch (Memc[cmd+1]) { + case 'a': # next aperture + call rv_do_save (rv, written) + code = next_ap (rv, written) + case 'o': # next object spectrum + call rv_do_save (rv, written) + code = next_spec (rv, infile, written) + case 't': # next template spectrum + call rv_do_save (rv, written) + code = next_temp (rv, rinfile, written) + default: + call rv_errmsg ("Please specify 'aperture|object|template'.") + } + +exit_ call sfree (sp) + return (code) +end + + +# CMD_OBJECTS - Set/Show the [new] object input list. + +int procedure cmd_objects (rv, infile, written) + +pointer rv #I RV struct pointer +pointer infile #I input list pointer +bool written #I data write flag + +pointer sp, buf +char imname[SZ_FNAME] +int ip +pointer imtopen() +int get_spec(), imtrgetim(), rv_verify_aps() +errchk imtopen + +begin + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + call rv_do_save (rv, written) + for (ip=1; IS_WHITE(Memc[buf+ip-1]); ip=ip+1) + ; + call imtclose (infile) + OBJCONT(rv) = NO # update data flags + infile = imtopen (Memc[buf+ip-1]) + RV_OBJECTS(rv) = infile + RV_IMNUM(rv) = 1 + if (imtrgetim(infile, RV_IMNUM(rv), imname, SZ_FNAME) != EOF && + infile != EOF) { + if (get_spec(rv, imname, OBJECT_SPECTRUM) == ERR_READ) { + call sfree (sp) + return (ERR_READ) + } + if (rv_verify_aps (rv, APPARAM(rv), APLIST(rv,1), + NUMAPS(rv)) == ERR_READ) + return (ERR_READ) + } else { + call rv_errmsg ("Error reading image from list.\n") + call sfree (sp) + return (ERR_READ) + } + RV_NEWXCOR(rv) = YES + RV_FITDONE(rv) = NO + written = false + } else { + call printf ("Current object image name = `%s'") + call pargstr (IMAGE(rv)) + } + + call sfree (sp) + return (OK) +end + + +# CMD_OUTPUT - Change/Show the output log file name. + +procedure cmd_output (rv) + +pointer rv #I RV struct pointer + +pointer sp, fn +bool streq() +pointer gopen() +errchk gopen + +begin + call smark (sp) + call salloc (fn, SZ_FNAME, TY_CHAR) + + call gargstr (Memc[fn], SZ_FNAME) # get new file name + if (Memc[fn] == EOS) { + call printf ("Output file name = `%s'") + call pargstr (SPOOL(rv)) + } else { + # Close existing log file - if any + if (RV_TXFD(rv) != NULL) + call close (RV_TXFD(rv)) + if (RV_GRFD(rv) != NULL) + call close (RV_GRFD(rv)) + + # Open the graphics pointer and file descriptors. + if (streq("",Memc[fn+1]) || streq(" ",Memc[fn+1]) || + Memc[fn+1] == '"') { + RV_TXFD(rv) = NULL + RV_GRFD(rv) = NULL + } else if (streq("STDOUT",Memc[fn+1])) { + RV_TXFD(rv) = STDOUT + RV_GRFD(rv) = NULL + } else { + # Open the files + if (!streq(Memc[fn+1],"\"\"")) { + call init_files (rv, DEVICE(rv), Memc[fn+1], true) + RV_MGP(rv) = gopen ("stdvdm", APPEND, RV_GRFD(rv)) + } + } + + if (streq("",Memc[fn+1]) || streq(" ",Memc[fn+1]) || + Memc[fn+1] == '"') { + call strcpy ("", SPOOL(rv), SZ_FNAME) + } else + call strcpy (Memc[fn+1], SPOOL(rv), SZ_FNAME) + } + + call sfree (sp) +end + + +# CMD_OUT_TYPE - CCF output type. + +procedure cmd_out_type (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + if (Memc[buf+1] == 'i') { + RV_CCFTYPE(rv) = OUTPUT_IMAGE + } else if (Memc[buf+1] == 't') { + RV_CCFTYPE(rv) = OUTPUT_TEXT + } else + call rv_errmsg ("Choose one of 'image|text'.") + } else { + call printf ("ccftype = `%s'") + if (RV_CCFTYPE(rv) == OUTPUT_IMAGE) + call pargstr ("image") + else + call pargstr ("text file") + } + + call sfree (sp) +end + + +# CMD_PEAK - Is peak height a normalized correlation? + +procedure cmd_peak (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + call rv_erase_fit (rv, false) + RV_PEAK(rv) = btoi (bval) + RV_FITDONE(rv) = NO + } else { + call printf ("peak = `%b'") + call pargb (itob(RV_PEAK(rv))) + } +end + + +# CMD_PIXCORR - Do a pixel-only correlation? + +procedure cmd_pixcorr (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int stat, nscan(), btoi(), rv_getim() + +begin + call gargb (bval) + if (nscan() == 2) { + if (btoi(bval) != RV_PIXCORR(rv)) { + RV_PIXCORR(rv) = btoi (bval) + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + call printf ("Re-reading images....") + call flush (STDOUT) + stat = rv_getim (rv, IMAGE(rv), OBJECT_SPECTRUM, INDEF, + INDEF, INDEFI) + stat = rv_getim (rv, RIMAGE(rv), REFER_SPECTRUM, INDEF, + INDEF, INDEFI) + call printf ("\n") + call flush (STDOUT) + } + } else { + call printf ("pixcorr = `%b'") + call pargb (itob(RV_PIXCORR(rv))) + } +end + + +# CMD_PREVIOUS - Get the previous input spectrum. + +int procedure cmd_previous (rv, infile, rinfile, written, cmdstr) + +pointer rv #I RV struct pointer +pointer infile, rinfile #I file list pointers +bool written #I have data been written? +char cmdstr[SZ_FNAME] #I command string + +pointer sp, cmd +int code +int prev_ap(), prev_spec(), prev_temp() + +define exit_ 99 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + code = OK + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + call gargstr (Memc[cmd], SZ_FNAME) + switch (Memc[cmd+1]) { + case 'a': # previous aperture + call rv_do_save (rv, written) + code = prev_ap (rv, written) + case 'o': # previous object spectrum + call rv_do_save (rv, written) + code = prev_spec (rv, infile, written) + case 't': # previous template spectrum + call rv_do_save (rv, written) + code = prev_temp (rv, rinfile, written) + default: + call rv_errmsg ("Please specify 'aperture|object|template'.") + } + +exit_ call sfree (sp) + return (code) +end + + +# CMD_PRINTZ - Toggle output of Z values + +procedure cmd_printz (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + RV_PRINTZ(rv) = btoi (bval) + } else { + call printf ("Z output = `%b'") + call pargb (itob(RV_PRINTZ(rv))) + } +end + + +# CMD_PRTDISP - Print the rebinned dispersion info for the user. + +procedure cmd_prtdisp (rv) + +pointer rv #I RV struct pointer + +int nscan() + +begin + if (nscan() > 1) { + call rv_errmsg ("Syntax: ':disp'.") + } else { + if (RV_DCFLAG(rv) != -1) { + call printf ("Object W0 = %.5f Template W0 = %.5f WPC = %g\n") + call pargr (RV_OW0(rv)) + call pargr (RV_RW0(rv)) + call pargr (RV_OWPC(rv)) + } else { + call printf ( + "No dispersion information present. (Pixel correlation only)") + } + } +end + + +# CMD_REBIN - Set/Show the rebin parameter. + +procedure cmd_rebin (rv) + +pointer rv #I RV struct pointer + +pointer sp, rb +int rebin, cod_rebin() + +begin + call smark (sp) + call salloc (rb, SZ_FNAME, TY_CHAR) + + call gargstr (Memc[rb], SZ_FNAME) + if (Memc[rb] != EOS) { + rebin = cod_rebin (Memc[rb]) + if (rebin == ERR) { + call rv_errmsg ( + "`rebin' must be one of `smallest|largest|object|template'") + call sfree (sp) + return + } + RV_REBIN(rv) = rebin + } else { + call nam_verbose (rv, Memc[rb]) + call printf ("rebin = `%s'") + call pargstr (Memc[rb]) + } +end + + +# CMD_REFSPEC - Set/Show the [new] reference spectrum. + +int procedure cmd_refspec (rv, rinfile, written) + +pointer rv #I RV struct pointer +pointer rinfile #U image list pointer +bool written #I data write flag + +pointer sp, buf, tmp +pointer imtopen() +int ip +int read_template_list(), rv_verify_aps() +errchk imtopen + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + call rv_do_save (rv, written) + for (ip=0; IS_WHITE(Memc[buf+ip]); ip=ip+1) # skip white space + ; + tmp = imtopen (Memc[buf+ip]) + if (read_template_list(rv,tmp) == ERR_READ) { + call rv_errmsg ("Null list specified for templates.") + call sfree (sp) + return (ERR_READ) + } else { + call imtclose (rinfile) + rinfile = tmp + RV_TEMPLATES(rv) = tmp + if (rv_verify_aps (rv, APPARAM(rv), APLIST(rv,1), + NUMAPS(rv)) == ERR_READ) + return (ERR_READ) + } + RV_NEWXCOR(rv) = YES + RV_FITDONE(rv) = NO + call rv_tempcodes (rv, RV_TXFD(rv)) # write out new codes + written = false + + } else { + call printf ("Current template image name = `%s'") + call pargstr (RIMAGE(rv)) + } + + call sfree (sp) + return (OK) +end + + +# CMD_REGIONS - Set/Show the current selected regions list. + +int procedure cmd_regions (rv, ssp) + +pointer rv #I RV struct pointer +pointer ssp #I Sample struct pointer + +pointer sp, buf +int rv_load_sample() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call aclrs (Memc[buf], SZ_FNAME) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + call rv_erase_regions (ssp, RV_GP(rv)) + if (Memc[buf+1] == '*') + SR_COUNT(ssp) = ALL_SPECTRUM + else { + if (rv_load_sample(ssp, Memc[buf+1]) == ERR_CORREL) { + call sfree (sp) + return (ERR_CORREL) + } + } + RV_NEWXCOR(rv) = YES + + if (SR_COUNT(ssp) != ALL_SPECTRUM) + call rv_mark_regions (ssp, RV_GP(rv)) + SR_MODIFY(ssp) = YES + } else { + call rv_make_range_string (ssp, Memc[buf]) + call printf ("Sample regions selected: `%s'") + call pargstr (Memc[buf]) + call flush (STDOUT) + } + + call sfree (sp) + return (OK) +end + + +# CMD_RESULT - Page the logfile of results. + +procedure cmd_result (rv) + +pointer rv #I RV struct pointer + +pointer sp, cmd, buf, gp +int open(), fstati() +errchk open + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + call smark (sp) + call salloc (buf, SZ_FNAME, TY_CHAR) + call salloc (cmd, SZ_FNAME, TY_CHAR) + + # Page the logfile. Pointer is closed to be VMS compatible. + call gargstr (Memc[cmd], SZ_FNAME) + if (Memc[cmd] == EOS) { + if (RV_TXFD(rv) != NULL) { + if (fstati(RV_TXFD(rv),F_FILESIZE) == 0) + call rv_errmsg ("Nothing yet written to logfile.") + else { + call sprintf (Memc[buf], SZ_FNAME, "%s.txt\0") + call pargstr (SPOOL(rv)) + call flush (RV_TXFD(rv)) + call close (RV_TXFD(rv)) + call gpagefile (gp, Memc[buf], "Log File of Results:") + RV_TXFD(rv) = open (Memc[buf], APPEND, TEXT_FILE) + } + } else + call rv_errmsg ("No output file specified.") + } else { + call sprintf (Memc[buf], SZ_FNAME, "%s.txt\0") + call pargstr (Memc[cmd]) + call gpagefile (gp, Memc[buf], "Log File of Results:") + } + + call sfree (sp) +end + + +# CMD_TEMPVEL - Set/show the known template velocity. + +procedure cmd_tempvel (rv, tnum) + +pointer rv #I RV struct pointer +int tnum #I Template number + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + TEMPVEL(rv,tnum) = rval + RV_NEWXCOR(rv) = YES + } else { + call printf ("Template velocity = %g km/sec") + call pargr (TEMPVEL(rv,tnum)) + } +end + + +# CMD_TNUM - Get the specified template spectrum + +int procedure cmd_tnum (rv, rinfile, written, cmdstr) + +pointer rv #I RV struct pointer +pointer rinfile #I File list pointers +bool written #I Have data been written? +char cmdstr[SZ_FNAME] #I Command string + +pointer sp, cmd +int i, tn, t1, t2, code +int strlen(), get_spec(), imtrgetim() + +define exit_ 99 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + code = OK + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Now get the requested template number. + call gargstr (Memc[cmd], SZ_FNAME) + for (i=0; IS_WHITE(Memc[cmd+i]); i=i+1) + ; + if (IS_DIGIT(Memc[cmd+i])) { + call sscan (Memc[cmd+i]) + call gargi (tn) + #RV_TEMPNUM(rv) = tn + } else { + if (strlen(Memc[cmd+i]) == 1) { + tn = int (Memc[cmd+i]) + if (IS_LOWER(tn)) tn = TO_UPPER(tn) + tn = tn - 'A' + 1 + } else if (strlen(Memc[cmd+i]) == 2) { + if (Memc[cmd+i] == ' ') + t1 = 0 + else { + t1 = int (Memc[cmd+i]) + if (IS_LOWER(t1)) t1 = TO_UPPER(t1) + t1 = t1 - 'A' + 1 + } + t2 = int (Memc[cmd+i]) + if (IS_LOWER(t2)) t2 = TO_UPPER(t2) + t2 = t2 - 'A' + 1 + tn = t1 * 26 + t2 + } + } + + # Optimize. + if (RV_TEMPNUM(rv) == tn) { + call nam_tempcode (tn, Memc[cmd]) + call rv_errmsg ("Current template is already template `%s'.\n") + call pargstr (Memc[cmd]) + call sfree (sp) + return + } + + # Check for the data write. + call rv_do_save (rv, written) + + # Do the read on the template + RV_TEMPNUM(rv) = tn + if (imtrgetim(rinfile, RV_TEMPNUM(rv), RIMAGE(rv), SZ_FNAME) != EOF) { + if (get_spec (rv, RIMAGE(rv), REFER_SPECTRUM) == ERR_READ) + call error (0, "Error reading next template.") + call rv_imtitle (RIMAGE(rv), TEMPNAME(rv), SZ_FNAME) + written = false + RV_TEMPCODE(rv) = TEMPCODE(rv,RV_TEMPNUM(rv)) + call amovkr (0.0, COEFF(rv,1), 4) + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + } else + call rv_errmsg ("Error getting the requested template.") + +exit_ call sfree (sp) + return (code) +end + + +# CMD_TEXTCOLOR - Set/Show the text color. + +procedure cmd_textcolor (rv) + +pointer rv #I RV struct pointer + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + RV_TXTCOLOR(rv) = ival + } else { + call printf ("Text color = %d") + call pargi (RV_TXTCOLOR(rv)) + } +end + + +# CMD_VERBOSE - Set/Show the verbose output flag. + +procedure cmd_verbose (rv) + +pointer rv #I RV struct pointer + +pointer sp, bp, op +int verbose +int cod_verbose() + +begin + call smark (sp) + call salloc (bp, SZ_FNAME, TY_CHAR) + call salloc (op, SZ_FNAME, TY_CHAR) + + call gargstr (Memc[bp], SZ_FNAME) + if (Memc[bp] != EOS) { + verbose = cod_verbose (Memc[bp]) + if (verbose == ERR) { + call rv_errmsg ( + "`verbose' must be one of `short|long|nogki|nolog|txtonly'") + call sfree (sp) + return + } + RV_VERBOSE(rv) = verbose + } else { + call nam_verbose (rv, Memc[op]) + call printf ("verbose = `%s'") + call pargstr (Memc[op]) + } + + call sfree (sp) +end + + +# CMD_VERSION - Development debug to print IRAF/RV version numbers. + +procedure cmd_version () + +begin + call printf ("RV Version: %s") + call pargstr (RV_VERSION) +end + + +# CMD_WEIGHTS - Get/Set the fitting weights. + +procedure cmd_weights (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + call rv_erase_fit (rv, false) + RV_WEIGHTS(rv) = rval + RV_FITDONE(rv) = NO + } else { + call printf ("weights = %g") + call pargr (RV_WEIGHTS(rv)) + } +end + + +# CMD_WIDTH - Get/Set the fitting width. + +procedure cmd_width (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + if (!IS_INDEF(rval)) { + if (int(rval) > RV_CCFNPTS(rv)) { + call rv_errmsg ("Width is greater than npts in the ccf.") + return + } + } + call rv_erase_fit (rv, false) + RV_FITWIDTH(rv) = rval + RV_FITDONE(rv) = NO + } else { + call printf ("width = %g") + call pargr (RV_FITWIDTH(rv)) + } +end + + +# CMD_WINCENTER - Get/Set the window center. + +procedure cmd_wincenter (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + RV_WINCENPAR(rv) = rval + call rv_batch_xcor (rv, RV_TEMPNUM(rv), RV_APNUM(rv), NO, YES, YES) + } else { + if (RV_DCFLAG(rv) == -1 || RV_PIXCORR(rv) == YES) { + call printf ("wincenter = %d lags") + if (IS_INDEF(RV_WINPAR(rv))) + call pargi (INDEFI) + else + call pargi (int(RV_WINCENPAR(rv))) + } else { + call printf ("wincenter = %.2f Km/sec") + call pargr (RV_WINCENPAR(rv)) + } + } +end + + +# CMD_WINDOW - Set/show the current width of the peak window. + +procedure cmd_window (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + RV_WINPAR(rv) = rval + call rv_batch_xcor (rv, RV_TEMPNUM(rv), RV_APNUM(rv), NO, YES, YES) + } else { + if (RV_DCFLAG(rv) == -1 || RV_PIXCORR(rv) == YES) { + call printf ("window = %d pixels") + if (IS_INDEF(RV_WINPAR(rv))) + call pargi (INDEFI) + else + call pargi (int(RV_WINPAR(rv))) + } else { + call printf ("window = %.2f Km/sec") + call pargr (RV_WINPAR(rv)) + } + } +end + + +# CMD_WRITE - Write results to logfile and/or header. + +procedure cmd_write (rv, written) + +pointer rv #I RV struct pointer +bool written #I data write flag + +pointer sp, fn, fname +pointer gopen() +int stat, scan() +bool streq() +errchk gopen + +begin + if (written && RV_UPDATE(rv) == NO) + return + + call smark (sp) + call salloc (fn, SZ_FNAME, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Make sure we have an output file. + if (RV_TXFD(rv) == NULL) { + call strcpy ("\0", Memc[fname], SZ_FNAME) + while (Memc[fname] == '\0' && !streq(Memc[fname],"\"\"")) { + call printf ("Root output filename: ") + call flush (STDOUT) + stat = scan() + call gargstr (Memc[fname], SZ_FNAME) + } + if (!streq(Memc[fname],"\"\"")) { + call init_files (rv, DEVICE(rv), Memc[fname], true) + RV_MGP(rv) = gopen ("stdvdm", APPEND, RV_GRFD(rv)) + } + } + + if (!streq(Memc[fname],"\"\"")) { + call sprintf (Memc[fn], SZ_FNAME, "%s.txt") + call pargstr (SPOOL(rv)) + call printf ("Writing current results to `%s'....") + call pargstr (Memc[fn]) + call flush (STDOUT) + + call rv_write (rv, RV_RECORD(rv)) + call rv_eplot (rv, RV_MGP(rv)) + #if (RV_VERBOSE(rv) == YES) + call rv_verbose_fit (rv, RV_VBFD(rv)) + RV_RECORD(rv) = RV_RECORD(rv) + 1 + written = true + RV_UPDATE(rv) = NO + call printf ("Done.\n") + } else + call printf ("Results not saved.\n") + + call flush (STDOUT) + call sfree (sp) +end + + +# CMD_YMAX - Set/show the top of the ccf plot window. + +procedure cmd_ymax (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + RV_Y2(rv) = rval + RV_NEWGRAPH(rv) = YES + } else { + call printf ("Ymax = %f") + call pargr (RV_Y2(rv)) + } +end + + +# CMD_YMIN - Set/show the bottom of the ccf plot window. + +procedure cmd_ymin (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + RV_Y1(rv) = rval + RV_NEWGRAPH(rv) = YES + } else { + call printf ("Ymin = %f") + call pargr (RV_Y1(rv)) + } +end diff --git a/noao/rv/complex.x b/noao/rv/complex.x new file mode 100644 index 00000000..68fb06e2 --- /dev/null +++ b/noao/rv/complex.x @@ -0,0 +1,214 @@ +include <math.h> +include <mach.h> + +# COMPLEX.X - File containing utility routines for complex arithmetic. + +# CX_ADD - Addition of complex numbers. + +procedure cx_add (ar, ai, br, bi, cr, ci) + +real ar, ai #I First number +real br, bi #I Second number +real cr, ci #O Computed value + +begin + cr = ar + br + ci = ai + bi +end + + +# CX_SUB - Subtraction of complex numbers. + +procedure cx_sub (ar, ai, br, bi, cr, ci) + +real ar,ai #I First number +real br,bi #I Second number +real cr,ci #O Computed value + +begin + cr = ar - br + ci = ai - bi +end + + +# CX_MUL - Multiplication of complex numbers. + +procedure cx_mul (ar, ai, br, bi, cr, ci) + +real ar,ai #I First number +real br,bi #I Second number +real cr,ci #O Computed value + +begin + cr = ar*br - ai*bi + ci = ai*br + ar*bi +end + + +# CX_DIV - Division of complex numbers. + +procedure cx_div (ar, ai, br, bi, cr, ci) + +real ar,ai #I First number +real br,bi #I Second number +real cr,ci #O Computed value + +real r, den + +begin + if (br == 0.0 && bi == 0.0) { # Trap divide by zero + cr = 0.0 + ci = 0.0 + return + } + + if (abs(br) >= abs(bi)) { + r = bi / br + den = br + r*bi + cr = (ar + r*ai) / den + ci = (ai - r*ar) / den + } else { + r = br / bi + den = bi + r*br + cr = (ar*r + ai) / den + ci = (ai*r - ar) / den + } +end + + +# CX_ABS - Absolute value of complex numbers. + +real procedure cx_abs (ar, ai) + +real ar, ai #I First number + +real x, y, ans, temp + +begin + x = abs (ar) + y = abs (ai) + if (x == 0.0) + ans = y + else if (y == 0.0) + ans = x + else if (x > y) { + temp = y / x + ans = x * sqrt (1.0 + temp*temp) + } else { + temp = x / y + ans = y * sqrt (1.0 + temp*temp) + } + + return (ans) +end + + +# CX_CONJG - Complex conjugate. + +procedure cx_conjg (ar, ai, br, bi) + +real ar,ai #I First number +real br,bi #I Conjugate + +begin + br = ar + bi = - ai +end + + +# CX_SQRT - Square root of complex numbers. + +procedure cx_sqrt (ar, ai, br, bi) + +real ar, ai #I First number +real br, bi #I Square root + +real x, y, w, r + +begin + if (ar == 0.0 && ai == 0.0) { + br = 0.0 + bi = 0.0 + } else { + x = abs (ar) + y = abs (ai) + if (x >= y) { + r = y / x + w = sqrt (x) * sqrt (0.5*(1.0+sqrt(1.0+r*r))) + } else { + r = x / y + w = sqrt (y) * sqrt (0.5*(1.0+sqrt(1.0+r*r))) + } + if (ar >= 0.0) { + br = w + bi = ai / (2.0*w) + } else { + if (ai >= 0) + bi = w + else + bi = -w + br = ai / (2.0*bi) + } + } +end + + +# CEXP1 - Complex exponentiation routine. + +procedure cexp1 (a, b, dr, di) + +real a #I Real part of argument +real b #I Complex part of argument +real dr, di #O Resultant real/imaginary components + +begin + if (a > log(MAX_REAL)) { + dr = 0.0 + di = 0.0 + } else + call cx_div (cos(b), sin(b), exp(a), 0.0, dr, di) +end + + +# CX_PAK - Pack two real arrays of an FFT into one real FFT array. +# The array `fft' must be dimensioned to at least 2*fnpts elements. + +procedure cx_pak (creal, cimg, fft, fnpts) + +real creal[fnpts], cimg[fnpts] #I Real/Img complex components +real fft[ARB] #O Output 'real' array +int fnpts #I Npts in array + +int i,j + +begin + j = 1 + do i = 1, fnpts { + fft[j] = creal[i] + j = j + 1 + fft[j] = cimg[i] + j = j + 1 + } +end + + +# CX_UNPAK - Unpack one real FFT array into two component real arrays. +# The array `fft' must be dimensioned to at least 2*fnpts elements. + +procedure cx_unpak (fft, creal, cimg, fnpts) + +real fft[ARB] #O Output 'real' array +real creal[fnpts], cimg[fnpts] #I Real/Img complex components +int fnpts #I Npts in array + +int i,j + +begin + j = 1 + do i = 1, fnpts { + creal[i] = fft[j] + j = j + 1 + cimg[i] = fft[j] + j = j + 1 + } +end diff --git a/noao/rv/contin.x b/noao/rv/contin.x new file mode 100644 index 00000000..2b9b4f8a --- /dev/null +++ b/noao/rv/contin.x @@ -0,0 +1,204 @@ +include <pkg/gtools.h> +include <error.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" + +# DO_CONTINUUM - Do a continuum fitting for an given object, template or +# bin spectrum. + +procedure do_continuum (rv, which) + +pointer rv #I RV struct pointer +int which #I Which spectrum to work on? + +pointer sp, fit +int tnum, inum +int continuum() +errchk realloc, continuum + +begin + call smark (sp) # Allocate some temporary space + call salloc (fit, max(RV_RNPTS(rv),RV_NPTS(rv))+10, TY_REAL) + + tnum = RV_TEMPNUM(rv) + inum = RV_IMNUM(rv) + + # Now parse the argument to find out what to do + switch (which) { + case OBJECT_SPECTRUM: # Do object only + if (RV_CONTINUUM(rv) == TEMP_ONLY || RV_CONTINUUM(rv) == NONE) { + call sfree (sp) + return + } + + call realloc (RV_OCONTP(rv), RV_NPTS(rv), TY_REAL) + OBJCONT(rv) = continuum (rv, OBJPIXY(rv,1), RV_NPTS(rv), + OCONT_DATA(rv,1), Memr[fit]) + + case REFER_SPECTRUM: # Do template only + if (RV_CONTINUUM(rv) == OBJ_ONLY || RV_CONTINUUM(rv) == NONE) { + call sfree (sp) + return + } + + call realloc (RV_RCONTP(rv), RV_RNPTS(rv), TY_REAL) + REFCONT(rv) = continuum (rv, REFPIXY(rv,1), RV_RNPTS(rv), + RCONT_DATA(rv,1), Memr[fit]) + } + + call sfree (sp) +end + + +# CONTINUUM - Do the continuum normalization, either interactively or in +# batch mode. + +int procedure continuum (rv, indata, npts, outdata, fit) + +pointer rv #I RV struct pointer +real indata[npts] #I Array to be fit +int npts #I NPTS to fit +real outdata[npts] #O Normalized array +real fit[npts] #O Fit array + +pointer ic # ICFIT ptr +pointer gt_init() + +begin + # Set the ICFIT pointer structure. + if (RV_ICFIT(rv) == NULL) { + call ic_open (ic) + RV_ICFIT(rv) = ic + } + + call ic_pstr (ic, "sample", Memc[CON_SAMPLE(rv)]) + call ic_pstr (ic, "function", Memc[CON_FUNC(rv)]) + call ic_puti (ic, "naverage", CON_NAVERAGE(rv)) + call ic_puti (ic, "order", CON_ORDER(rv)) + call ic_puti (ic, "niterate", CON_NITERATE(rv)) + call ic_putr (ic, "low", CON_LOWREJECT(rv)) + call ic_puti (ic, "markrej", CON_MARKREJ(rv)) + call ic_putr (ic, "high", CON_HIGHREJECT(rv)) + call ic_putr (ic, "grow", CON_GROW(rv)) + call ic_pstr (ic, "ylabel", "") + + if (CON_INTERACTIVE(rv) == YES && RV_INTERACTIVE(rv) == YES) { + if (RV_GT(rv) == NULL) # Initialize GTOOLS if needed + RV_GT(rv) = gt_init() + call gt_sets (RV_GT(rv), GTTYPE, "line") + } + + # Fit the input image. + call cn_fit1d (rv, indata, npts, ic, RV_GT(rv), CON_INTERACTIVE(rv), + outdata, fit) + + call ic_closer (ic) + RV_ICFIT(rv) = NULL + return (YES) +end + + +# CN_FIT1D -- If the interactive flag is set then set the fitting +# parameters interactively. + +procedure cn_fit1d (rv, indata, npts, ic, gt, interactive, outdata, fit) + +pointer rv #I RV struct pointer +real indata[npts] #I Array to be fit +int npts #I NPTS in data array +pointer ic #I ICFIT pointer +pointer gt #I GTOOLS pointer +int interactive #I Interactive? +real outdata[npts] #O Array of normalized data +real fit[npts] #O Array of fit + +int i +pointer cv, sp, x, wts + +begin + # Allocate memory for curve fitting. + call smark (sp) + call salloc (x, npts, TY_REAL) + call salloc (wts, npts, TY_REAL) + + do i = 1, npts # Initlialize X and WTS array + Memr[x+i-1] = real (i) + call amovkr (1., Memr[wts], npts) + + call ic_putr (ic, "xmin", 1.) # Update icfit struct + call ic_putr (ic, "xmax", real(npts)) + + # If the interactive flag is set then use icg_fit to set the + # fitting parameters. Only done if task is run interactively + # as well. + + if (interactive == YES && RV_INTERACTIVE(rv) == YES) { + if (RV_GP(rv) == NULL) + call init_gp (rv, true, "stdgraph") + call gclear (RV_GP(rv)) + + call icg_fit (ic, RV_GP(rv), "cursor", gt, cv, Memr[x], indata, + Memr[wts], npts) + + # Now recover any parameters that were changed + call recover_icfit_pars (rv, ic) + + } else { + # Do the fit non-interactively. + call ic_fit (ic, cv, Memr[x], indata, Memr[wts], npts, YES, YES, + YES, YES) + } + + # Replace rejected points with the fit if requested. + if (CON_REPLACE(rv) == YES) { + call amovr (indata, fit, npts) + call ic_clean (ic, cv, Memr[x], fit, Memr[wts], npts) + call amovr (fit, indata, npts) + } + + # Now subtract the fit. + call cvvector (cv, Memr[x], fit, npts) + call asubr (indata, fit, outdata, npts) + + call cvfree (cv) + call sfree (sp) +end + + +# RECOVER_ICFIT_PARS - Since the ICFIT parameters may have been changed in +# an interactive operation, we need to get the new values from the ICFIT +# structure. + +procedure recover_icfit_pars (rv, ic) + +pointer rv #I RV struct pointer +pointer ic #I ICFIT pointer + +pointer sp, func + +int strdic(), ic_geti() +real ic_getr() + +begin + call smark (sp) + call salloc (func, SZ_FNAME, TY_CHAR) + + CON_NAVERAGE(rv) = ic_geti (ic, "naverage") + CON_ORDER(rv) = ic_geti (ic, "order") + CON_NITERATE(rv) = ic_geti (ic, "niterate") + CON_MARKREJ(rv) = ic_geti (ic, "markrej") + CON_LOWREJECT(rv) = ic_getr (ic, "low") + CON_HIGHREJECT(rv) = ic_getr (ic, "high") + CON_GROW(rv) = ic_getr (ic, "grow") + + call ic_gstr (ic, "sample", Memc[CON_SAMPLE(rv)], SZ_LINE) + call ic_gstr (ic, "function", Memc[func], SZ_LINE) + CON_CNFUNC(rv) = strdic(Memc[func], Memc[func], SZ_LINE, CN_INTERP_MODE) + if (CON_CNFUNC(rv) == 0) { + call sfree (sp) + call error (0, "Unknown fitting function type") + } + + call sfree (sp) +end diff --git a/noao/rv/continpars.par b/noao/rv/continpars.par new file mode 100644 index 00000000..251506c8 --- /dev/null +++ b/noao/rv/continpars.par @@ -0,0 +1,14 @@ +# CONTINPARS - Continuum flattening of data parameter set + +c_interactive,b,h,no,,,"Fit continuum interactively?" +c_sample,s,h,"*",,,"Sample of points to use in fit" +c_function,s,h,"spline3","spline3|legendre|chebyshev|spline1",,"Fitting function + (spline3|legendre|chebyshev|spline1)" +naverage,i,h,1,,,"Number of points in sample averaging" +order,i,h,1,1,,"Order of fitting function" +replace,b,h,no,,,"Replace rejected spectrum w/ fit?" +low_reject,r,h,2.,0.,,"Low rejection in sigma of fit" +high_reject,r,h,2.,0.,,"High rejection in sigma of fit" +niterate,i,h,10,0,,"Number of rejection iterations" +grow,r,h,1.,0.,,"Rejection growing radius" +mode,s,h,"ql" diff --git a/noao/rv/continpars.x b/noao/rv/continpars.x new file mode 100644 index 00000000..3f64de62 --- /dev/null +++ b/noao/rv/continpars.x @@ -0,0 +1,518 @@ +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" +include "rvcont.h" + +.help continpars +.nf ___________________________________________________________________________ +CONTINPARS - Support routines for the 'continpars' named external pset. + + This file include routines for opening/closing the contin structure +as well as command handling. Command handling is limited to changing the +parameter values or resetting them to the default values. Routines included +here are as follows. + + cont_open (rv) + cont_close (rv) + cont_get_pars (rv, sample, func) + cont_parupdate (rv) + cont_unlearn (rv) + cont_show (rv) + cont_colon (rv, cmdstr) + cmd_interactive (rv) + cmd_sample (rv) + cmd_naverage (rv) + cmd_function (rv) + cmd_replace (rv) + cmd_cn_order (rv) + cmd_low_reject (rv) + cmd_high_reject (rv) + cmd_niterate (rv) + cmd_grow (rv) + + The 'cmd_' prefix indicates that the routine is called from a colon +command to either print the current value or set the new value for that +field. Other routines should be self-explanatory + +.endhelp _____________________________________________________________________ + +# Default values for the CONTPARS pset +define DEF_INTERACTIVE NO # Fit continuum interactively? +define DEF_TYPE DIFF # Type of output(fit|diff|ratio) +define DEF_SAMPLE "*" # Sample of points to use in fit +define DEF_NAVERAGE 1 # Npts in sample averaging +define DEF_FUNCTION CN_SPLINE3 # Fitting function +define DEF_ORDER 1 # Order of fitting function +define DEF_REPLACE NO # Replace spec w/ fit? +define DEF_LOW_REJECT 2. # Low rejection in sigma of fit +define DEF_HIGH_REJECT 2. # High rejection in sigma of fit +define DEF_NITERATE 10 # Number of rejection iterations +define DEF_GROW 1. # Rejection growing radius + + +# CONT_OPEN - Open the Process parameters substructure. This is used to +# reduce the size of the already over-burdened main RV struct. + +procedure cont_open (rv) + +pointer rv #I RV struct pointer + +pointer cptr + +begin + iferr (call calloc (cptr, SZ_CONT_STRUCT, TY_STRUCT)) + call error (0, "Error allocating sub-structure RV_CONT.") + + RV_CONT(rv) = cptr + + # Initlialize the values + call calloc (CON_SAMPLE(rv), 2*SZ_LINE, TY_CHAR) + call calloc (CON_FUNC(rv), SZ_FNAME, TY_CHAR) + call cont_get_pars (rv, Memc[CON_SAMPLE(rv)], Memc[CON_FUNC(rv)]) +end + + +# CONT_CLOSE - Close the continpars structure. + +procedure cont_close (rv) + +pointer rv #I RV struct pointer + +begin + call mfree (CON_FUNC(rv), TY_CHAR) + call mfree (CON_SAMPLE(rv), TY_CHAR) + call mfree (RV_CONT(rv), TY_STRUCT) +end + + +# CONT_GET_PARS - Get the continuum fitting parameters from the pset. + +procedure cont_get_pars (rv, sample, func) + +pointer rv #I RV struct pointer +char sample[SZ_FNAME] #U Sample points used +char func[SZ_FNAME] #U Function name for fit + +pointer pp +pointer sp, rbf, bp, bp1, bp2 + +pointer clopset() +int strdic(), clgpseti(), btoi() +real clgpsetr() +bool clgpsetb(), streq() + +begin + # Get continuum parameters. + iferr (pp = clopset("continpars")) + call error (0, "Error opening `continpars' pset") + + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + call salloc (bp1, SZ_LINE, TY_CHAR) + call salloc (bp2, SZ_LINE, TY_CHAR) + call salloc (rbf, SZ_FNAME, TY_CHAR) + + call clgpset (pp, "c_function", func, SZ_LINE) + if (streq(func,"") || streq(func," ")) + call error (0,"Continpars.function specified as empty string.") + + call clgpset (pp, "c_sample", sample, SZ_LINE) + if (streq(sample,"") || streq(sample," ")) + call strcpy ("*", sample, SZ_FNAME) + + CON_ORDER(rv) = clgpseti (pp, "order") + CON_NITERATE(rv) = clgpseti (pp, "niterate") + CON_NAVERAGE(rv) = clgpseti (pp, "naverage") + CON_GROW(rv) = clgpsetr (pp, "grow") + CON_LOWREJECT(rv) = clgpsetr (pp, "low_reject") + CON_HIGHREJECT(rv) = clgpsetr (pp, "high_reject") + CON_INTERACTIVE(rv) = btoi (clgpsetb(pp, "c_interactive")) + CON_REPLACE(rv) = btoi (clgpsetb(pp, "replace")) + + CON_CNFUNC(rv) = strdic (func, func, SZ_LINE, CN_INTERP_MODE) + if (CON_CNFUNC(rv) == 0) + call error (0, "Unknown fitting function type") + + CON_MARKREJ(rv) = YES + + call clcpset (pp) # Close pset + call sfree (sp) +end + + +# CONT_PARUPDATE - Update the pset with the current values of the struct. + +procedure cont_parupdate (rv) + +pointer rv #I RV struct pointer + +pointer sp, b0, b1, b2 +pointer pp, clopset() +bool itob() +errchk clopset + +begin + # Update contin params + iferr (pp = clopset ("continpars")) { + call rv_errmsg ("Error opening `continpars' pset.") + return + } + + call smark (sp) + call salloc (b0, SZ_LINE, TY_CHAR) + call salloc (b1, SZ_LINE, TY_CHAR) + call salloc (b2, SZ_LINE, TY_CHAR) + + call clppseti (pp, "order", CON_ORDER(rv)) + call clppseti (pp, "naverage", CON_NAVERAGE(rv)) + call clppseti (pp, "niterate", CON_NITERATE(rv)) + + call clppsetr (pp, "low_reject", CON_LOWREJECT(rv)) + call clppsetr (pp, "high_reject", CON_HIGHREJECT(rv)) + call clppsetr (pp, "grow", CON_GROW(rv)) + + call clppsetb (pp, "c_interactive", itob(CON_INTERACTIVE(rv))) + call clppsetb (pp, "replace", itob(CON_REPLACE(rv))) + + call nam_cninterp (rv, Memc[b1]) + call clppset (pp, "c_function", Memc[b1]) + + if (CON_SAMPLE(rv) != NULL) + call clppset (pp, "c_sample", Memc[CON_SAMPLE(rv)]) + + call clcpset (pp) + call sfree (sp) +end + + +# CONT_UNLEARN - Unlearn the pset and replace with the default values. + +procedure cont_unlearn (rv) + +pointer rv #I RV struct pointer + +begin + CON_CNFUNC(rv) = DEF_FUNCTION + CON_ORDER(rv) = DEF_ORDER + CON_LOWREJECT(rv) = DEF_LOW_REJECT + CON_HIGHREJECT(rv) = DEF_HIGH_REJECT + CON_NITERATE(rv) = DEF_NITERATE + CON_REPLACE(rv) = DEF_NITERATE + CON_GROW(rv) = DEF_GROW + CON_NAVERAGE(rv) = DEF_NAVERAGE + CON_INTERACTIVE(rv) = DEF_INTERACTIVE + + if (CON_SAMPLE(rv) != NULL) + call strcpy (DEF_SAMPLE, Memc[CON_SAMPLE(rv)], SZ_FNAME) +end + + +# CONT_SHOW - Show the current contin parameters + +procedure cont_show (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I output file descriptor + +pointer sp, str, str1 +bool itob() + +begin + if (fd == NULL) + return + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (str1,SZ_LINE, TY_CHAR) + + call fprintf (fd, "%21tProcesspars PSET Values\n") + call fprintf (fd, "%21t-----------------------\n\n") + + # Print the continpars info + call fprintf (fd, "CONTINUUM parameters:\n") + + call fprintf (fd, "c_interactive%15t= %b\n") + call pargb (itob(CON_INTERACTIVE(rv))) + call fprintf (fd, "c_sample%15t= '%.10s'\n") + call pargstr (Memc[CON_SAMPLE(rv)]) + call fprintf (fd, "naverage%15t= %d\n") + call pargi (CON_NAVERAGE(rv)) + call fprintf (fd, "c_function%15t= '%.10s'\n") + call pargstr (Memc[CON_FUNC(rv)]) + call fprintf (fd, "order%15t= %d\n") + call pargi (CON_ORDER(rv)) + call fprintf (fd, "replace%15t= %d\n") + call pargb (itob(CON_REPLACE(rv))) + call fprintf (fd, "low_reject%15t= %g\n") + call pargr (CON_LOWREJECT(rv)) + call fprintf (fd, "high_reject%15t= %g\n") + call pargr (CON_HIGHREJECT(rv)) + call fprintf (fd, "niterate%15t= %d \n") + call pargi (CON_NITERATE(rv)) + call fprintf (fd, "grow%15t= %g\n") + call pargr (CON_GROW(rv)) + + call fprintf (fd, "\n\n") + call sfree (sp) +end + + +# CONT_COLON -- Process the continpars task colon commands. + +procedure cont_colon (rv, cmdstr) + +pointer rv #I pointer to the RV structure +char cmdstr[SZ_LINE] #I command string + +pointer sp, cmd, buf +int strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, CONT_KEYWORDS)) { + case CNT_INTERACTIVE: + call cmd_interactive (rv) + case CNT_SAMPLE: + call cmd_sample (rv) + case CNT_NAVERAGE: + call cmd_naverage (rv) + case CNT_FUNCTION: + call cmd_cnfunc (rv) + case CNT_CN_ORDER: + call cmd_cn_order (rv) + case CNT_REPLACE: + call cmd_replace (rv) + case CNT_LOW_REJECT: + call cmd_low_reject (rv) + case CNT_HIGH_REJECT: + call cmd_high_reject (rv) + case CNT_NITERATE: + call cmd_niterate (rv) + case CNT_GROW: + call cmd_grow (rv) + default: + call rv_errmsg ("") + } + + call sfree (sp) +end + + +# CMD_INTERACTIVE - Set/Show the interactive continuum subtraction flag. + +procedure cmd_interactive (rv) + +pointer rv #I RV struct pointer + +int nscan(), btoi() +bool bval, itob() + +begin + call gargb (bval) + if (nscan() == 2) { + CON_INTERACTIVE(rv) = btoi (bval) + } else { + call printf ("continpars.c_interactive = %b") + call pargb (itob(CON_INTERACTIVE(rv))) + } +end + + +# CMD_SAMPLE - Set/Show the sample regions for continuum fitting. + +procedure cmd_sample (rv) + +pointer rv + +pointer sp, buf +bool streq() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + if (streq(Memc[buf],"") || streq(Memc[buf]," ")) + call error (0, "continpars.c_sample specified as empty string.") + call strcpy (Memc[buf+1], Memc[CON_SAMPLE(rv)], SZ_LINE) + } else { + call printf ("continpars.c_sample = '%s'") + call pargstr (Memc[CON_SAMPLE(rv)]) + } + + call sfree (sp) +end + + +# CMD_NAVERAGE - Set/Show the number of points to average in the fit. + +procedure cmd_naverage (rv) + +pointer rv #I RV struct pointer + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + CON_NAVERAGE(rv) = ival + } else { + call printf ("continpars.naverage = %d") + call pargi (CON_NAVERAGE(rv)) + } +end + + +# CMD_CNFUNC - Set/Show the fitting function used. + +procedure cmd_cnfunc (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf, bp +int cod_cninterp() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + CON_CNFUNC(rv) = cod_cninterp (Memc[buf+1]) + + } else { + call nam_cninterp (rv, Memc[bp]) + call printf ("continpars.c_function = '%s'") + call pargstr (Memc[bp]) + } + + call sfree (sp) +end + + +# CMD_CN_ORDER - Set/Show the order of the function fit. + +procedure cmd_cn_order (rv) + +pointer rv #I RV struct pointer + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + CON_ORDER(rv) = ival + } else { + call printf ("continpars.order = %d") + call pargi (CON_ORDER(rv)) + } +end + + +# CMD_REPLACE - Set/Show the replace continuum subtraction flag. + +procedure cmd_replace (rv) + +pointer rv #I RV struct pointer + +int nscan(), btoi() +bool bval, itob() + +begin + call gargb (bval) + if (nscan() == 2) { + CON_REPLACE(rv) = btoi (bval) + } else { + call printf ("continpars.replace = %b") + call pargb (itob(CON_REPLACE(rv))) + } +end + + +# CMD_LOW_REJECT - Set/Show the lower sigma rejection limit. + +procedure cmd_low_reject (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + CON_LOWREJECT(rv) = rval + } else { + call printf ("continpars.low_reject = %g") + call pargr (CON_LOWREJECT(rv)) + } +end + + +# CMD_HIGH_REJECT - Set/Show the upper sigma rejection limit. + +procedure cmd_high_reject (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + CON_HIGHREJECT(rv) = rval + } else { + call printf ("continpars.high_reject = %g") + call pargr (CON_HIGHREJECT(rv)) + } +end + + +# CMD_NITERATE - Set/Show the number of iterations in the fit. + +procedure cmd_niterate (rv) + +pointer rv #I RV struct pointer + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + CON_NITERATE(rv) = ival + } else { + call printf ("continpars.niterate = %d") + call pargi (CON_NITERATE(rv)) + } +end + + +# CMD_GROW - Set/Show the rejection growing radius. + +procedure cmd_grow (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + CON_GROW(rv) = rval + } else { + call printf ("continpars.grow = %g") + call pargr (CON_GROW(rv)) + } +end diff --git a/noao/rv/deblend.x b/noao/rv/deblend.x new file mode 100644 index 00000000..ee8c0e8f --- /dev/null +++ b/noao/rv/deblend.x @@ -0,0 +1,776 @@ +include <error.h> +include <mach.h> +include <gset.h> +include "rvpackage.h" +include "rvflags.h" + +# DEBLEND -- Deblend up to 4 lines in a spectral region. + +procedure deblend (rv, gp, x1, x2, dx, wx1, wy1, pix, ans, nans) + +pointer rv #I RV struct pointer +pointer gp #I GIO file descriptor +real x1, x2, dx #I Coordinate scale +real wx1, wy1 #I Cursor position +real pix[ARB] #I Spectrum data +char ans[2*SZ_LINE,4] #O Answer strings +int nans #O Number of answer strings + +int i, j, i1, npts, nlines, maxlines, wc, key, op, stat + +double vobs, vhelio, verr +real w, wxc, wyc, wx, wy, wx2, wy2, a[14], waves[4] +real slope, height, flux, cont, sigma, eqw, scale, chisq +real serr, shift, fwhm +bool fit +pointer sp, cmd, x, y, anti + +int scan(), clgcur(), clgkey(), rv_rvcorrect() +errchk dofit + +include "fitcom.com" +define done_ 99 +define HELP "noao$lib/scr/deblend.key" +define OP "Option (a=0p1s, b=1p1s, c=np1s, d=0pns, e=1pns, f=npns, q=quit):" +define SQ2PI 2.5066283 + +begin + call smark (sp) + call salloc (cmd, SZ_FNAME, TY_CHAR) + + # Input cursor is first continuum point now get second continuum point. + call printf ("d again:") + if (clgcur ("cursor", wx2, wy2, wc, key, Memc[cmd], SZ_FNAME) == EOF) { + call sfree (sp) + return + } + call gctran (gp, wx2, wy2, wx2, wy2, wc, 2) + if (RV_FITDONE(rv) == YES) { + call rv_erase_fit (rv, false) + RV_FITDONE(rv) = NO + IS_DBLSTAR(rv) = NO + } + + # Set pixel indices and determine number of points to fit. + call fixx (wx1, wx2, wy1, wy2, x1, x2) + call pixind (x1, dx, wx1, i1) + call pixind (x1, dx, wx2, j) + npts = j - i1 + 1 + RV_IEND(rv) = j + RV_ISTART(rv) = i1 + if (npts < 3) { + call rv_errmsg ("At least 3 points are required\n") + call sfree (sp) + return + } + + # Allocate space for the points to be fit. + call salloc (x, npts, TY_REAL) + call salloc (y, npts, TY_REAL) + + # Subtract the continuum and scale the data. + wxc = wx1 + wyc = wy1 + slope = (wy2-wy1) / (wx2-wx1) + scale = 0. + do i = 1, npts { + w = x1 + (i1+i-2) * dx + Memr[y+i-1] = pix[i1+i-1] - (wyc + slope * (w-wxc)) + scale = max (scale, abs (Memr[y+i-1])) + Memr[x+i-1] = w + } + call adivkr (Memr[y], scale, Memr[y], npts) + + # Select the lines to be fit. If no lines return. + maxlines = 4 + nlines = 0 + call printf ("Lines ('m' to mark, 't' to type, 'q' to quit):") + while (clgcur ("cursor", wx, wy, wc, key, Memc[cmd], SZ_FNAME) != EOF) { + switch (key) { + case 'm': + call gctran (gp, wx, wy, wx, wy, wc, 2) + case 't': + if (RV_DCFLAG(rv) == -1) { + call printf ("shift: ") + call flush (STDOUT) + if (scan() != EOF) + call gargr (wx) + } else { + call printf ("velocity: ") + call flush (STDOUT) + if (scan() != EOF) + call gargr (wx) + wx = wx / RV_DELTAV(rv) + } + call printf ("Lines ('m' to mark, 't' to type, 'q' to quit):") + case 'q': + call printf ("\n") + break + case 'I': + call fatal (0, "Interrupt") + default: + call printf ( + "Lines ('m' to mark, 't' to type, 'q' to quit):") + next + } + for (i = 1; i <= nlines && wx != waves[i]; i = i + 1) + ; + if (i > nlines) { + nlines = nlines + 1 + waves[nlines] = wx + call gmark (gp, wx, wy, GM_VLINE, 4., 4.) + call gflush (gp) + } + if (nlines == maxlines) { + call printf ("\n") + break + } + } + if (nlines == 0) + goto done_ + + # Do fits. + fit = false + call printf (OP) + while (clgcur ("cursor", wx, wy, wc, op, Memc[cmd], SZ_FNAME) != EOF) { + switch (op) { + case '?': + call gpagefile (gp, HELP, "Rvxcor Deblending Options") + call printf (OP) + next + case 'a', 'b', 'c', 'd', 'e', 'f': + case 'q': + call printf ("\n") + break + case 'I': + call fatal (0, "Interrupt") + default: + call printf ("%s") + call pargstr (OP) + next + } + + # Erase old deblended fit in case we've been here before. Fit is + # erased above from when we first entered. + if (IS_DBLSTAR(rv) == YES) { + call gseti (gp, G_PLTYPE, GL_CLEAR) + call rv_plt_deblend (rv, gp, NO) + call gseti (gp, G_PLTYPE, GL_SOLID) + } + + # Save some variables for later plotting. + DBL_X1(rv) = wx1 + DBL_X2(rv) = wx2 + DBL_Y1(rv) = wy1 + DBL_Y2(rv) = wy2 + DBL_I1(rv) = i1 + DBL_NFITP(rv) = npts + DBL_SCALE(rv) = scale + DBL_SLOPE(rv) = slope + + # Convert line postions to relative to first line. + a[1] = waves[1] + a[2] = 0.25 * abs (Memr[x+npts-1] - Memr[x]) / nlines + do i = 1, nlines { + call pixind (x1, dx, waves[i], j) + a[3*i] = (pix[j] - (wyc + slope * (waves[i]-wxc))) / scale + a[3*i+1] = waves[i] - waves[1] + a[3*i+2] = 1. + } + + switch (op) { + case 'a': + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + next + } + case 'b': + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('b', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + next + } + case 'c': + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('b', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('c', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + next + } + case 'd': + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('d', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + next + } + case 'e': + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('b', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('e', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + next + } + case 'f': + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('b', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('c', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('f', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + next + } + } + fit = true + RV_FITDONE(rv) = YES + DBL_NSHIFTS(rv) = nlines + call amovr (a, DBL_COEFFS(rv,1), 3*nlines+2) + + # Update parameters in the fitting common for the output log + nfit = npts + nfitpars = 3*nlines+2 + binshift = INDEFI + niter = 3 + chisqr = INDEF + ccfvar = INDEF + mresid = INDEF + sresid = INDEF + + # Compute model spectrum with continuum and plot. + IS_DBLSTAR(rv) = YES + call rv_plt_deblend (rv, gp, NO) + + # Print computed values on status line. + i = 1 + key = '' + repeat { + call flush (STDOUT) + switch (key) { + case '-': + i = i - 1 + if (i < 1) + i = nlines + case '+': + i = i + 1 + if (i > nlines) + i = 1 + case 'q': + call printf ("\n") + break + } + + height = scale * a[3*i] + w = a[1] + a[3*i+1] + sigma = abs (a[2]*a[3*i+2]) + flux = sigma * height * SQ2PI + cont = wyc + slope * (w - wxc) + if (cont > 0.) + eqw = abs (flux) / cont + else + eqw = INDEF + + if (key == 'r') { + call printf ("\nrms = %8.4g") + call pargr (scale * sqrt (chisq / npts)) + } else if (key == 'I') { + call fatal (0, "Interrupt") + } else if (key == 'v') { + serr = 0.0 + shift = w + stat = rv_rvcorrect (rv, shift, serr, vobs, vhelio, verr) + call printf ( + "\n%d: shift = %8.4f Vo = %8.3f Vh = %8.3f fwhm = %6.4f") + call pargi (i) + call pargr (shift) + call pargd (vobs) + call pargd (vhelio) + call pargr (2.35482 * sigma * RV_DELTAV(rv)) + } else { + call printf ( + "\n%d: center = %8.6g, flux = %8.4g, eqw = %6.4g, fwhm = %6.4g") + call pargi (i) + call pargr (w) + call pargr (flux) + call pargr (eqw) + call pargr (2.35482 * sigma) + } + + call printf (" (+,-,v,r,q):") + call flush (STDOUT) + } until (clgkey ("ukey", key, Memc[cmd], SZ_FNAME) == EOF) + + # Log computed values + nans = nlines + do i = 1, nlines { + w = a[1] + a[3*i+1] + cont = wyc + slope * (w - wxc) + height = scale * a[3*i] + sigma = abs (a[2]*a[3*i+2]) + flux = sigma * height * SQ2PI + if (cont > 0.) + eqw = abs (flux) / cont + else + eqw = INDEF + + call sprintf (ans[1,i], 2*SZ_LINE, + " %9.7g %9.7g %9.6g %9.4g %9.6g %9.4g %9.4g\n") + call pargr (w) + call pargr (cont) + call pargr (flux) + call pargr (eqw) + call pargr (height) + call pargr (sigma) + call pargr (2.35482 * sigma) + + # Now calculate and save the velocity information + serr = 0.0 + if (RV_DCFLAG(rv) != -1) { + stat = rv_rvcorrect (rv, w, serr, vobs, vhelio, verr) + call salloc (anti, RV_CCFNPTS(rv), TY_REAL) + fwhm = 2.35482 * sigma + call rv_antisym (rv, w, height, fwhm, WRKPIXY(rv,1), + RV_CCFNPTS(rv), Memr[anti], ccfvar, verr, DBL_R(rv,i)) + if (IS_INDEFD(vobs)) + DBL_VOBS(rv,i) = INDEFR + else + DBL_VOBS(rv,i) = real (vobs) + if (IS_INDEFD(vhelio)) + DBL_VHELIO(rv,i) = INDEFR + else + DBL_VHELIO(rv,i) = real (vhelio) + if (IS_INDEFD(verr)) + DBL_VERR(rv,i) = INDEFR + else + DBL_VERR(rv,i) = real (verr) + DBL_FWHM(rv,i) = 2.35482 * sigma * RV_DELTAV(rv) + } else { + DBL_VOBS(rv,i) = INDEFR + DBL_VHELIO(rv,i) = INDEFR + DBL_VERR(rv,i) = INDEFR + DBL_FWHM(rv,i) = 2.35482 * sigma + } + DBL_HEIGHT(rv,i) = height + DBL_SHIFT(rv,i) = w + } + call printf (OP) + } + + +done_ call sfree (sp) +end + + +# SUBBLEND -- Subtract last fit. + +procedure subblend (rv, gp, pix, x1, x2, dx, wx1, wy1) + +pointer rv #I RV struct pointer +pointer gp #I Graphics descriptor +real pix[ARB] #I CCF array +real x1, x2, dx #I Coordinate scale +real wx1, wy1 #I Cursor position + +int i, j, i1, wc, npts, key +real w, wx2, wy2 +pointer sp, cmd + +int clgcur() +real model() + +begin + call smark (sp) + call salloc (cmd, SZ_FNAME, TY_CHAR) + + # Subtract continuum subtracted curve from spectrum + if (RV_FITDONE(rv) == NO) { + call sfree (sp) + return + } + + # Determine fit range + call printf ("- again:") + call flush (STDOUT) + if (clgcur ("cursor", wx2, wy2, wc, key, Memc[cmd], SZ_FNAME) == EOF) { + call sfree (sp) + return + } + + call fixx (wx1, wx2, wy1, wy2, x1, x2) + call pixind (x1, dx, wx1, i1) + call pixind (x1, dx, wx2, j) + npts = j - i1 + 1 + + do i = 1, npts { + w = x1 + (i1+i-2) * dx + pix[i1+i-1] = pix[i1+i-1] - DBL_SCALE(rv) * model (w, + DBL_COEFFS(rv,1), 3*DBL_NSHIFTS(rv)+2) + } + + # Plot subtracted curve + call gvline (gp, pix[i1], npts, wx1, wx2) + call gflush (gp) + + RV_FITDONE(rv) = NO + call sfree (sp) +end + + +# DOFIT -- Perform nonlinear iterative fit for the specified parameters. +# This uses the Levenberg-Marquardt method from NUMERICAL RECIPES. + +procedure dofit (key, x, y, npts, a, nlines, chisq) + +int key #I Fitting option +real x[npts] #I X data +real y[npts] #I Y data +int npts #I Number of points +real a[ARB] #I Fitting parameters +int nlines #I Number of lines +real chisq #O Chi squared + +int i, np, nfit +real mr, chi2 +pointer sp, flags +errchk mr_solve + +begin + # Number of terms is 3 for each line plus common center and sigma. + np = 3 * nlines + 2 + + call smark (sp) + call salloc (flags, np, TY_INT) + + # Peaks are always fit. + switch (key) { + case 'a': # Solve one sigma. + nfit = 1 + nlines + Memi[flags] = 2 + do i = 1, nlines + Memi[flags+i] = 3 * i + case 'b': # Solve one position and one sigma. + nfit = 2 + nlines + Memi[flags] = 1 + Memi[flags+1] = 2 + do i = 1, nlines + Memi[flags+1+i] = 3 * i + case 'c': # Solve independent positions and one sigma. + nfit = 1 + 2 * nlines + Memi[flags] = 2 + do i = 1, nlines { + Memi[flags+2*i-1] = 3 * i + Memi[flags+2*i] = 3 * i + 1 + } + case 'd': # Solve for sigmas. + nfit = 2 * nlines + do i = 1, nlines { + Memi[flags+2*i-2] = 3 * i + Memi[flags+2*i-1] = 3 * i + 2 + } + case 'e': # Solve for one position and sigmas. + nfit = 1 + 2 * nlines + Memi[flags] = 1 + do i = 1, nlines { + Memi[flags+2*i-1] = 3 * i + Memi[flags+2*i] = 3 * i + 2 + } + case 'f': # Solve for positions and sigmas. + nfit = 3 * nlines + do i = 1, nfit + Memi[flags+i-1] = i + 2 + } + + + mr = -1. + i = 0 + chi2 = MAX_REAL + repeat { + call mr_solve (x, y, npts, a, Memi[flags], np, nfit, mr, chisq) + if (chi2 - chisq > 1.) + i = 0 + else + i = i + 1 + chi2 = chisq + } until (i == 3) + + mr = 0. + call mr_solve (x, y, npts, a, Memi[flags], np, nfit, mr, chisq) + + call sfree (sp) +end + + +# MODEL -- Compute model from fitted parameters. +# +# I(x) = I(i) exp {[(x - xc - dx(i)) / (sig sig(i))] ** 2 / 2.} +# +# where the parameters are xc, sig, I(i), dx(i), and sig(i) (i=1,nlines). + +real procedure model (x, a, na) + +real x #I X value to be evaluated +real a[na] #I Parameters +int na #I Number of parameters + +int i +real y, arg + +begin + y = 0. + do i = 3, na, 3 { + arg = (x - a[1] - a[i+1]) / (a[2] * a[i+2]) + if (abs (arg) < 7.) + y = y + a[i] * exp (-arg**2 / 2.) + } + return (y) +end + + +# DERIVS -- Compute model and derivatives for MR_SOLVE procedure. +# +# I(x) = I(i) exp {[(x - xc - dx(i)) / (sig sig(i))] ** 2 / 2.} +# +# where the parameters are xc, sig, I(i), dx(i), and sig(i) (i=1,nlines). + +procedure derivs (x, a, y, dyda, na) + +real x #I X value to be evaluated +real a[na] #I Parameters +real y #O Function value +real dyda[na] #O Derivatives +int na #I Number of parameters + +int i +real sig, arg, ex, fac + +begin + y = 0. + dyda[1] = 0. + dyda[2] = 0. + do i = 3, na, 3 { + sig = a[2] * a[i+2] + arg = (x - a[1] - a[i+1]) / sig + if (abs (arg) < 7.) + ex = exp (-arg**2 / 2.) + else + ex = 0. + fac = a[i] * ex * arg + + y = y + a[i] * ex + dyda[1] = dyda[1] + fac / sig + dyda[2] = dyda[2] + fac * arg / a[2] + dyda[i] = ex + dyda[i+1] = fac / sig + dyda[i+2] = fac * arg / a[i+2] + } +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] #I X data array +real y[npts] #I Y data array +int npts #I Number of data points +real params[np] #U Parameter array +int flags[np] #I Flag array indexing parameters to fit +int np #I Number of parameters +int nfit #I Number of parameters to fit +real mr #O MR parameter +real chisq #O Chi square of fit + +int i +real chisq1 +pointer new, a1, a2, delta1, delta2 + +errchk mr_invert + +begin + # Allocate memory and initialize. + if (mr < 0.) { + call mfree (new, TY_REAL) + call mfree (a1, TY_REAL) + call mfree (a2, TY_REAL) + call mfree (delta1, TY_REAL) + call mfree (delta2, TY_REAL) + + call malloc (new, np, TY_REAL) + call malloc (a1, nfit*nfit, TY_REAL) + call malloc (a2, nfit*nfit, TY_REAL) + call malloc (delta1, nfit, TY_REAL) + call malloc (delta2, nfit, TY_REAL) + + call amovr (params, Memr[new], np) + call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a2], + Memr[delta2], nfit, chisq) + mr = 0.001 + } + + # Restore last good fit and apply the Marquardt parameter. + call amovr (Memr[a2], Memr[a1], nfit * nfit) + call amovr (Memr[delta2], Memr[delta1], nfit) + do i = 1, nfit + Memr[a1+(i-1)*(nfit+1)] = Memr[a2+(i-1)*(nfit+1)] * (1. + mr) + + # Matrix solution. + call mr_invert (Memr[a1], Memr[delta1], nfit) + + # Compute the new values and curvature matrix. + do i = 1, nfit + Memr[new+flags[i]-1] = params[flags[i]] + Memr[delta1+i-1] + call mr_eval (x, y, npts, Memr[new], flags, np, Memr[a1], + Memr[delta1], nfit, chisq1) + + # Check if chisq has improved. + if (chisq1 < chisq) { + mr = 0.1 * mr + chisq = chisq1 + call amovr (Memr[a1], Memr[a2], nfit * nfit) + call amovr (Memr[delta1], Memr[delta2], nfit) + call amovr (Memr[new], params, np) + } else + mr = 10. * mr + + if (mr == 0.) { + call mfree (new, TY_REAL) + call mfree (a1, TY_REAL) + call mfree (a2, TY_REAL) + call mfree (delta1, TY_REAL) + call mfree (delta2, TY_REAL) + } +end + + +# MR_EVAL -- Evaluate curvature matrix. This calls procedure DERIVS. + +procedure mr_eval (x, y, npts, params, flags, np, a, delta, nfit, chisq) + +real x[npts] #I X data array +real y[npts] #I Y data array +int npts #I Number of data points +real params[np] #I Parameter array +int flags[np] #I Flag array indexing parameters to fit +int np #I Number of parameters +real a[nfit,nfit] #U Curvature matrix +real delta[nfit] #U Delta array +int nfit #I Number of parameters to fit +real chisq #U 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] #I Input matrix and returned inverse +real b[n] #U Input RHS vector and returned solution +int n #I Dimension of input matrices + +int krank +real rnorm +pointer sp, h, g, ip + +begin + call smark (sp) + call salloc (h, n, TY_REAL) + call salloc (g, n, TY_REAL) + call salloc (ip, n, TY_INT) + + call hfti (a, n, n, n, b, n, 1, 0.001, krank, rnorm, + Memr[h], Memr[g], Memi[ip]) + + call sfree (sp) +end + + +# FIXX - Check for bounds on x's. + +procedure fixx (eqx1, eqx2, eqy1, eqy2, x1, x2) + +real eqx1, eqx2, eqy1, eqy2, x1, x2 + +real temp + +begin + if ((x1 - x2) * (eqx1 - eqx2) < 0.) { + temp = eqx2 + eqx2 = eqx1 + eqx1 = temp + + temp = eqy2 + eqy2 = eqy1 + eqy1 = temp + } + + eqx1 = max (min (x1, x2), min (max (x1, x2), eqx1)) + eqx2 = max (min (x1, x2), min (max (x1, x2), eqx2)) +end + + +# PIXIND -- Compute pixel index. + +procedure pixind (x1, dx, valx, i1) + +real x1, dx, valx +int i1 + +begin +# i1 = aint ((valx-x1)/dx +0.5) + 1 + i1 = (valx - x1) / dx + 1.5 +end diff --git a/noao/rv/doc/continpars.hlp b/noao/rv/doc/continpars.hlp new file mode 100644 index 00000000..17f9badf --- /dev/null +++ b/noao/rv/doc/continpars.hlp @@ -0,0 +1,129 @@ +.help continpars Jan92 noao.rv +.ih +NAME +continpars -- edit the continuum subtraction parameters +.ih +USAGE +continpars +.ih +PARAMETERS +.ls c_sample = "*" +Lines or columns to be used in the fits. The default value ("*") selects +all pixels. Type \fIhelp ranges\fR for a complete description of the +syntax. +.le +.ls c_function = "spline3" +Continuum function to be fit to the image lines or columns. The functions are +"legendre" (Legendre polynomial), "chebyshev" (Chebyshev polynomial), +"spline1" (linear spline), and "spline3" (cubic spline). The functions +may be abbreviated. +.le +.ls c_interactive = "no" +Interactively fit the continuum? If set to yes, each spectrum will be fit +interactively as they are read into the task if the \fIfxcor.continuum\fR +parameter requires it. The \fIfxcor\fR keystroke commands 'o' and 't' will +automatically fit the continuum interactively. +.le +.ls naverage = 1 +Number of sample points to combined to create a fitting point. +A positive value specifies an average and a negative value specifies +a median. +.le +.ls order = 1 +The order of the polynomials or the number of spline pieces. +.le +.ls replace = no +Replace rejected data points with continuum fit points prior to the +subtraction? If set to yes, points lying outside the \fIlow_reject\fR or +\fIhigh_reject\fR limits are replaced by the fit values prior to the +continuum subtraction. This can be useful in removing emission features +or cosmic ray events, but great care must be taken in setting other parameters +in order to get satisfactory results. Adjusting the \fIgrow\fR or +\fIaverage\fR parameters, and using a low order function usually provide +a good result. +.le +.ls low_reject = 2., high_reject = 2. +Rejection limits below and above the fit in units of the residual sigma. +.le +.ls niterate = 1 +Number of rejection iterations. +.le +.ls grow = 1. +When a pixel is rejected, pixels within this distance of the rejected pixel +are also rejected. +.le + +.ih +DESCRIPTION +The \fIcontinpars\fR pset is used to control the continuum subtraction from +the data. When the \fIfxcor\fR task is run in a batch mode, +the parameters are used to +automatically process the data without intervention from the user. In an +interactive session, the user may experiment with different parameter values by +changing them with the allowed colon commands. + +Continuum subtraction is done exactly as with the \fIonedspec.continuum\fR +task. (Details of the operation are described in the \fIcontinuum\fR +documentation.) The fit to the spectra is subtracted from the data, thus +producing a continuum subtracted spectrum suitable for input to the correlation +routines. + +Users who require the full ability of the \fIonedspec.continuum\fR task to +supply another form of output spectrum, such as the ratio of the fit, or +who wish to make use of the "clean" option, should use that task and disable +continuum subtraction in the \fIrv\fR package tasks. More functionality is +planned for this pset in the future. + +.ih +TASK COLON COMMANDS +The values of the \fIcontinpars\fR pset may be changed, displayed, or updated +from within tasks that use them by means of various colon commands. Simply +typing the parameter name will have the default action of printing the current +value of that parameter. +.ls :unlearn continpars +Reset the continpars pset parameters with their default values. +The argument "continpars" must be present or else the command will default +to the \fIfxcor\fR task command. +.le +.ls :update continpars +Update the continpars pset parameters with the current values. +The argument "continpars" must be present or else the command will default +to the \fIfxcor\fR task command. +.le +.ls :show continpars +Show the current values of the continpars pset parameters. +The argument "continpars" must be present or else the command will default +to the \fIfxcor\fR task command. +.le + +The following parameters will be displayed if it's name it typed, and a new +value accepted if an argument is given. + +.nf +:c_sample [range_string] +:naverage [int_value] +:c_function [spline3|legendre|chebyshev|spline1] +:order [int_value] +:low_reject [int_value] +:high_reject [int_value] +:niterate [int_value] +:grow [int_value] +.fi + +.ih +EXAMPLES +1. List the continuum parameters. + +.nf + rv> lpar continpars +.fi + +2. Edit the continuum parameters + +.nf + rv> continpars +.fi +.ih +SEE ALSO +fxcor, onedspec.continuum, icfit, sfit +.endhelp diff --git a/noao/rv/doc/filtpars.hlp b/noao/rv/doc/filtpars.hlp new file mode 100644 index 00000000..596970ee --- /dev/null +++ b/noao/rv/doc/filtpars.hlp @@ -0,0 +1,167 @@ +.help filtpars Jan91 noao.rv +.ih +NAME +filtpars -- edit the filter function parameters +.ih +USAGE +filtpars +.ih +PARAMETERS +.ls f_type = "ramp" +Type of filter to be used. Possible choices are +.ls ramp +A ramp function which begins to rise at the \fIcuton\fR wavenumber and +reaches full value (i.e. passes the full value of the component) at the +\fIfullon\fR wavenumber. It begin to decline at the \fIcutoff\fR wavenumber +and returns to zero at the \fIfulloff\fR wavenumber. +.le +.ls Hanning +A Hanning function is used to attenuate the fourier components over the +range specified by the \fIcuton\fR and \fIcutoff\fR parameters. +.le +.ls Welch +A Welch function is used to attenuate the fourier components over the range +specified by the \fIcuton\fR and \fIcutoff\fR parameters. +.le +.ls Square +A standard step function which is zero outside the \fIcuton\fR and +\fIcutoff\fR component numbers and one within those numbers. +.le +.le +.ls cuton = 0 +The fourier wavenumber at which the filter begins to pass the filtered fft +component. +.le +.ls cutoff = 0 +The fourier wavenumber at which the filter ceases to pass fft components. +.le +.ls fullon = 0 +Used only for a 'ramp' filter. The fourier wavenumber at which the filter +reaches full value and passes all of the data. +.le +.ls fulloff = 0 +Used only for a 'ramp' filter. The fourier wavenumber at which the filter +reaches zero value and passes none of the data. +.le +.ih +DESCRIPTION +The filtering parameters control the type of filter to be used +on the Fourier transformed data as well as the range in wavenumbers over +which it will operate. Filtering of the data may be necessary to remove +high frequency noise or low-frequency tends not removed by continuum +subtraction. If the filtering is enabled, then once the data have been +transformed, a bandpass filter of the type chosen by the +\fIf_type\fR parameter is applied to the Fourier components of the +spectra. Wavenumbers lower than that specified by the \fIcuton\fR parameter +are set to zero and wavenumbers up to that specified by the \fIcutoff\fR +parameter (or the \fIfulloff\fR parameter in the case of a 'ramp' filter) +are attenuated or passed in full according to the filter chosen. +Since the data are assumed to be linearized in log-wavelength space, applying +a filter to the data in Fourier space introduces no phase shift and has +the same effect as smoothing the data in real space. The data are centered +and zero padded in an array of length 2**N such that the number of elements +is greater than or equal to the number of actual data points. This array in +then Fourier transformed, and the resulting fft is then filtered prior +to correlation. + +Filtering is enabled by turning on the \fIfxcor.filter\fR parameter and setting +it to something other than "none". Filtering may be done on only one of the +two spectra or both prior to correlation. + +The filter choices behave as follows: +.ls Square Filter +The fourier components at wavenumbers between the \fIcuton\fR and \fIcutoff\fR +wavenumbers are passed without change. Those wavenumbers outside this region +are set to zero. +.le +.ls Ramp Filter +Fourier components below the \fIcuton\fR and above the \fIfulloff\fR +wavenumbers are set to zero. +At the \fIcuton\fR wavenumber the filter function +begins to rise until the \fIfullon\fR wavenumber is reached. Data in this +region is weighted by the slope of the filter until at the \fIfullon\fR +wavenumber data are passed through without change. Similarly, the filter +begins to fall at the \fIcutoff\fR wavenumber until it completely blocks +(i.e. zeros) the fourier components at the \fIfulloff\fR wavenumber. +.le +.ls Welch Filter +Fourier components below the \fIcuton\fR and above the \fIcutoff\fR +wavenumbers are set to zero. Components between these regions are weighted +according to the equation for a Welch window. Namely, +.nf + + 2 + w(j) = 1. - [ (j - 1/2(N-1)) / (1/2(N+1)) ] + + where j = (wavenumber - cuton_wavenumber) + N = (cutoff - cuton) + 1 +.fi +.le +.ls Hanning Filter +Fourier components below the \fIcuton\fR and above the \fIcutoff\fR +wavenumbers are set to zero. Components between these regions are weighted +according to the equation for a Hanning window. Namely, +.nf + + w(j) = 1/2 [ 1. - cos( (TWOPI*j) / (N-1) ) ] + + where j = (wavenumber - cuton_wavenumber) + N = (cutoff - cuton) + 1 +.fi +.le + +.ih +TASK COLON COMMANDS +The values of the \fIfiltpars\fR pset may be changed, displayed, or updated +from within the Fourier mode of the \fIfxcor\fR task. Simply +typing the parameter name will have the default action of printing the current +value of that parameter. An optional value may be added to change the named +parameter. +.ls :update filtpars +Update the pset with the current values of the filter parameters. +The argument "filtpars" must be present or else the command will default +to the task parameters. +.le +.ls :unlearn filtpars +Reset the parameter values to their defaults. +The argument "filtpars" must be present or else the command will default +to the task parameters. +.le +.ls :show filtpars +Clear the screen and display all values in the filtpars pset. +The argument "filtpars" must be present or else the command will default +to the task default. +.le +.ls :filttype [ramp|welch|hanning|square|none] +Set or show the current value of the filter type to use +.le +.ls :cuton [int_value] +Set or show the current value of the cuton fourier component +.le +.ls :cutoff [int_value] +Set or show the current value of the cutoff fourier component +.le +.ls :fullon [int_value] +Set or show the current value of the fullon fourier component +.le +.ls :fulloff [int_value] +Set or show the current value of the fulloff fourier component +.le + +.ih +EXAMPLES +1. List the filtering parameters. + +.nf + rv> lpar filtpars +.fi + +2. Edit the filtering parameters + +.nf + rv> filtpars +.fi +.ih +SEE ALSO +fxcor +.endhelp diff --git a/noao/rv/doc/fxcor.hlp b/noao/rv/doc/fxcor.hlp new file mode 100644 index 00000000..7f253a3b --- /dev/null +++ b/noao/rv/doc/fxcor.hlp @@ -0,0 +1,1143 @@ +.help fxcor Mar93 noao.rv +.ih +NAME +fxcor -- compute radial velocities via Fourier cross correlation +.ih +USAGE +fxcor objects templates +.ih +PARAMETERS +.ce +INPUT PARAMETERS +.ls objects +The list of image names for the input object spectra. +.le +.ls templates +The list of image names that will be used as templates for the cross +correlation. This list need not match the object list. All pairs +between the two lists will be correlated. +.le +.ls apertures = "*" +List of apertures to be correlated in echelle and multispec format spectra. +This parameter is used for \fIboth\fR the object and reference spectra if both +spectra are two dimensional, otherwise the aperture list applies to the object +only if the template is one-dimensional. Individual apertures from a +two-dimensional template may be +extracted to 1-D using the \fIonedspec.scopy\fR task, and these new images may +then be used in the template list as separate images. (See the examples for +how this may be done). The default of '*' means to process all of the +apertures in the spectrum. Note that the sample regions named by the +\fIosample\fR and \fIrsample\fR parameters will apply to all apertures. +.le +.ls cursor = "" +Graphics cursor input. +.le + +.ce +DATA PREPARATION PARAMETERS +.ls continuum = "both" +Continuum subtract the spectra prior to correlation? Possible values for +this parameter are any of the strings (or abbreviations) "object" (for object +spectrum only), "template" (for template spectrum only), "both" for +continuum flattening both object and template spectra, or "none" for +flattening neither spectrum. The \fIcontinpars\fR pset is used to specify +the continuum fitting parameters. +.le +.ls filter = "none" +Fourier filter the spectra prior to correlation? Possible values for +this parameter are any of the strings (or abbreviations) "object" (for object +spectrum only), "template" (for template spectrum only), "both" for +fourier filtering both object and template spectra, or "none" for +filtering neither spectrum. The \fIfiltpars\fR pset holds the parameters +for the filtering (filter type and width). +.le +.ls rebin = "smallest" +Rebin to which spectrum dispersion? If the input dispersions are not equal +prior to the correlation, +one of the two spectra in the pair will be rebinned according to the +\fIrebin\fR parameter. Possible values are "smallest" (to rebin to the +smaller of the two values), "largest" (to rebin to the larger of the two +values), "object" (to force the template to always be rebinned to the object +dispersion), and "template" (to force the object to always be rebinned to the +template dispersion). Input spectra \fImust be\fR linearly corrected. +Support for non-linear input dispersions is not included in this release. +.le +.ls pixcorr = "no" +Do a pixel-only correlation, ignoring any dispersion information? If this +parameter is set to \fIyes\fR, then regardless of whether dispersion +information is present in the image headers, the correlation will be done +without rebinning the data to a log-linear dispersion. This option is useful +when pixel shifts, not velocities, are the desired output. +.le +.ls osample = "*" +Sample regions of the object spectrum to be used in the correlation specified +in pixels if the first character is a 'p', or angstroms if the first +character is an 'a'. The default (i.e. no 'a' or 'p' as the first +character) if a range is provided, is a range specified in angstroms. +This string value will be updated in an interactive session as sample +regions are re-selected in spectrum mode. The default, '*', is the entire +spectrum. The region is specified as a starting value, a '-', and an ending +value. If the specified range is out of bounds, the endpoints will be +modified to the nearest boundary, or else the entire spectrum will be +correlated if the whole range is out of bounds. +.le +.ls rsample = "*" +Sample regions of the template spectrum to be used in the correlation specified +in pixels if the first character is a 'p', or angstroms if the first +character is an 'a'. The default (i.e. no 'a' or 'p' as the first +character) if a range is provided, is a range specified in angstroms. +This string value will be updated in an interactive session as sample +regions are re-selected in spectrum mode. The default, '*', is the entire +spectrum. The region is specified as a starting value, a '-', and an ending +value. If the specified range is out of bounds, the endpoints will be +modified to the nearest boundary, or else the entire spectrum will be +correlated if the whole range is out of bounds. +.le +.ls apodize = 0.2 +Fraction of endpoints to apodize with a cosine bell when preparing the data +prior to the FFT. +.le + +.ce +CORRELATION PEAK FITTING PARAMETERS +.ls function = "gaussian" +Function used to find the center and width of the correlation peak. +Possible choices are "gaussian", "parabola", "lorentzian", "center1d", +or "sinc". If a center1d fit is selected, then only the center is determined. +A "sinc" function uses a sinc interpolator to find the maximum of the +peak by interpolating the points selectes. The FWHM calculation in this +case is computed empirically by finding the half power point according +to the computed peak height and the \fIbackground\fR level. No FWHM +will be computed of the background is not set. The function fitting options +all compute the FWHM from the fitted coefficients of the function. +.le +.ls width = INDEF +Width of the fitting region in pixels. The fitting weights are +zero at the endpoints so the width should be something +like the expected full width. If INDEF, then the width is +set by the \fIheight\fR and \fIpeak\fR parameters. If other than INDEF, +this parameter will override the \fIheight\fR and \fIpeak\fR parameters. +.le +.ls height = 0. +The width of the fitting region is defined by where the correlation +function crosses this height starting from the peak. The height is +specified as either a normalized correlation level (this is like +the 'y' interactive key) or normalized to the peak. The type of +level is selected by the \fIpeak\fR parameter. +.le +.ls peak = no +Measure the height parameter relative to the correlation peak value +rather than as a normalized correlation level? If yes, then \fIheight\fR +is a fraction of the peak height with an assumed base of zero. +.le +.ls minwidth = 3., maxwidth = 21. +The minimum and maximum widths allowed when the width is determined +from the height. +.le +.ls weights = 1. +Power of distance defining the fitting weights. The points used +in fitting the correlation peak are weighted by a power of the +distance from the center as given by the equation +.nf + + weight = 1 - (distance / (width/2)) ** \fIweights\fR + +.fi +Note that a weight parameter of zero is equivalent to uniform weights. +The center1d fitting algorithm uses it's own weighting function. +.le +.ls background = 0.0 +Background level, in normalized correlation units, for a Gaussian or +Lorentzian fitting function. If set to INDEF, the background is a free +parameter in the fit. +.le +.ls window = INDEF +Size of the window in the correlation plot. The peak will be displayed +with a window centered on the peak maximum and two times \fIwindow\fR +pixels wide if no dispersion information is present in the image header. +If dispersion information is present, \fIwindow\fR is specified in Km/s. +A value of INDEF results in a default window size of 20 pixels. If the +window proves to be too small for the number of points to be fit selected +with the \fIwidth\fR, \fIheight\fR, and/or \fIpeak\fR parameters, a message +will be written to the ".log" file and/or screen explaining that points +outside the window bounds were used in the fit. The user may wish to +review this fit or increase the window size. +.le +.ls wincenter = INDEF +Center of the peak search window specified in pixel lags if no dispersion +information is present, or specified in Km/s if dispersion information is +present. If set to the default INDEF, the maximum peak in the cross-correlation +function will be fit by default. If set to other than INDEF, the maximum peak +within a window centered on \fIwincenter\fR and two times \fIwindow\fR +lags wide will be used. Note that this parameter can be used to constrain +the velocities computed to a certain range in non-interactive mode. +.le + +.ce +OUTPUT PARAMETERS +.ls output = "" +Name of the file to which output will be written. If no file name is given +then no log files will be kept, but the user will be queried for a file name +if a write operation is performed. Tabular text output will have a ".txt" +suffix appended to the \fIoutput\fR name, a verbose description of each fit +will have ".log" suffix appended and will be written only if the \fIverbose\fR +parameter is set, and the graphics metacode file will be appended with +a ".gki" suffix. (NOTE: Image names will be truncated to 10 characters in the +output file because of space considerations. Verbose output logs will +truncate the image names to 24 characters. Object names are similarly +truncated to 15 characters. If a relative velocity is calculated with a +redshift of more than 0.2, output will be redshift z values rather than +velocities in Km/s.) +.le +.ls verbose = "long" +Set level of verbosity and types of files to create. The \fIverbose\fR +parameter is an enumerated string whose values determine the number and type +of output files created. Up to three files are created: the ".txt", ".log", +and ".gki" files (see the description for the \fIoutput\fR parameter). +Possible values for \fIverbose\fR and the files created are as follows: +.nf + + Value: Files Created: + + short (an 80-char .txt file and a .gki file) + long (a 125-char .txt file, a .log file, a .gki file) + nolog (a 125-char .txt file and a .gki file) + nogki (a 125-char .txt file and a .log file) + txtonly (a 125-char .txt file) + stxtonly (an 80-char .txt file) + +.fi +The \fIfields\fR task +may be used to strip out selected columns from the .txt files. The 125-char +.txt output +may be printed without wrapping the lines either in landscape mode for +a laser printer, or on a 132 column lineprinter. +.le +.ls imupdate = "no" +Update the image header with the computed velocities? If set to yes, then +the image will be updated with the observed and heliocentric velocities +by adding the \fIkeywpars.vobs\fR and \fIkeywpars.vhelio\fR keywords +respectively. Two-dimensional spectra cannot be updated. Additional keywords +defined in the \fIkeywpars\fR pset will also be updated. +.le +.ls graphics = "stdgraph" +Output graphics device. +.le + +.ce +CONTROL PARAMETERS +.ls interactive = "yes" +Process the spectra interactively? +.le +.ls autowrite = "yes" +Automatically record the last fit to the log file when moving to the +next/previous spectrum or quitting? If set to "no", the user will be +queried whether to write the results if no write was performed, and +possibly queried for a file name if \fIoutput\fR isn't set. +.le +.ls autodraw = "yes" +Automatically redraw the new fit after it changes. If set to the default +"yes" then the old fit is erased and a new one computed and drawn after +the 'g', 'y', 'd', or 'b' keystrokes. If set to "no", then old fits are not +erased and the user must redraw the screen with an 'r' keystroke. +.le +.ls ccftype = "image" +Type of output to create when writing out the correlation function with +the ":wccf file" command. Possible choices are "text" which will be a +simple list of (lag,correlation_value) pairs, or "image" which will be an +IRAF image whose header would describe the lag limits and selected peak. +.le + +.ce +ADDITIONAL PARAMETER SETS +.ls observatory = "kpno" +The location of the observations, as defined by the \fInoao.observatory\fR +task. The image header keyword OBSERVAT will override this parameter, thus +allowing for images which were taken at another observatory to be properly +corrected. These values are used in the heliocentric correction routines. +.le +.ls continpars = "" +The continuum subtraction parameters as described in the \fIcontinpars\fR +named pset. +.le +.ls filtpars = "" +The parameter set defining the parameters to be used in filtering the +data prior to the correlation. +.le +.ls keywpars = "" +The image header keyword translation table as described in +the \fIkeywpars\fR named pset. +.le + +.ce +RV PACKAGE PARAMETERS +.ls dispaxis = 1, nsum = 1 +Parameters for defining vectors in 2D images. The +dispersion axis is 1 for line vectors and 2 for column vectors. +A DISPAXIS parameter in the image header has precedence over the +\fIdispaxis\fR parameter. +.le +.ls z_threshold = 0.2 +Redshift value at which the output logs switch from printing velocities in +units of Km/s to redshift z values. +.le +.ls tolerance = 1.0e-5 +Fitting tolerance for Least Squares fitting. +.le +.ls maxiters = 100 +Maximum number of iterations for Least Squares fitting or any other iterative +algorithm. +.le +.ls interp = "poly5" +Interpolator used when rebinning the data to a log-linear dispersion. See +the section on interpolation for more information. Possible choices are +"nearest", "linear", "poly3", "poly5", "spline3", and "sinc". +.le +.ls line_color = 1 +Color index of overlay plotting vectors. This parameter has no effect on +devices which do not support color vectors. +.le +.ls text_color = 1 +Color index of plot text annotation. This parameter has no effect on +devices which do not support color vectors. +.le +.ls observatory = "observatory" +Observatory at which the spectra were obtained if not specified in the +image header by the keyword OBSERVAT. This parameter is used by several +tasks in the package through parameter redirection so this parameter may be +used to affect all these tasks at the same time. The observatory may be +one of the observatories in the observatory database, "observatory" to +select the observatory defined by the environment variable "observatory" or +the parameter \fBobservatory.observatory\fR, or "obspars" to select the +current parameters set in the \fBobservatory\fR task. See help for +\fBobservatory\fR for additional information. +.le + +.ih +DESCRIPTION +\fIFxcor\fR performs a Fourier cross-correlation on the input list of object +and template spectra. Object spectra may be either one or two dimensional +(in `echelle' or `multispec' format), and may be correlated against a one +or two dimensional template. If the template spectrum is only one dimensional +but the object is two dimensional, the template is used to correlate each of +the apertures specified by the \fIapertures\fR parameter in the object +spectrum. Two dimensional templates will correlate corresponding apertures. + +If the input spectra are not dispersion corrected (DC-FLAG parameter missing +or less than zero), or the \fIpixcorr\fR parameter is turned on, then only +a pixel space correlation is done. This is +appropriate for a simple cross-correlation of images whether spectra or not. +If the spectra are dispersion corrected, a log binned correlation is +performed and various radial velocity measurements are made. At a minimum, +a relative velocity between the object and template spectra is produced. +If the image headers contain sufficient information for heliocentric +velocity corrections (see help for \fBkeywpars\fR), the corrections are +computed and possibly recorded in the image header (see below for a full +explanation of the computed velocities). If the value of the +heliocentric velocity is returned as INDEF, the user may use the 'v' +keystroke to see the full results of the correlation, including errors +which occured causing the corrections to not be done. + +A number of operations may be performed to prepare the data for +correlation. If a linear wavelength dispersion is defined, the spectra are +rebinned to a log-linear dispersion using the interpolant set by the package +parameter \fIinterp\fR (See the section on interpolation for details). +At this time only linear input dispersions are supported for rebinning. +The starting and ending wavelength for +both spectra will remain the same, but the dispersion in log space will be +determined from the \fIrebin\fR parameter if the input disersions aren't +equal, or from the spectrum's endpoints and number of pixels if they are +equal. For example, assuming \fIrebin\fR is set to "smallest", if object +one and the template have the same input log dispersion of 0.5e-4 A/pix the +data will not be rebinned. Object two with a wpc of 0.4e-4 A/pix will force +the template to be rebinned to a common wpc of 0.4e-4 A/pix. If the third +object on the list then has a dispersion of 0.3e-4 A/pix, the template will +again be rebinned from the original 0.5e-4 A/pix dispersion to a new 0.3e-4 +A/pix dispersion. If object three and the template are the same star, the +template spectrum will suffer from interpolation errors that should be +considered when analyzing the results. The output .txt file will update +every time the common dispersion is changed. The suggested course of action +is to bin all spectra to the same dispersion, preferably a log-linear one, +prior to executing this package. + +If the \fIcontinuum\fR flag is set to something other than +"none", the object and/or template data will +be continuum subtracted using the fitting parameters found in the +\fIcontinpars\fR pset on input. The data are zeroed outside the sample +region specified by the \fIosample\fR and \fIrsample\fR parameters, +the ends of each region are apodized, and the bias is then subtracted. +If the \fIfilter\fR flag is set to something other than +"none", the data are Fourier filtered according to the parameters in +the \fIfiltpars\fR pset prior to the correlation computation. + +Once the correlation is computed, the maximum peak within the window +specified by the \fIwincenter\fR and \fIwindow\fR parameters is found and +fit according to the \fIwidth\fR or \fIheight\fR and \fIpeak\fR parameters. +A small, unlabeled plot of the entire cross correlation function (hereafter +CCF) is drawn above a larger, expanded plot centered on the peak in a window +of size specified by the \fIwindow\fR parameter. The dashed lines in the +small plot show the limits of the expanded plot. The bottom axis of the +expanded plot is labeled with pixel lag and, if dispersion information is +present, the top axis is labeled with relative velocity. To choose a +different peak to fit, move the cursor to the top plot of the whole ccf and +hit the 'z' keystroke at the desired peak. The plot will be redrawn with +the new peak now centered in the window and a fit automatically done. The +status line will contain a summary of the pixel shift from the fit and +optional velocity information. The 'v' keystroke may be used to suspend +graphics and get a more detailed description of the correlation and fit, and +the '+' keystroke will toggle the status line output. To view the +antisymmetric noise component of the correlation function, simply hit the +'a' keystroke followed by any keystroke to return to the correlation plot. +Similarly, the 'e' keystroke may be used to preview the summary plot of the +correlation, again hitting any key to return to the correlation. An +overplot of the subtracted fit (residuals) may be seen with the 'j' +keystroke. + +If the user is dissatisfied with the fit to the peak, he can mark the left +and right side of the peak with the 'g' keystroke to redo the fit, or else +set the cursor to mark a cutoff with the 'y' keystroke, and all points from +the peak maximum to the cursor will be fit. To fix the background of a +Gaussian fit (i.e. change the \fIbackground\fR parameter graphically), type +the 'b' keystroke at the desired level, and a new fit will be done. The 'r' +keystroke may be used at any time to redraw the plot, and the 'x' keystroke +can be used to compute a new correlation if any of the parameters relating +to the correlation are changed (e.g. the apodize percentage). New +correlations are automatically computed when new images are read in, the +data are continuum subtracted, a different region is selected for +correlation, or Fourier filtering is done. Certain colon commands from +within the Fourier or Spectrum mode will also cause a new correlation to be +computed when these modes are exited. + +The 'c' keystroke may be used to get a printout of the cursor position in both +lag and relative velocity. The cursor may be positioned in either the +unlabeled CCF plot on the top, or in the zoomed plot on the bottom. This is +useful for judging the FWHM calculation, or estimating the velocity of a +peak without using the 'z' keystroke to zoom and fit. Note that because of +the plotting implementation, the normal cursor mode keystroke \fIshift-C\fR +should not be used as it may return erroneous results depending upon cursor +position. Note also that velocities printed are only approximate relative +velocities, and the user should properly fit a peak or use the ":correction" +command to get a true heliocentric velocity. + +For binary star work, the user may type the 'd' and/or '-' keystrokes to fit +and then subtract up to four Gaussians to the peaks. See the discussion +below for more deatils on the use of this feature. If multiple peaks were +fit, a separate entry will be made in the log file for each peak with a +comment that it was part of a blended peak. The metacode file will contain +only one summary plot with each peak marked with it's heliocentric velocity +or pixel shift. + +To move to the next spectrum in a list (of images or apertures), simply hit +the 'n' keystroke. Similary, the 'p' keystroke will move to the previous +spectrum. These commands have a hitch, though. By default, the +next/previous commands will move first to the next template in the template +image list. Once the end of the template image list is reached, the next +spectrum will be the next aperture in the list specified by \fIapertures\fR, +resetting the template image list automatically and possibly updating the +aperture in the template image as well. Finally, after correlating all of +the templates against all of the apertures, the next/previous command will +move to the next object image, again resetting the template image and/or +aperture list. To override this sequence, the user may use the ":next" or +":previous" commands and specify one of "aperture", "object", or +"template". If \fIautowrite\fR is set, the results of the last fit will be +written to the log automatically. To write any one of the fits explicitly, +use the 'w' keystroke. + +The \fIfxcor\fR task also contains three submodes discussed in detail below. +Briefly, the 'f' keystroke will put the user in the "fourier mode", +where he can examine the Fourier transform of the spectra in various +ways and change/examine the filtering parameters. The 'o' and 't' +keystrokes let the user examine and fit the continuum for the object +and template spectra, respectively, using the \fBicfit\fR commands. +Upon exiting the continuum fitting the spectra are continuum subtracted +and a new correlation is computed. Finally the 's' keystroke will put +the user in "spectrum mode", in which he may graphically select the +region to be correlated, compute an approximate shift using the cursor, +or simply examine the two spectra in a variety of ways. All of these +submodes are exited with the 'q' keystroke, after which the correlation +will be redone, if necessary, and the CCF plot redrawn. + +Colon commands may also be used to examine or change parameter values in +any of the \fIfiltpars\fR, \fIcontinpars\fR, or \fIkeywpars\fR +psets. Simply type a ':' followed by the parameter name and an optional +new value. The \fIobservatory\fR parameters may only be changed outside +the task. + +To exit the task, type 'q'. Results will be saved +to the logfile automatically if one was specified, otherwise the user will +be asked if he wants to save the results, and if so, queried for a file name +before exiting if no \fIoutput\fR file was defined. + +If the \fIoutput\fR parameter is set, several files will be created +depending on the value of the \fIverbose\fR parameter (see the parameter +description for details). These include a file with a ".gki" suffix +containing metacode output of a summary plot, a ".txt" suffix file +containing text output in the standard IRAF 'list' format containing either +verbose or non-verbose output, and a third file having a ".log" suffix +containing a verbose description of the correlation and fit, as well as any +warning messages. This contents of the ".log" file is identical to what is +seen with the 'v' keystroke. If the computed relative velocity exceeds the +package parameter \fIz_threshold\fR, the ".txt" file will contain redshift Z +values rather than the default velocities. Text file output may be have +selected columns extracted using the iraf \fIfields\fR task (where string +valued fields will have blank spaces replaced with an underscore), and +specific metacode plots may be extracted or displayed with the iraf +\fIgkiextract\fR and/or \fIstdgraph\fR/\fIgkimosaic\fR tasks. + +(References: Tonry, J. and Davis, M. 1979 \fIAstron. J.\fR \fB84,\fR 1511, +and Wyatt, W.F. 1985 in \fIIAU Coll. No 88, Stellar Radial Velocities\fR, +p 123). + +.ih +FOURIER MODE DESCRIPTION +Fourier mode is entered from the main task mode via the 'f' keystroke. By +default, the user is presented with a split plot of the power spectra of +the object and template spectra (object on top) and the requested filter +overlayed. The X-axis is double-labeled with wavenumbers on the bottom of +the screen and frequency on top. The ":log_scale" command can be used to +toggle the log scaling of the Y-axis of the plot, and the ":overlay" command +will toggle whether or not the filter function (if specified) is overlayed +on the plot. By default the entire power spectrum is displayed, but +the ":zoom" command may be used to specify a blowup factor for the +display (e.g. ":zoom 2" will display only the first half of the power +spectrum). Plot scaling and content parameters are learned for the next +invocation of this mode. + +The plot contents may also be changed through various keystroke commands. +The 'p' keystroke will display the power spectrum (the default) and the 'f' +keystroke will display the two FFT's. The 'b' and 'g' +keystrokes may be used to examine the power spectra and FFT's +respectively \fIbefore\fR filtering. The user can determine the period +trend in the data by placing the cursor at a particular wavenumber/frequency +and hitting the 'i' keystroke (this command will not work on a plot of +the filtered spectra). The 'r' key will redraw whichever plot is currently +selected and a 'q' will return the user to the mode which called the Fourier +mode (i.e. either the main task mode or the Spectrum mode). The Spectrum +mode may be entered from within Fourier mode via the 's' keystroke. + +Colon commands are also used to specify or examine the filtering parameters +by simply typing a ':' followed by the parameter name found in +the \fIfiltpars\fR pset. + +.ih +CONTINUUM MODE DESCRIPTION +Automatic continuum subtraction is controlled by the \fIcontinpars\fR +pset. These may be reset from the main +correlation function mode. To interactively fit and modify the continuum +fitting parameters the 'o' and 't' keys are used. This enters +the ICFIT package which is described elsewhere (see \fIicfit\fR). +Exiting the fitting, +with 'q', causes a recomputation of the correlation function and peak +fit. To view the flattened spectra use the spectrum review mode +entered with the 's' key. Fitting parameters changed while doing the +interactive continuum fitting are learned. + +.ih +SPECTRUM MODE DESCRIPTION +Spectrum mode is entered from the main or fourier mode via the 's' +keystroke. The user may select plots of the original input spectra with the +'i' keystroke, or the continuum subtracted spectra with the 'n' keystroke, +If the data have been rebinned to a log scale, they will still be plotted +on a linear wavelength scale for clarity. Pixel data are plotted identically +to how they were read. (NOTE: For rebinned spectra, a slight slope may be +noticed in the 'original' data because of rebinning effects.) +In addition, a sample regions (if selected) for the correlation are marked +on the bottom of both plots. To select a new sample region, use the 's' +keystroke to select the endpoints of the region. An 's' keystroke on the +top plot will select a sample region for the object spectrum, and an 's' on +the bottom plot will select a template sample, using the 'b' keystroke will +select both samples simultaneously. The regions may be selected +explicitly by using the ":osample" and ":rsample" commands, and selected +sample regions may be cleared entirely using the (e.g.) ":osample *" command, +or individual regions may be unselected by putting the cursor within the +region and typing 'u'. See the +parameter description for syntax of the sample ranges. Regions will be +checked and possibly truncated to see if they +lie within the range of the spectrum. The 'd' +keystroke may be used to print the difference in pixels (and/or velocity) +between two points on the spectrum. This is useful for getting an +approximate shift. Fourier mode may be entered via the 'f' keystroke. To +return to the correlation simply type 'q' or 'x'. + +In addition to the above commands, the user may examine or change the +parameters in the \fIcontinpars\fR pset by simply typing a ':' followed +by the parameter name. Changing these values will not cause a new correlation +until an explicit command is given to redo the continuum subtraction. + +(NOTE: More functionality is planned for this mode.) + +.ih +INTERPOLATION +The interpolation type is set by the package parameter \fIinterp\fR. +The available interpolation types are: + +.nf + nearest - nearest neighbor + linear - linear + poly3 - 3rd order polynomial + poly5 - 5th order polynomial + spline3 - cubic spline + sinc - sinc function +.fi + +The default interpolation type is a 5th order polynomial (poly5). + +The choice of interpolation type depends on the type of data, smooth +verses strong, sharp, undersampled features, and the requirements of +the user. The "nearest" and "linear" interpolation are somewhat +crude and simple but they avoid "ringing" near sharp features. The +polynomial interpolations are smoother but have noticible ringing +near sharp features. They are, unlike the sinc function described +below, localized. + +In V2.10 a "sinc" interpolation option is available. This function +has advantages and disadvantages. It is important to realize that +there are disadvantages! Sinc interpolation approximates applying a phase +shift to the fourier transform of the spectrum. Thus, repeated +interpolations do not accumulate errors (or nearly so) and, in particular, +a forward and reverse interpolation will recover the original spectrum +much more closely than other interpolation types. However, for +undersampled, strong features, such as cosmic rays or narrow emission or +absorption lines, the ringing can be more severe than the polynomial +interpolations. The ringing is especially a concern because it extends +a long way from the feature causing the ringing; 30 pixels with the +truncated algorithm used. Note that it is not the truncation of the +interpolation function which is at fault! + +Because of the problems seen with sinc interpolation it should be used with +care. Specifically, if there are no undersampled, narrow features it is a +good choice but when there are such features the contamination of the +spectrum by ringing is much more severe than with other interpolation +types. + +.ih +DEBLENDING +When entering the deblending function, two cursor settings define the +local background, which may be sloping, and the region to be fit. Note +that both the x and y of the cursor position are used. The lines to be +fit are then entered either with the cursor ('m'), or by typing the +shifts ('t'). The latter is useful if the shifts of the +lines are known accurately and if fits restricting the absolute or +relative positions of the lines will be used (i.e. 'a', 'b', 'd', +'e'). A maximum of four lines may be fit. If fewer lines are desired, +exit the marking step with 'q'. + +There are six types of fits which may be selected. This covers all +combinations of fixing the absolute positions, the relative positions, +the sigmas to be the same, and letting all parameters be determined. +In all cases the peak intensities are also determined for each line. +The options are given below with the appropriate key and mnemonic. + +.nf + a=0p1s Fit intensities and one sigma with positions fixed + b=1p1s Fit intensities, one position, and one sigma with + separations fixed + c=np1s Fit intensities, positions, and one sigma + d=0pns Fit intensities and sigmas with positions fixed + e=1pns Fit intensities, one position, and sigmas with + separations fixed + f=npns Fit intensities, positions, and sigmas +.fi + +This list may also be printed with the '?' key when in the deblending +function. + +As noted above, sometimes the absolute or relative shifts of the +lines are known a priori and this information may be entered by typing +the shifts explicitly using the 't' option during marking. In +this case, one should not use the 'c' or 'f' fitting options since they +will adjust the line positions to improve the fit. Options 'a' and 'd' +will not change the lines positions and fit for one or more sigmas. +Options 'b' and 'e' will maintain the relative positions of the lines +but allow an other than expected shift. + +After the fit, the modeled lines are overplotted. The line center, +flux, equivalent width, and full width half maximum are printed on the +status line for the first line. The values for the other lines and +the RMS of the fit may be examined by scrolling the status line +using the '+', '-', and 'r' keys. Velocity information is obtained by +typing the 'v' keystroke. To continue enter 'q'. + +The fitting may be repeated with different options until exiting with 'q'. + +The fitted model may be subtracted from the data (after exiting the +deblending function) using the '-' (minus) +keystroke to delimit the region for which the subtraction is to +be performed. This allows you to fit a portion of a peak which may +be contaminated by a blend and then subtract away the entire peak +to examine the remaining components. + +The fitting uses an interactive algorithm based on the Levenberg-Marquardt +method. The iterations attempt to improve the fit by varying the parameters +along the gradient of improvement in the chi square. This method requires +that the initial values for the parameters be close enough that the +gradient leads to the correct solution rather than an incorrect local +minimum in the chi square. The initial values are determined as follows: + +.nf + 1. The initial line centers are those specified by the user + either by marking with the cursor or entering the shifts. + 2. The initial peak intensities are the data values at the + given line centers with the marked continuum subtracted. + 3. The initial sigmas are obtained by dividing the width of + the marked fitting region by the number of lines and then + dividing this width by 4. +.fi + +Note that each time a new fitting options is specified the initial parameters +are reset. Thus the results do not depend on the history of previous fits. +However, within each option an iteration of parameters is performed as +described next. + +The iteration is more likely to fail if one initially attempts to fit too +many parameters simultaneously. A constrained approach to the solution +is obtained by iterating starting with a few parameters and then adding +more parameters as the solution approaches the true chi square minimum. +This is done by using the solutions from the more constrained options +as the starting point for the less constrained options. In particular, +the following iterative constraints are used during each option: + +.nf + a: 0p1s + b: 0p1s, 1p1s + c: 0p1s, 1p1s, np1s + d: 0p1s, 0pns + e: 0p1s, 1p1s, 1pns + f: 0p1s, 1p1s, np1s, npns +.fi + +For example, the most general fit, 'f', first fits for only a single sigma +and the peak intensities, then allows the lines to shift but keeping the +relative separations fixed. Next, the positions are allowed to vary +independently but still using a single sigma, and then allows all parameters +to vary. + +To conclude, here are some general comments. The most restrictive 'a' +key will give odd results if the initial positions are not close to the +true centers. The most general 'f' can also lead to incorrect results +by using unphysically different sigmas to make one line very narrow and +another very broad in an attempt to fit very blended lines. The +algorithm works well when the lines are not severely blended and the +shapes of the lines are close to Gaussian. + +.ih +PEAK FITTING/FINDING ALGORITHMS +Determining the center of the cross correlation peak is the key step in +measuring a relative shift or velocity between the object and template. +The width of the correlation peak is also of interest for measuring +a line broadening between the two samples. Since people have different +preferences and prejudices about these important measurements, a variety +of methods with a range of parameters is provided. + +In all cases, one must specify the fitting function and a sample width; i.e. +the range of points about the correlation peak to be used in the +measurement. Note that the width defines where the fitting weights vanish +and should be something like the full width. For the CENTER1D algorithm the +maximum weights are at the half width points while for the other methods +(with the exception of "sinc") greater weight is given to data nearer the +center. + +The width may be specified in three ways. The first is as an actual +width in pixels. This is the most straightforward and is independent +of quirks in the actual shape of the peak. The second way is to find +where the correlation function crosses a specified height or level. +The height may be specified in normalized correlation units or as a +fraction of the peak height. The former is equivalent to the +interactive 'y' key setting while the latter may be used to select some +"flux" point. A value of 0.5 in the latter would be approximately the +full width at half intensity point except that the true zero or base of +the peak is somewhat uncertain and one needs to keep in mind that the +weights go to zero at this point. Note that a level may be negative. +In this method the actual width may go to zero or include the entire +data range if the level fall above the peak or below the minimum of the +correlation. The minimum and maximum width parameters are applied to +constrain the fitting region. The last method is to interactively mark +the fitting region with the 'g' key. + +There are five methods for determining the correlation peak position. The +CENTER1D algorithm has been heavily used in IRAF and is quite stable and +reliable. It is independent of a particular model for the shape of the peak +or the background determination and is based on bisecting the integral. It +uses antisymmetric weights with maxima at points half way between the +estimated center and the fitting region endpoint. A parabola fit and sinc +interpolation is also independent of background determinations. The +parabola is included because it is a common method of peak centering. + +The sinc option uses a sinc interpolator together with a maximization +(actually a minimization algorithm) function to determine the peak height +and center. A width will be computed only if a background level has been +set and is determined empirically based on the peak height and background. +Point weighting is not used in this option. + +The gaussian and lorentzian function fits are model dependent and +determine a center, width, and peak value. The background may also +be determined simultaneously but this extra degree of freedom +for a function which is not strictly gaussian or lorentzian may +produce results which are sensitive to details of the shape of the +correlation function. The widths reported are the full width at +half maximum from the fits. + +The parabola, gaussian, and lorentzian methods use weights which +vary continuously from 1 at the estimated center to zero at the +endpoints of the fitting region. The functional form of the +weights is a power law with specified exponent. A value of zero +for the exponent produces uniform weights. However, this is +discontinuous at the endpoints and so is very sensitive to the data +window. A value of one (the default) produces linearly decreasing weights. + +All these methods produce centers which depend on the actual +data points and weights used. Thus, it is important to iterate +using the last determined center as the center of the data window +with continuous weights in order to find a self-consistent center. +The methods are iterated until the center does not change by more +than 0.01 pixels or a maximum of 100 iterations is reached. + +Errors in the pixel shift are computed from the center parameter of the fitting +function. Velocity errors are computed based on the fitted peak height and +the antisymmetric noise as described in the Tonry & Davis paper (1979, +\fIAstron. J.\fR \fB84,\fR 1511). Dispersion/pixel-width errors are +not computed in this release but are planned for a future release. + +The initial peak fit will be the maximum of the CCF. This will be the only +peak fit in non-interactive mode but a confidence level will be entered in +the logfile. In interactive mode, the user may select a different peak with +the 'z' keystroke, and the maximum peak within the specified \fIwindow\fR +(centered on the cursor) will be fit. The user has full control in interactive +mode over the points used in the fit. Once the endpoints of the peak have +been selected, the actual data points are shown with '+' signs on the CCF, +the fitted curve drawn, and a horizontal bar showing the location of the +FWHM calculation is displayed. The status line will show a summary of the +fit, and the user may type the 'v' keystroke for a more detailed description +of the fit and correlation. + +.ih +VELOCITY COMPUTATION ALGORITHM +Up to three velocities are computed by the task depending on the completeness +of the images headers and the presence of dispersion information. If only +dispersion information is present, a relative velocity, VREL, and an error +will be computed. If a full header is present (see the \fIkeywpars\fR +help page), an observed and heliocentric velocity (VOBS and VHELIO +respectively) will be computed. + +In short form, here are the equations: +.nf + + ref_rvobs = catalogue_vel_of_template - H(temp) # obs. vel. of temp. + VREL = C * (10 ** (wpc * shift) - 1.) # relative vel. + VOBS = ((1+ref_rvobs/C)*(10**(wpc*shift)-1)) * C # observed vel. + VHELIO = VOBS + H(object) # heliocentric vel. + +.fi +where H() is the heliocentric correction for that observation. The +equation used for the relative velocity is derived from the standard +(1+z), and the VOBS equation reflects that the observed velocty is the +product of (1+z) values for the object and template (this allows for high +redshift templates to be used). The date, time, and position of each +spectrum is found from the image header via the keywords defined in +\fIkeywpars\fR. In the case of the time the task first looks for a +keyword defining the UT mid-point of the observation +(\fIkeywpars.utmiddle\fR). If that is not found any time present in the +header DATE-OBS (\fIkeywpars.date_obs\fR) keyword is used at the UT start +point, if there is no time in the keyword value then the mid-point UT is +computed from the exposure time (\fIkeywpars.exptime\fR) and UT of +observation (\fIkeywpars.ut\fR) keywords. + +The keyword added to the template header (as defined by the +"vhelio" parameter in the \fIkeywpars\fR pset) should be the catalogue velocity +of the template. Since the observation of the template has a slightly +different heliocentric correction, this is subtracted from the template +heliocentric velocity so that the \fIobserved\fR velocity of the template +is used when correcting the relative velocity computed from the shift. +This gives the \fIobserved\fR velocity of the object wrt the template. +Adding the heliocentric correction of the object star then yields the true +heliocentric velocity of the object. + +.bp +.ih +CURSOR KEYS AND COLON COMMANDS SUMMARY + +.ce +CORRELATION MODE COMMANDS +.nf +? Print list of cursor key and colon commands +- Subtract blended component from correlation peak +. Do the continuum subtraction ++ Toggle status line output +a Display the antisymmetric noise component of the correlation +b Fix the background level for the Gaussian fit +c Read out cursor position in pixel lag and velocity +d Deblend multiple correlation peak +e Preview the summary plot of the correlation +f Fourier filtering and FFT display mode +g Mark correlation peak lag limits and fit +I Interrupt +j Plot the residuals of the fit to the peak +l Page the current logfile of results +m Plot polymarkers of actual CCF points on the plot +n Go to next (template --> aperture --> object) +o Fit or refit object spectrum continuum for subtraction +p Go to previous (template --> aperture --> object) +q Quit task +r Redraw +s Examine object/template spectra and display mode +t Fit or refit template spectrum continuum for subtraction +v Print full correlation result in text window +w Write current correlation results to the log file +x Compute correlation +y Mark correlation peak lower limit and fit +z Expand on different correlation peak using full correlation plot + +:apertures [range] Set/Show list of apertures to process +:apnum [aperture] Set/Show specific aperture to process +:apodize [fraction] Set/Show fraction of endpts to apodize +:autowrite [y|n] Set/Show autowrite param +:autodraw [y|n] Set/Show autodraw param +:background [background|INDEF] Set/Show background fitting level +:ccftype [image|text] Set/Show type of CCF output +:comment [string] Add a comment to the output logs +:continuum [both|obj|temp|none] Set/Show which spectra to normalize +:correction shift Convert a pixel shift to a velocity +:deltav Print the velocity per pixel dispersion +:disp Print dispersion info +:filter [both|obj|temp|none] Set/Show which spectra to filter +:function [gaussian|lorentzian| Set/Show CCF peak fitting function + center1d|parabola] +:height [height] Set/SHow CCF peak fit height +:imupdate [y|n] Set/Show image update flag +:maxwidth [width] Set/Show min fitting width +:minwidth [width] Set/Show max fitting width +:nbang :Next command without a write +:next [temp|aperture|object] Go to next correlation pair +:objects [list] Set/Show object list +:osample [range] Set/Show object regions to correlate +:output [fname] Set/Show output logfile +:<parameter> [value] Set/Show pset parameter value +:peak [y|n] Set/Show peak height flag +:pbang :Previous command without a write +:previous [temp|aperture|object] Go to previous correlation pair +:printz [y|n] Toggle output of redshift z values +:rebin [small|large|obj|temp] Set/Show the rebin parameter +:results [file] Page results +:rsample [range] Set/Show template regions to correlate +:show List current parameters +:templates [list] Set/Show template list +:tempvel [velocity] Set/Show template velocity +:tnum [temp_code] Move to a specific temp. in the list +:unlearn Unlearn task parameters +:update Update task parameters +:version Show task version number +:verbose [y|n] Set/Show verbose output flag +:wccf Write out the CCF to an image|file +:weights [weight] Set/Show fitting weights +:width [width] Set/Show fitting width about peak +:wincenter [center] Set/Show peak window center +:window [size] Set/Show size of window +:ymin [correlation height] Set/Show lower ccf plot scaling +:ymax [correlation height] Set/Show upper ccf plot scaling +.fi + +.ce +FOURIER MODE COMMANDS +.nf +? Print list of cursor key and colon commands +b Display power spectra before filtering +f Enter Fourier mode +g Display Fourier transforms before filtering +i Print period trend information +o Display filtered and unfiltered object spectrum +p Display power spectra after filtering +q Quit +r Redraw +s Enter Spectrum mode +t Display filtered and unfiltered template spectrum +x Return to parent mode + +:log_scale [y|n] Plot on a Log scale? +:one_image [object|template] What plot on screen +:overlay [y|n] Overlay filt function? +:<parameter> [value] Set/Show the FILTERPARS parameter value +:plot [object|template] What type of plot to draw on single plot? +:split_plot [y|n] Make a split-plot? +:when [before|after] Plot before/after filter? +:zoom [factor] FFT zoom parameter +.fi + +.ce +CONTINUUM MODE COMMANDS + +See \fBicfit\fR. + +.ce +SPECTRUM MODE COMMANDS +.nf +? Print list of cursor key and colon commands +b Select sample regions for both spectra +d Print velocity difference between two cursor positions +f Enter Fourier mode +i Display original input spectra +n Display continuum subtracted spectra +p Display the prepared spectra prior to correlation +q Quit +r Redraw +s Select sample region endpoints +u Unselect a sample region +x Return to correlation mode + +:<parameter> [value] Set/Show parameters in CONTINPARS pset +:osample [list] List of object sample regions +:rsample [list] List of template sample regions +:show List current parameters +.fi + +.ih +EXAMPLES +.nf + 1. Cross correlate a list of 1-dimensional object spectra against + three 1-dimensional template spectra, saving results automatically + and not continuum subtracting or filtering the data: + + rv> fxcor.interactive = no # Do it in batch mode + rv> fxcor obj* temp1,temp2,temp3 autowrite+ continuum="no" + >>> filter="no" output="results" + + 2. Compute a velocity for a list of apertures in a 2-dimensional + multispec format object image, using only two apertures of a multispec + image as the templates: + + cl> onedspec + on> scopy object.ms temp apert="8,9" inform="multi" outform="oned" + on> rv + rv> fxcor.interactive = no # Do it in batch mode + rv> fxcor object.ms temp.0008,temp.0009 apertures="1-7,10,12-35" + + In this example, apertures 8 and 9 of the object image will be used + as the template. The \fIscopy\fR task is used to extract the aper- + tures to onedspec format, into two images named "temp.0008" and + "temp.0009". The task is then run with all of the apertures in the + aperture list correlated against the onedspec templates. + + 3. Compute a velocity by fitting a fixed number of points on the peak, + using uniform weighting: + + rv> fxcor obj temp width=8 weights=0. + + 4. Compute a velocity by fitting a Gaussian to the points on the CCF + peak above the 0.1 correlation level. Constrain the number of points + to be less than 15, and linearly decrease the weights: + + rv> fxcor obj temp func="gaussian" width=INDEF height=0.1 + >>> maxwidth=15 weights=1. + + 5. Compute a velocity by fitting a Lorentzian to the peak, from the + peak maximum to it's half power point: + + rv> fxcor obj temp func-"lorentz" width=INDEF height=0.5 peak+ + >>> maxwidth=15 weights=1. + + 6. Process a 1-dimensional object against a 1-dimensional template + interactively, examining the FFT, and input spectra to define a sample + region for the correlation: + + rv> fxcor obj temp inter+ continuum="both" autowrite- output="" + Screen is cleared and CCF peak with fit displayed + + ... to refit peak, move cursor to left side of peak and type 'g' + ... move cursor to right side of peak and hit any key + + New fit is drawn and results displayed to the status line + + ... type the 'v' key for a detailed description of the correlation + + Graphics are suspended and the text screen shows various + parameters of the correlation and fit. + + ... type 'q' to get back to graphics mode + + ... to examine the FFT's of the spectra, type the 'f' keystroke. + + The screen is cleared and a split plot of the two power spectra + after filtering is drawn with the requested filter (if any) + overlayed. + ... type the 'f' keystroke + The screen is cleared and the absolute value of the two FFT's + after filtering is plotted, again with the filter overlayed. + ... type ":overlay no", followed by a 'g' keystroke + The spectra are redrawn prior to filtering, with no filter over- + lay + ... type 'q' to return to correlation mode + + The screen is redrawn with the CCF plot and peak fit + + ... type 's' to enter spectrum mode + + The screen is cleared and the input spectra displayed + ... type 's' to mark the endpoints of sample regions for correl- + ... ation. The user can mark either the top or bottom plot to + ... set sample regions for the object and template respectively. + ... Then type 'q' to quit this mode + + A new correlation is computed and the peak refit automatically + + ... type 'q' to quit the task, satisfied with the results + The user is asked whether he wants to save results + ... type 'y' or <cr> to save results + The user is prompted for an output file name since one wasn't + specified in the parameter set + ... type in a file name + + The task exits. + + 7. Save the correlation function of two galaxy spectra: + + rv> fxcor obj temp inter+ ccftype="text" + Screen is cleared and CCF peak with fit displayed + + ... type ":wccf" to write the CCF + ... type in a filename for the text output + ... quit the task + + rv> rspectext ccf.txt ccf.fits dtype=interp + rv> splot ccf.fits + + The velocity per-pixel-shift is non-linear and is an approximation + which works well for low-velocity shifts. In the case of hi-velocity + correlations (or when there are many points) it is best to save the + CCF as a text file where the velocity at each shift is written to + the file, then use RSPECTEXT to linearize and convert to an image + format. This avoids the task interpolating a saved image CCF in + cases where it may not be required. + + 7. Compute a cross-correlation where the template has already been + corrected to the rest frame and no heliocentric correction is + required: + + Step 1) Use the HEDIT or HFIX tasks to add the following + keywords to the template image: + + DATE-OBS= '1993-03-17T04:56:38.0' + RA = '12:00:00' + DEC = '12:00:00' + EPOCH = 1993.0 + OBSERVAT= 'KPNO' + VHELIO = 0.0 + + These values produce a heliocentric correction of zero + to within 5 decimal places. The VHELIO keyword will + default to zero if not present. + + Step 2) Use the HEDIT task to add an OBSERVAT keyword to each + of the object spectra. The OBSERVATORY task can be used + get a list of recognized observatories. + + Because mixing observatories is not currently well supported, the + use of the OBSERVAT keyword in \fI both\fR images is the only sure + way to apply the proper observatory information to each image. Users + may wish to derive a zero-valued heliocentric correction for their + local observatory and use those values instead. +.fi + +.ih +SEE ALSO +continpars, filtpars, observatory, keywpars, onedspec.specwcs, center1d, +dispcor, stsdas.fourier +.endhelp diff --git a/noao/rv/doc/keywpars.hlp b/noao/rv/doc/keywpars.hlp new file mode 100644 index 00000000..5fd1aa9f --- /dev/null +++ b/noao/rv/doc/keywpars.hlp @@ -0,0 +1,94 @@ +.help keywpars Dec90 noao.rv +.ih +NAME +keywpars -- edit the image header keywords used by the package +.ih +USAGE +keywpars +.ih +PARAMETERS +.ls ra = "RA" +Right Ascension keyword. (Value in HMS format). +.le +.ls dec = "DEC" +Declination keyword. (Value in HMS format). +.le +.ls ut = "UT" +UT of observation keyword. This field is the UT start of the observation. +(Value in HMS Format). +.le +.ls utmiddle = "UTMIDDLE" +UT mid-point of observation keyword. This field is the UT mid-point of +the observation. (Value in HMS Format). +.le +.ls exptime = "EXPTIME" +Exposure time keyword. (Value in Seconds). +.le +.ls epoch = "EPOCH" +Epoch of coordinates keyword. (Value in Years). +.le +.ls date_obs = "DATE-OBS" +Date of observation keyword. Format for this field should be +dd/mm/yy, (old FITS format), yyyy-mm-dd (new FITS format), or +yyyy-mm-ddThh:mm:ss.sss (new FITS format with time). +.le + +.ce +OUTPUT KEYWORDS +.ls hjd = "HJD" +Heliocentric Julian date keyword. (Value in Days). +.le +.ls mjd_obs = "MJD-OBS" +Modified Julian Data keyword. The MJD is defined as the julian date of +the mid-point of the observation - 2440000.5. (Value in Days). +.le +.ls vobs = "VOBS" +Observed radial velocity keyword. (Value in Km/sec). +.le +.ls vrel = "VREL" +Observed radial velocity keyword. (Value in Km/sec). +.le +.ls vhelio = "VHELIO" +Corrected heliocentric radial velocity keyword. (Value in Km/sec). +.le +.ls vlsr = "VLSR" +Local Standard of Rest velocity keyword. (Value in Km/sec). +.le +.ls vsun = "VSUN" +Epoch of solar motion. (Character string with four real valued fields +describing the solar velocity (km/sec), the RA of the solar velocity (hours), +the declination of the solar velocity (degrees), and the epoch of solar +coordinates (years)). +.le +.ih +DESCRIPTION +The image header keywords used by the \fIfxcor\fR task can be +edited if they differ +from the NOAO standard keywords. For example, if the image header keyword +giving the exposure time for the image is written out as "EXP-TIME" instead +of the standard "OTIME" at a given site, the keyword accessed for +that information +may be changed based on the value of the \fIexptime\fR parameter. + +The \fIvhelio\fR keywords must be added to the image header of the template +spectrum and should contain the known radial velocity of the template star. +The output keywords may be added to the object image header if the +tasks \fIfxcor.imudate\fR parameter is set. + +.ih +EXAMPLES +1. List the image header keywords. + +.nf + rv> lpar keywpars +.fi + +2. Edit the image header keywords + +.nf + rv> keywpars +.fi +.ih +SEE ALSO +fxcor +.endhelp diff --git a/noao/rv/doc/rv.spc b/noao/rv/doc/rv.spc new file mode 100644 index 00000000..720f1b0b --- /dev/null +++ b/noao/rv/doc/rv.spc @@ -0,0 +1,918 @@ +.help rvxcor Aug90 noao.rv +.ih +INTRODUCTION + +Specifications are presented for a Fourier cross-correlation task used +to compute either relative or heliocentric radial velocities. Input +data need not be dispersion corrected, and the user has full control +over cross-correlation function (ccf) peak fitting, continuum subtraction, +and Fourier filtering of the data. Several sub-modes exist wherein the +user may examine the Fourier characteristics of the data, interactively +fit the continuum, and examine the input spectra themselves. Output +options include a text logfile which may be parsed with the IRAF \fIfields\fR +task, a GKI metacode file containing a summary plot of the correlation, +and optionally a text or IRAF image of the ccf itself (from interactive +operation only). + +.ih +SUMMARY +.nf + + BASIC TASK ORGANIZATION + + List of object and template spectra + | + | +------------------------+ + | | Rebin the data? | + +--------------+ | Fit/subtract continuum | + | Prepare data |<----->| Zero endpoints and pts | + +--------------+ | not in sample | + | | Subtract bias | + | | Apodize end regions | + +----------------------+ | Center in FFT array | + | Compute correlation | +------------------------+ + | Display correlation | + | Fit correlation peak | + +----------------------+ + | + +--------------------+-----------------------+ + ^ ^ ^ + / \ / \ / \ + | | | + \ / \ / \ / + ` ` ` ++-------------------+ +---------------------+ +-------------------+ +| Fourier filtering |-->| Spectra review |-->| Continuum fitting | +| |<--| Mark sample regions |<--| ICFIT | ++-------------------+ +---------------------+ +-------------------+ + + TASK PARAMETERS + +Input parameters: objects + templates + apertures = "*" + cursor = "" + +Data preparation: continuum = "both" + filter = "none" + sample = "*" + apodize = 0.2 + +Peak fitting: function = "gaussian" + width = INDEF + height = 0.0 + peak = no + minwidth = 3. + maxwidth = 11. + weights = 1.0 + background = 0.0 + window = 20 + +Output parameters: output = "" + verbose = "yes" + imupdate = "no" + graphics = "stdgraph" + +Control parameters: interactive = "yes" + autowrite = "yes" + ccftype = "image" + +Parameter sets: continpars = "" + filterpars = "" + rvkeywords = "" + observatory = "" + +MAIN CORRELATION FITTING COMMAND SUMMARY + +? Print list of cursor key and colon commands +- Subtract blended component from correlation peak ++ Toggle status line output +a Display the antisymmetric noise component of the correlation +b Fix background level for Gaussian fit +c Plot polymarkers of actual CCF points on the plot +d Deblend multiple correlation peak +e Preview the summary plot of the correlation +f Fourier filtering and display mode +g Mark correlation peak lag limits and fit +j Plot the residuals of the fit to the peak +k Plot the ratio of the fit to the peak +l Page the log file of results +n Go to next (template --> aperture --> object) +o Fit or refit object spectrum continuum for subtraction +p Go to previous (template --> aperture --> object) +q Quit task +r Redraw +s Examine object/template spectra and display mode +t Fit or refit template spectrum continuum for subtraction +v Print full correlation results in text window +w Write current correlation results to the log file +x Compute a new correlation +y Mark correlation peak lower limit and fit +z Expand on different correlation peak using full correlation plot + +:next [template|aperture|object] Go to next correlation pair +:parameters List current parameters +:previous [template|aperture|object] Go to previous correlation pair +:results [file] Page results +:wccf file Write the CCF to an image/text file + +Other colon commands set or show parameter values + +FOURIER FILTERING COMMAND SUMMARY + +? Print list of cursor key and colon commands +b Display power spectra before filtering +f Display Fourier transforms after filtering +g Display Fourier transforms before filtering +i Print period trend information +p Display power spectra after filtering +q Quit +r Redraw +s Enter spectrum mode +x Return to correlation mode + +:log_scale [yes|no] Set log scaling on Y axis +:overlay [yes|no] Overlay filter function +:parameters List current parameter values +:zoom [factor] Zoom x region + +Other colon commands set or show parameter values + +SPECTRUM REVIEW COMMAND SUMMARY + +? Print list of cursor key and colon commands +d Print velocity difference between two cursor positions +e Plot a preview of the summary plot +f Enter Fourier mode +i Display original input spectra +n Display continuum subtracted spectra +q Quit +r Redraw +s Mark sample regions +x Return to correlation mode + +:sample [list] List of sample regions + +CONTINUUM FITTING COMMAND SUMMARY + +See \fBicfit\fR. +.fi +.bp +.ih +NAME +rvxcor -- compute radial velocities via Fourier cross correlation +.ih +USAGE +rvxcor objects templates +.ih +PARAMETERS +.ce +INPUT PARAMETERS +.ls objects +The list of image names for the input object spectra. +.le +.ls templates +The list of image names that will be used as templates for the cross +correlation. +.le +.ls apertures = "*" +List of apertures to be used. This number is used for \fIboth\fR the +object and reference spectra. A '*' means to process all of the +apertures in the spectrum. If the template spectrum is one-dimensional, +that spectrum will be used as a template for all specified apertures in +the object spectrum. +.le +.ls cursor = "" +Graphics cursor input. +.le + +.ce +DATA PREPARATION PARAMETERS +.ls continuum = "both" +Continuum subtract the spectra prior to correlation? Possible values for +this parameter are any of the strings (or abbreviations) "object" (for object +spectrum only), "template" (for template spectrum only), or "both" for +continuum flattening both object and template spectra, or simply "none" for +flattening neither spectrum. The \fIcontinpars\fR pset is used to specify +the continuum fitting parameters. +.le +.ls filter = "none" +Fourier filter the spectra prior to correlation? Possible values for +this parameter are any of the strings (or abbreviations) "object" (for object +spectrum only), "template" (for template spectrum only), or "both" for +fourier filtering both object and template spectra, or simply "none" for +filtering neither spectrum. The \fIfilterpars\fR pset holds the parameters +for the filtering (filter type and width). +.le +.ls sample = "*" +Sample regions of the spectrum to be used in the correlation specified +in pixels if the first character is a 'p' or angstroms if the first +character is an 'a'. The default (i.e. no 'a' or 'p' as the first +character), if a range is provided, is a range specified in pixels. +This string value will be updated in an interactive session as sample +regions are re-selected. The default, '*', is the entire spectrum. The +region is specified as a starting value, a '-', and an ending value. +.le +.ls apodize = 0.2 +Fraction of endpoints to apodize with a cosine bell when preparing the data +prior to the FFT. +.le + +.ce +CORRELATION PEAK FITTING PARAMETERS +.ls function = "gaussian" +Function used to find the center and width of the correlation peak. +Possible choices are "gaussian", "parabola", "lorentzian", or "center1d". +If a parabola or center1d fit is selected then only the center is determined. +.le +.ls width = INDEF +Width of the fitting region in pixels. The fitting weights are +zero at the endpoints so the width should be something +like the expected full width. If INDEF, then the width is +set by the \fIheight\fR and \fIpeak\fR parameters. If other than INDEF, +this parameter will override the \fIheight\fR and \fIpeak\fR parameters. +It is recommended that an odd value of \fIwidth\fR be used to assure an +even number of pixels around the peak height. +.le +.ls height = 0. +The width of the fitting region is defined by where the correlation +function crosses this height starting from the peak. The height is +specified as either a normalized correlation level (this is like +the 'y' interactive key) or normalized to the peak. The type of +level is selected by the peak parameter. +.le +.ls peak = no +Measure the height parameter relative to the correlation peak value +rather than as a normalized correlation level? If yes, then \fIheight\fR +is a fraction of the peak height with an assumed base of zero. +.le +.ls minwidth = 3., maxwidth = 11. +The minimum and maximum widths allowed when the width is determined +from the height. +.le +.ls weights = 1. +Power of distance defining the fitting weights. The points used +in fitting the correlation peak are weighted by a power of the +distance from the center as given by the equation +.nf + + 1 - (distance / (width/2)) ** weights + +.fi +Note that a weight parameter of zero is equivalent to uniform weights. +The center1d fitting algorithm uses it's own weighting function. +.le +.ls background = 0.0 +Background level, in normalized correlation units, for a Gaussian or +Lorentzian fitting function. If set to INDEF, the background is a free +parameter in the fit. +.le +.ls window = 20 +Size of the window in the correlation plot. The peak will be displayed +with a window centered on the peak maximum and two times \fIwindow\fR +lags wide. +.le + +.ce +OUTPUT PARAMETERS +.ls output = "" +File name of file to which output will be written. If no file name is given +then no log files will be kept, but the user will be queried for a file name +if a write operation is performed. Text output will have a ".txt" sufix +appended, and the graphics metacode file will be appended with a ".gki" suffix. +.le +.ls verbose = "yes" +Print a verbose output record to the \fIoutput\fR file? The verbose output +will be a single line ~160 characters wide. The \fIfields\fR task may +be used to strip out selected columns. Non-verbose output is ~80 chars wide. +.le +.ls imupdate = "no" +Update the image header with the computed velocities? If set to yes, then +the image will be updated with the observed and heliocentric velocities +by adding the \fIrvkeywords.vobs\fR and \fIrvkeywords.vhelio\fR keywords +respectively. Two-dimensional spectra will have the keywords added with +the aperture number appended to the keyword. +.le +.ls graphics = "stdgraph" +Output graphics device. +.le + +.ce +CONTROL PARAMETERS +.ls interactive = "yes" +Process spectra interactively? +.le +.ls autowrite = "yes" +Automatically record the last fit to the log file when moving to the next +spectrum? If set to "no", the user will be queried whether to write the +results if no write was performed, and possibly queried for a file name +if \fIoutput\fR isn't set. +.le +.ls ccftype = "image" +Type of output to create when writing out the correlation function with +the ":wccf file" command. Possible choices are "text" which will be a +simple list of (lag,correlation_value) pairs, or "image" which will be an +IRAF image whose header would describe the lag limits and selected peak. +.le + +.ce +ADDITIONAL PARAMETER SETS +.ls continpars = "" +The processing parameters as described in the \fIcontinpars\fR named pset. +.le +.ls filterpars = "" +This is a parameter set defining the parameters to be used in filtering the +data prior to the correlation. +.le +.ls rvkeywords = "" +The image header keyword translation table as described in +the \fIrvkeywords\fR named pset. +.le +.ls observatory = "" +The observatory parameter set giving the location of the observation. These +values are used in the heliocentric correction routines. +.le +.ih +DESCRIPTION +\fIRvxcor\fR performs a Fourier cross-correlation on the input list of object +and template spectra. Object spectra may be either one or two dimensional +(in `echelle' or `multispec' format), and may be correlated against a one +or two dimensional template. If the template spectrum is only one dimensional +but the object is two dimensional, the template is used to correlate each of +the apertures specified by the \fIapertures\fR parameter. Two dimensional +templates will correlate corresponding apertures. + +If the input spectra are not dispersion corrected (DC-FLAG parameter missing +or less than zero) then only a pixel space correlation is done. This is +appropriate for a simple cross-correlation of images whether spectra or not. +If the spectra are dispersion corrected a log binned correlation is +performed and various radial velocity measurements are made. At a minimum, +a relative velocity between the object and template spectra are produced. +If the image headers contain sufficient information for heliocentric +velocity corrections (see help for \fBrvkeywords\fR), the corrections are +computed and possibly recorded in the image header. If the value of the +heliocentric velocity is returned as INDEF, the user may use the 'v' +keystroke to see the full results of the correlation, including errors +which occured causing the corrections to not be done. + +A number of operations may be performed to prepare the data for +correlation. If a linear wavelength dispersion is defined the spectra +are rebinned to a log-linear dispersion. The starting and ending wavelength, +the dispersion in log space, and the number of pixels are determined from +the template. If the \fIcontinuum\fR flag is set to sonething other than +"none", the object and/or template data will +be continuum subtracted using the fitting parameters found in the +\fIcontinpars\fR pset on input. The data is zeroed outside the sample +region specified by the \fIsample\fR parameter, the bias is subtracted, +and the ends apodized. If the \fIfilter\fR flag is set to something other than +"none", the data are Fourier filtered according to the parameters in +the \fIfilterpars\fR pset prior to the correlation computation. + +Once the correlation is computed, the maximum peak is found and fit +according to the \fIwidth\fR, \fIheight\fR and \fIpeak\fR parameters. +A small, unlabelled plot of the entire correlation function is +drawn above a larger, +expanded plot centered on the peak in a window of size specified by the +\fIwindow\fR parameter. The dashed lines in the small plot +show the limits of the expanded plot. The bottom axis is labelled with +pixel lag and, if dispersion information is present, the top axis +is labelled with relative velocity. The status line will contain a +summary of the pixel shift from the fit and optional velocity +information. The 'v' keystroke may be used to suspend graphics and get +a more detailed description of the correlation and fit. To view the +antisymmetric noise component of the correlation function, simply hit +the 'a' keystroke followed by any keystroke to return to the correlation +plot. Similarly, the 'e' keystroke may be used to preview the summary +plot of the correlation, again hitting any key to return to the correlation. + +If the user is dissatisfied with the fit to the peak, he can mark the +left and right side of the peak with the 'g' keystroke to redo the fit, +or else set the cursor to mark a cutoff with the 'y' keystroke, and all +points from the peak maximum to the cursor will be fit. To fix the background +of a Gaussian fit (i.e. change the \fIbackground\fR parameter graphically), +type the 'b' keystroke at the desired level. To choose a different +peak to fit, move the cursor to the top plot of the whole ccf and hit the +'z' keystroke at the desired peak. The plot will be redrawn with the new +peak now centered in the window and a fit automatically done. The 'r' +keystroke may be used at any time to redraw the plot, and the 'x' keystroke +can be used to compute a new correlation if any of the parameters relating +to the correlation are changed +(e.g. the apodize percentage). New correlations are automatically computed +when new images are read in, the data are continuum subtracted, a different +region is selected for correlation, or Fourier filtering is done. + +For binary star work, the user may type the 'd' and/or '-' keystrokes to fit +and then subtract up to four Gaussians to the peaks. This feature behaves +exactly as the deblending functions in the task \fIonedspec.splot\fR. Consult +the \fIsplot\fR help page for details. If multiple peaks were fit, +a separate entry +will be made in the log file for each peak with a comment that it was part of +a blended peak. The metacode file will contain only one summary plot with +each peak marked with it's heliocentric velocity (if velocities requested) +or pixel shift and error. + +To move to the next spectrum, simply hit the 'n' keystroke. Similary, +the 'p' keystroke will move to the previous spectrum. These commands +have a hitch, though. By default, the next/previous commands will move +first to the next template in the template image list. Once the end of the +template image list is reached, the next spectrum will be the next aperture +in the list specified by \fIapertures\fR, resetting the template image list +automatically and possibly updating the aperture in the template image +as well. Finally, after correlating all of the templates against +all of the apertures, the next/previous command will move to the next +object image, again resetting the template image and/or aperture list. +To override this sequence, the user may use the ":next" +or ":previous" commands and specify one of "aperture", "object", or +"template". If the \fIautowrite\fR is set, the results of the last +fit will be written to the log automatically. To write any one of the +fits explicity, use the 'w' keystroke. + +The \fIrvxcor\fR task also contains three submodes discussed in detail below. +Briefly, the 'f' keystroke will put the user in the "fourier mode", +where he can examine the Fourier transform of the spectra in various +ways and change/examine the filtering parameters. The 'o' and 't' +keystrokes let the user examine and fit the continuum for the object +and template spectra, respectively, using the \fBicfit\fR commands. +Upon exiting the continuum fitting the spectra are continuum subtracted +and a new correlation is computed. Finally the 's' keystroke will put +the user in "spectrum mode", in which he may graphically select the +region to be correlated, compute an approximate shift using the cursor, +or simply examine the two spectra in a variety of ways. All of these +submodes are exited with the 'q' keystroke, after which the correlation +will be redone, if necessary, and the ccf plot redrawn. + +To exit the task, the user simply types a 'q' keystroke. Results will be saved +to the logfile automatically if one was specified, otherwise the user will +be asked if he wants to save the results, and if so queried for a file name +before exiting if no \fIoutput\fR file was defined. + +(References: Tonry, J. and Davis, M. 1979 \fIAstron. J.\fR \fB84,\fR 1511, +and Wyatt, W.F. 1985 in \fIIAU Coll. No 88, Stellar Radial Velocities\fR, +p 123). + +.ce +CURSOR KEYS AND COLON COMMANDS + +.nf +? Print list of cursor key and colon commands +- Subtract blended component from correlation peak ++ Toggle status line output +a Display the antisymmetric noise component of the correlation +b Fix the background level for the Gaussian fit +c Plot polymarkers of actual CCF points on the plot +d Deblend multiple correlation peak +e Preview the summary plot of the correlation +f Fourier filtering and FFT display mode +g Mark correlation peak lag limits and fit +j Plot the residuals of the fit to the peak +k Plot the ratio of the fit to the peak +l Page the current logfile of results +n Go to next (template --> aperture --> object) +o Fit or refit object spectrum continuum for subtraction +p Go to previous (template --> aperture --> object) +q Quit task +r Redraw +s Examine object/template spectra and display mode +t Fit or refit template spectrum continuum for subtraction +v Print full correlation result in text window +w Write current correlation results to the log file +x Compute correlation +y Mark correlation peak lower limit and fit +z Expand on different correlation peak using full correlation plot + +:next [template|aperture|object] Go to next correlation pair +:parameters List current parameters +:previous [template|aperture|object] Go to previous correlation pair +:results [file] Page results + +Other colon commands set or show parameter values +.fi + +.ih +FOURIER MODE DESCRIPTION +Fourier mode is entered from the main task via the 'f' keystroke. By +default, the user is presented with a split plot of the power spectra of +the object and template spectra (object on top) and the requested filter +overlayed. The X-axis is double-labelled with wavenumbers on the bottom +and frequency on top. The ":log_scale" command can be used to toggle +the log scaling of the Y-axis of the plot, and the ":overlay" command +will toggle whether or not the filter function (if specified) is overlayed +on the plot. By default the entire power spectrum is displayed, but +the ":zoom" command may be used to specify a blowup factor for the +display (e.g. ":zoom 2" will display only the first half of the power +spectrum). Plot scaling parameters are learned for the next invocation +of this mode. + +The plot contents may also be changed through various keystroke commands. +The 'p' keystroke will display the power spectrum (the default), the 'f' +keystroke will display the two FFT's, and the 's' keystroke will display the +unfiltered and filtered spectra vertically offset. The 'b' and 'g' +keystrokes may be used to examine the power spectra and FFT's +respectively \fIbefore\fR filtering. The user can determine the period +trend in the data by placing the cursor at a particular wavenumber/frequency +and hitting the 'i' keystroke (this command will not work on a plot of +the filtered spectra). The 'r' key will redraw whichever plot is currently +selected and a 'q' will return the user to the main task mode. + +Colon commands are also used to specify or examine the filtering parameters +by simply typing a ':' followed by the parameter name found in +the \fIfilterpars\fR pset. The user still has full access to the colon +commands in the main task mode. + +.ce +CURSOR KEYS AND COLON COMMANDS + +.nf +? Print list of cursor key and colon commands +b Display power spectra before filtering +f Enter Fourier mode +g Display Fourier transforms before filtering +i Print period trend information +o Display filtered and unfiltered object spectrum +p Display power spectra after filtering +q Quit +r Redraw +s Display spectra +t Display filtered and unfiltered template spectrum +x Return to correlation mode + +:log_scale [yes|no] Set log scaling on Y axis +:overlay [yes|no] Overlay filter function +:parameters List current parameter values +:zoom [factor] Zoom x region + +Other colon commands set or show parameter values +.fi + +.ih +CONTINUUM MODE DESCRIPTION +Automatic continuum subtraction is controlled by the \fIcontinpars\fR +pset. These may be reset from the main +correlation function mode. To interactively fit and modify the continuum +fitting parameters the 'o' and 't' keys are used. This enters +the ICFIT package which is described elsewhere. Exiting the fitting, +with 'q', causes a recomputation of the correlation function and peak +fit. To view the flattened spectra use the spectrum review mode +entered with the 's' key. Fitting parameters changed while doing the +interactive continuum fitting are learned. + +.ce +CURSOR KEYS AND COLON COMMANDS + +See \fBicfit\fR. + +.ih +SPECTRUM MODE DESCRIPTION +Spectrum mode is entered from the main task via the 's' keystroke. +The user may select plots of the original input spectra 'i', the +continuum subtracted spectra 'n', and the filtered and unfilter spectra 'f'. +In addition, a sample region for the correlation is +marked on the bottom of the plots. To select a new sample region, use the 's' +keystroke to select the endpoints of the region. It may be selected +explicity by using the ":sample" command. The region will be checked to +see if it lies within the range of the spectrum. The 'd' keystroke may be +used to print the difference in pixels (and/or velocity) between two points +on the spectrum. This is useful for getting an approximate shift. +The 'w' keystroke or ":/<command>" commands will invoke the standard +GTOOLS windowing commands. +To return to the correlation simply type 'q'. + +(NOTE: More functionality is planned for this mode) + +.ce +CURSOR KEYS AND COLON COMMANDS + +.nf +? Print list of cursor key and colon commands +d Print velocity difference between two cursor positions +f Enter Fourier mode +i Display original input spectra +n Display continuum subtracted spectra +q Quit +r Redraw +s Enter Spectrum mode +w Window graphs with GTOOLS commands +x Return to correlation mode + +:sample [list] List of sample regions +.fi + +.ih +OUTPUT FILES +If the \fIoutput\fR parameter is set, two files will be created; one with +a ".gki" suffix containing metacode output of a summary plot, and one with +text output in the standard IRAF 'list' format containing either verbose or +non-verbose output +having a ".txt" suffix. If a write operation is performed and no output file +is specified, the user will be queried for a file name and the files will +be created. Text file output may be have selected columns extracted +using the iraf \fIfields\fR task (where string valued fields will have +blank spaces replaced with an underscore), and specific metacode plots may +be extracted or displayed with the iraf \fIgkiextract\fR and/or +\fIstdgraph\fR/\fIgkimosaic\fR tasks. +.ls METACODE FILES +For each correlation fit recorded a metacode plot will be drawn to the file +named by the \fIoutput\fR parameter with the ".gki" extension. This plot +will have a plot of the flattened object spectrum on top, with any selected +regions for the correlation marked. The bottom of the plot will be similar +to the standard correlation plot, but text will be overlaid showing the fitted +peak shift, width and computed velocities. + +For a blended peak, the plot will be the same with the exception that each of +the peak components will be labelled with the computed velocity, and the +text labelling will be suppressed. +.le +.ls TEXT FILES +For each correlation fit recorded a text entry will be written to the file +named by the \fIoutput\fR parameter with the ".txt" extension. Regardless +of whether the file contains verbose output, the file header will have comment +lines (beginning with a "#" in column 1) identifying each template used +with a letter code, followed by a description of the image name, template +source name, velocity dispersion (which will be the same for the object +spectra, and specified velocity. A similar comment will be written with +a unique ID whenever a new template image is read into the task interactively. +Similar comments will also be written to identify error codes, abbreviations +used, column headings, and the region used in the correlation. +.ls NON-VERBOSE OUTPUT +(NOTE: Details about field width and such will be worked out later on...) + +Non-verbose output will contain the object image name, object source name +(usually the star name), heliocentric Julian data, aperture number, +a code field identifying whether the data were +filtered, type of fitting function, and/or continuum subtracted, the pixel +shift (and error), velocity FWHM, observed velocity, heliocentric +velocity, and velocity error, as well as an error code field. + +This output will extend approximately less than 80 characters. +.le +.ls VERBOSE OUTPUT +(NOTE: Details about field width and such will be worked out later on...) + +Verbose text output will contain all of the above fields in the header. +Also written will be the Tonry & Davis "R" value, correlation peak height, +FWHM error, and covariance of the correlation. + +This output will extend approximately less than 160 characters. +.le +.le + +.ih +ALGORITHM DISCUSSIONS +.ih +SUMMARY OF THE BASIC TASK STRUCTURE +In this section we discuss the steps taken in preparing and filtering the +data prior to the correlation computation. We will use pseudocode to describe +this process as it is more detailed than the graphical display shown earlier. + +.nf +begin + # Data Rebinning on input + IF (DC-FLAG flag does not exist in object) + DC-FLAG(object) = -1 + IF (DC-FLAG flag does not exist in template) + DC-FLAG(template) = -1 + IF (DC-FLAG(object) * DC-FLAG(template) < 0) + Print error and go on to next correlation pair + ELSE { + IF (DC-FLAG exists in template header && DC-FLAG >= 0) + rebin data to log-linear dispersion + IF (DC-FLAG exists in object header && DC-FLAG >= 0) + rebin to log-linear using template wpc and npts values + } + + # Continuum normaliztion and data preparation + IF (continuum == "object" || continuum == "both") + fit and subtract the object continuum + IF (continuum == "template" || continuum == "both") + fit and subtract the template continuum + FOR (object and template spectrum) { + zero non-overlapping points + zero points outside sample region + subtract the bias + apodize remaining data + center in FFT array of length 2^N + normalize data by the number of FFT points + } + + # Do the Fourier filtering + compute the FFT of both object and template + IF (filter == "object" || filter == "both") + multiply specified filter by object FFT + IF (filter == "template" || filter == "both") + multiply specified filter by template FFT + + calculate the cross correlation + + # Get interactive use set up + display the ccf to the screen + select max peak in ccf + determine fit endpoints from "height" (and "nfit"/"threshold") params + Fit the selected peak + IF (sufficient header information) + compute heliocentric velocity from pixel shift + ELSE + compute only a relative velocity from pixel shift + print results to the status line + + # Process the interactive cursor commands + REPEAT { + # A few example commands + SWITCH (cursor command) { + : + CASE 'f': + enter Fourier mode + : + CASE 'o': + enter ICFIT for object spectrum continuum removal + : + CASE 's': + enter Spectrum mode + : + CASE 't': + enter ICFIT for template spectrum continuum removal + } + } +end +.fi +.ih +PEAK FITTING ALGORITHM +Determining the center of the cross correlation peak is the key step in +measuring a relative shift or velocity between the object and template. +The width of the correlation peak is also of interest for measuring +a line broadening between the two samples. Since people have different +preferences and prejudices about these important measurement a variety +of methods with a range of parameters is provided. + +In all cases one must specify the fitting function and a sample width; +i.e. the range of points about the correlation peak to be used in the +measurement. Note that the width defines where the fitting weights +vanish and should be something like the full width. For the CENTER1D +algorithm the maximum weights are at the half width points while for the +other methods greater weight is given to data nearer the center. + +The width may be specified in three ways. The first is as an actual +width in pixels. This is the most straightforward and is independent +of quirks in the actual shape of the peak. The second way is to find +where the correlation function crosses a specified height or level. +The height may be specified in normalized correlation units or as a +fraction of the peak height. The former is equivalent to the +interactive 'y' key setting while the latter may be used to select some +"flux" point. A value of 0.5 in the latter would be approximately the +full widht at half intensity point except that the true zero or base of +the peak is somewhat uncertain and one needs to keep in mind that the +weights go to zero at this point. Note that a level may be negative. +In this method the actual width may go to zero or include the entire +data range if the level fall above the peak or below the minimum of the +correlation. The minimum and maximum width parameters are applied to +constrain the fitting region. The last method is to interactively mark +the fitting region with the 'g' key. A note will be made in the logfile +if an inflection of the peak is found within the sample range, indicating +a possible second peak or binary component. + +There are four methods for determining the correlation peak position. +The CENTER1D algorithm has been heavily used in IRAF and is quite +stable and reliable. It is independent of a particular model for the +shape of the peak or the background determination and is based on +bisecting the integral. It uses antisymmetric weights with maxima +at points half way between the estimated center and the fitting +region endpoint. A parabola fit is also independent of background +determinations and also does not determine a width. It is included +because it is a common method of peak centering. + +The gaussian and lorentzian function fits are model dependent and +determine a center, width, and peak value. The background may also +be determined simultaneously but this extra degree of freedom +for a function which is not strictly gaussian or lorentzian may +produce results which are sensitive to details of the shape of the +correlation function. The widths reported are the full width at +half maximum from the fits. + +The parabola, gaussian, and lorentzian methods use weights which +vary continuously from 1 at the estimated center to zero at the +endpoints of the fitting region. The functional form of the +weights is a power law with specified exponent. A value of zero +for the exponent produces uniform weights. However, this is +discontinuous at the endpoints and so is very sensitive to the data +window. A value of one (the default) produces linearly decreasing weights. + +All these methods produce centers which depend on the actual +data points and weights used. Thus, it is important to iterate +using the last determined center as the center of the data window +with continuous weights in order to find a self-consistent center. +The methods are iterated until the center does not change by more +than 0.01 pixels or a maximum of 100 iterations is reached. + +Errors in the pixel shift are computed from the center parameter of the fitting +function. Velocity errors are computed based on the fitted peak height and +the antisymmetric noise as described in the Tonry & Davis paper (1979, +\fIAstron. J.\fR \fB84,\fR 1511). Dispersion/pixel-width errors are computed +similarly. + +The initial peak fit will be the maximum of the ccf. This will be the only +peak fit in non-interactive mode but a confidence level will be entered in +the logfile. In interactive mode, the user may select a different peak with +the 'z' keystroke, and the maximum peak within the specified \fIwindow\fR +(centered on the cursor) will be fit. The user has full control in interactive +mode over the points used in the fit. Once the endpoints of the peak have +been selected, the actual data points are shown with '+' signs on the ccf, +the fitted curve drawn, and a horizontal bar showing the location of the +FWHM calculation is displayed. The status line will show a summary of the +fit, and the user may type the 'v' keystroke for a more detailed description +of the fit and correlation. + +.ih +EXAMPLES +.nf + 1. Cross correlate a list of 1-dimensional object spectra against + three 1-dimensional template spectra, saving results automatically + and not continuum subtracting or filtering the data: + + rv> rvxcor.interactive = no # Do it in batch mode + rv> rvxcor obj* temp1,temp2,temp3 autowrite+ continuum="no" + >>> filter="no" output="results" + + 2. Compute a velocity for a list of apertures in a 2-dimensional + multispec format object image, using only one aperture of a multispec + image as a template: + + rv> rvxcor.interactive = no # Do it in batch mode + rv> rvxcor object.ms temp.ms[*,35:35] apertures="1-7,10,12-35" + + 3. Compute a velocity by fitting a fixed number of points on the peak, + using uniform weighting: + + rv> rvxcor obj temp width=8 weights=0. + + 4. Compute a velocity by fitting a Gaussian to the points on the ccf + peak above the 0.1 correlation level. Constrain the number of points + to be less than 15, and linearly decrease the weights: + + rv> rvxcor obj temp func="gaussian" width=INDEF height=0.1 + >>> maxwidth=15 weights=1. + + 5. Compute a velocity by fitting a Lorentzian to the peak, from the + peak maximum to it's half power point: + + rv> rvxcor obj temp func-"lorentz" width=INDEF height=0.5 peak+ + >>> maxwidth=15 weights=1. + + 6. Process a 1-dimensional object against a 1-dimensional template + interactively, examining the FFT, and input spectra to define a sample + region for the correlation: + + rv> rvxcor obj temp inter+ continuum="both" autowrite- output="" + Screen is cleared and ccf peak with fit displayed + + ... to refit peak, move cursor to left side of peak and type 'g' + ... move cursor to right side of peak and hit any key + + New fit is drawn and results displayed to the status line + + ... type the 'v' key for a detailed description of the correlation + + Graphics are suspended and the text screen shows various + parameters of the correlation and fit. + + ... type 'q' to get back to graphics mode + + ... to examine the FFT's of the spectra, type the 'f' keystroke. + + The screen is cleared and a split plot of the two power spectra + after filtyering is drawn with the requested filter overlayed. + ... type the 'f' keystroke + The screen is cleared and the absolute value of the two FFT's + after filtering is plotted, again with the filter overlayed. + ... type ":overlay no", followed by a 'g' keystroke + The spectra are redrawn prior to filtering, with no filter over- + lay + ... type 'q' to return to correlation mode + + The screen is redrawn with the ccf plot and peak fit + + ... type 's' to enter spectrum mode + + The screen is cleared and the the input spectra displayed + ... type 's' to mark the endpoints of a sample region for correl- + ... ation. Then type 'q' to quit this mode + + A new correlation is computed and the peak refit automatically + + ... type 'q' to quit the task, satisfied with the results + The user is asked whether he wants to save results + ... type 'y' or <cr> to save results + The user is prompted for an output file name since one wasn't + specified in the parameter set + ... type in a file name + + The task exits. +.fi + +.ih +TIME REQUIREMENTS +To be determined + +.ih +SEE ALSO +continpars, filterpars, observatory, rvkeywords, center1d +.bp +.endhelp diff --git a/noao/rv/doc/rvidlines.hlp b/noao/rv/doc/rvidlines.hlp new file mode 100644 index 00000000..2e87a412 --- /dev/null +++ b/noao/rv/doc/rvidlines.hlp @@ -0,0 +1,530 @@ +.help rvidlines Aug93 noao.rv +.ih +NAME +rvidlines -- Measure radial velocities from spectral lines +.ih +USAGE +rvidlines images +.ih +PARAMETERS +.ls images +List of spectral images in which to identify spectral lines and measure a +velocity. The spectra must be dispersion calibrated in Angstroms. +.le +.ls section = "middle line" +If an image is not one dimensional or given as a one dimensional image +section then the image section given by this parameter is used. The +section is used to define the initial vector and the direction (columns, +lines, or "z") of the image vectors to be fit. The image is still considered +to be two or three dimensional and it is possible to change the data vector +within the program. + +The section parameter may be specified directly as an image section or +in one of the following forms + +.nf +line|column|x|y|z first|middle|last|# [first|middle|last|#]] +first|middle|last|# [first|middle|last|#] line|column|x|y|z +.fi + +where each field can be one of the strings separated by | except for # +which is an integer number. The field in [] is a second designator +which is used with 3D data. See the example section for examples of +this syntax. Abbreviations are allowed though beware +that 'l' is not a sufficient abbreviation. +.le +.ls database = "database" +Database in which the feature data and redshifts are recorded. +.le +.ls coordlist = "" +User coordinate list consisting of an ordered list of rest spectral line +coordinates. If a line list is defined lines from the list may be +automatically found and added to the lines being measured. +.le +.ls nsum = "10" +Number of lines, columns, or bands across the designated vector axis to be +summed when the image is a two or three dimensional spatial spectrum. +It does not apply to multispec format spectra. If the image is three +dimensional an optional second number can be specified for the higher +dimensional axis (the first number applies to the lower axis number and +the second to the higher axis number). If a second number is not specified +the first number is used for both axes. +.le +.ls match = 5. +The maximum difference for a match between the measured line coordinate +and a coordinate in the coordinate list. The units of this parameter +is that of the user coordinates. +.le +.ls maxfeatures = 50 +Maximum number of the strongest features to be selected automatically from +the coordinate list (function 'l') or from the image data (function 'y'). +.le +.ls zwidth = 100. +Width of graphs, in user coordinates, when in zoom mode (function 'z'). +.le + +The following parameters are used in determining feature positions. +.ls ftype = "absorption" (emission|absorption|gemission|gabsorption) +Type of features to be identified. The possibly abbreviated choices are +"emission", "absorption", "gemission", and "gabsorption". The first two +select the \fBcenter1d\fR centering algorithm while the last two +select the Gaussian fitting centering algorithm. +.le +.ls fwidth = 4. +Width in pixels of features to be identified. +.le +.ls cradius = 5. +The maximum distance, in pixels, allowed between a feature position +and the initial estimate when defining a new feature. +.le +.ls threshold = 0. +In order for a feature center to be determined the range of pixel intensities +around the feature must exceed this threshold. +.le +.ls minsep = 2. +The minimum separation, in pixels, allowed between feature positions +when defining a new feature. +.le + +The following parameters control the input and output. +.ls logfile = "logfile" +Log file for recording the results of the velocity measurements. The +results are written when exiting or changing input images. The +results can be previewed with the ":features" command. If no log file +is specified then the results are not saved. +.le +.ls autowrite = no +Automatically write or update the logfile and database? If no then a query +is given for writing results to the logfile. A query for writing to the +database is also given if the feature data have been modified. If yes +exiting the program automatically writes to the logfile and updates the +database. +.le +.ls keywpars = "" +The image header keyword translation table as described in +the \fIkeywpars\fR named pset. This defines the header keywords used +to obtain the observation information needed for computing the +heliocentric velocity. +.le +.ls graphics = "stdgraph" +Graphics device. The default is the standard graphics device which is +generally a graphics terminal. +.le +.ls cursor = "" +Cursor input file. If a cursor file is not given then the standard graphics +cursor is read. +.le +.ih +ADDTIONAL PARAMETERS +The measured velocities are corrected to a heliocentric frame of reference +if possible. This requires determining various parameters about the +observation. The latitude, longitude, and altitude of the observation +are determined from the observatory database. The observatory is +defined by either the OBSERVAT image header keyword or the "observatory" +package parameter in that order. See the help for \fBobservatory\fR +for additional information. + +The date, universal time, right ascension, declination, and coordinate epoch +for the observation are obtained from the image header. The keywords +for these parameters are defined in the \fBkeywpars\fR parameter set. +Note that the parameters used are "ra", "dec", "ut", and "date-obs". +The "utmiddle" parameter is not used so if you have a keyword for the +middle of the exposure that you want to use then you must set the +"ut" parameter to reference that keyword. + +Before IRAF V2.12, if the date keyword included a time then that time was +used and the "ut" keyword was not used. In V2.12 this was changed and the +time is always taken from the keyword specified by "ut". However, the +value can be in either a single time or a date/time string. So if you +want to use both the date and time from the same keyword, say DATE-OBS, +then point the "date_obs" and "ut" parameters in KEYWPARS to the same +keyword. +.ih +CURSOR KEYS + +.nf +? Clear the screen and print menu of options +a Apply next (c)enter or (d)elete operation to (a)ll features +b Mark and de(b)lend features by Gaussian fitting +c (C)enter the feature nearest the cursor +d (D)elete the feature nearest the cursor +f (F)it redshift and velocity from the fitted and user coordinates +i (I)nitialize (delete features and coordinate fit) +j Go to the preceding image line/column/band/aperture +k Go to the next image line/column/band/aperture +l Match coordinates in the coordinate (l)ist +m (M)ark new feature near the cursor and enter coord and label +n Move the cursor or zoom to the (n)ext feature (same as +) +o Go to the specified image line/column/band/aperture +p (P)an to user defined window after (z)ooming on a feature +q (Q)uit and continue with next image (also carriage return) +r (R)edraw the graph +t Reset the position of a feature without centering +u Enter a new (u)ser coordinate and label for the current feature +w (W)indow the graph. Use '?' to window prompt for more help. +y Automatically find strongest peaks and identify them +z (Z)oom on the feature nearest the cursor +. Move the cursor or zoom to the feature nearest the cursor ++ Move the cursor or zoom to the next feature +- Move the cursor or zoom to the previous feature +I Interrupt task and exit immediately +.fi + +The parameters are listed or set with the following commands which may be +abbreviated. To list the value of a parameter type the command alone. + +.nf +:show file Show the values of all the parameters +:features file Write feature list to file (default STDOUT) + +:coordlist file Coordinate list file +:cradius value Centering radius in pixels +:threshold value Detection threshold for feature centering +:database name Database for recording feature records +:ftype value Feature type + (emission|absorption|gemission|gabsorption) +:fwidth value Feature width in pixels +:image imagename Set a new image or show the current image +:labels value Feature label type + (none|index|pixel|coords|user|both) +:match value Coordinate list matching distance +:maxfeatures value Maximum number of features automatically found +:minsep value Minimum separation allowed between features +:read name ap Read a record from the database + (name/ap default to the current spectrum) +:write name ap Write a record to the database + (name/ap default to the current spectrum) +:add name ap Add features from the database + (name/ap default to the current spectrum) +:zwidth value Zoom width in user units + +Labels: + none - No labels + index - Sequential numbers in increasing pixel position + pixel - Pixel coordinates + coords - User coordinates such as wavelength + user - User labels + both - Combination of coords and user +.fi +.ih +DESCRIPTION +\fBRvidlines\fR measures radial velocities from spectra by determining the +wavelength shift in spectral lines relative to specified rest wavelengths. +The basic usage consists of identifying one or more spectral lines (also +called features), entering the rest wavelengths, and computing the average +wavelength shift converted to a radial velocity. Additional lines can then +be automatically added from a coordinate list of rest wavelengths. + +Each dispersion calibrated image in the input list is examined in turn. If +the image is not one dimensional or a one dimensional section of an image +then the image section given by the parameter \fIsection\fR is used. This +parameter may be specified in several ways as described in the parameter +and examples sections. The image section is used to select a starting +vector and image axis. The parameter \fInsum\fR determines the number +of lines, columns, or bands to sum in a two or three dimensional image. + +Once a spectrum has been selected it is graphed. The graph title includes +the image name, spectrum title, and the current velocity and redshift if +one has been determined. An initial feature list is read from the database +if an entry exists. The features are marked on the graph by tick marks. +The features may also be labeled using the ":label" option. The graph has +the observed wavelength scale along the bottom and the rest wavelength +scale along the top (if a velocity has been determined). The status line +gives the pixel coordinate, observed wavelength, rest wavelength (as +computed by the last velocity computation), the true rest wavelength, the +velocity residual, and an optional identification string for the "current" +feature. + +The graphics cursor is used to select features and perform various +functions. A menu of the keystroke options and functions is printed with +the key '?'. The cursor keys and their functions are defined in the CURSOR +KEYS section and described further below. The standard cursor mode keys +are also available to window and redraw the graph and to produce hardcopy +"snaps". + +There are two types of feature selection functions; defining new +features and selecting previously defined features. The 'm' key marks +a new feature near the cursor position. The feature position is +determined by a centering algorithm. There are two algorithms; +a flux bisecting algorithm called \fBcenter1d\fR and a gaussian +profile fitting algorithm. The choice of fitting algorithm and whether the +feature is an emission or absorption line is set by the \fIftype\fR +parameter. + +The center1d algorithm is described in the help topic \fBcenter1d\fR. The +parameters which control it are \fIfwidth\fR, \fIftype\fR, \fIcradius\fR, +and \fIthreshold\fR. + +The gaussian fitting algorithm estimates a linear local background by +looking for the minimum or maximum, depending on whether the feature type +is set to absorption or emission, within a distance of the entered cursor +position of one-half the feature width specified by the \fIfwidth\fR +parameter plus the centering error radius specified by the \fIcradius\fR +parameters. This background estimation is crude but generally is not +critical for reasonably strong lines. Once the sloped background is +defined a non-linear Levenberg-Marquardt algorithm determines the gaussian +center, peak strength, and sigma. The initial estimates for these +parameters are the starting center, the background subtracted pixel value +at the starting center, and the \fIfwidth\fR value divided by six. After +fitting the gaussian model it is overplotted on the data for comparison. The +\fIthreshold\fR parameter also applies to this algorithm to check for a +minimum data range and the \fIcradius\fR parameter checks for a maximum +error in the center from the initial value. + +For a more critical setting of the background in the gaussian algorithm or +for the simultaneous solution of multiple gaussian components (deblending) +the 'b' key is available. The 'b' key is used to mark the initial +positions of up to ten features. The feature marking ends with 'q'. The +user is then queried to mark two points for the linear background. After +doing the simultaneous fitting the user is queried sequentially for the +rest wavelengths of each line. Note that the 'b' key will do the gaussian +fitting regardless of whether the \fIftype\fR setting is for a gaussian +or not and can be used for fitting just a single line. + +When a feature is defined the value of \fIftype\fR and \fIfwidth\fR are +associated with the feature. Subsequent recentering will use these values +even if the default values are changed. This is how a combination of +absorption and emission lines may be defined. The only constraint to this +is that the feature data does not record the combination of lines used in a +deblending operation so automatic recentering will treat each line +separately. + +When a new feature is marked if the wavelength is within a distance given +by the parameter \fIminsep\fR of a previous feature it is considered to be +the same feature and replaces the old feature. The coordinate list is +searched for a match between the measured wavelength, corrected to rest +using the current velocity, and a user coordinate in the list. The +matching is based on the nearest line within a specified \fImatch\fR +distance. If a match is found it becomes the default user coordinate which +the user may override. The new feature is marked on the graph and it +becomes the current feature. The redefinition of a feature which is within +the minimum separation may be used to set the user coordinate from the +coordinate list. The 't' key allows setting the position of a feature to +other than that found by the centering algorithms. + +If at least one feature is marked with it's rest wavelength specified then +the 'l' key may be used to identify additional features from a coordinate +list of rest wavelengths. First a velocity is computed from the initial +features. Then each coordinate in the list is corrected to the +observed velocity and a feature is sought in the data at that point. +Up to a maximum number of features, set by the parameter \fImaxfeatures\fR, +may be defined in this way. A new velocity is computed using all the +located features. + +The 'y' key provides another way to add features. Rather than look for +features at the coordinates of a list, a peak finding algorithm is used to +find features up to the specified maximum number. If there are more +peaks only the strongest are kept. The peaks are then matched against the +coordinate list to find user coordinate values. + +To select a different feature as the current feature the keys '.', 'n', +'+', and '-' are used. The '.' selects the feature nearest the cursor, the +'n' and '+' select the next feature, and the '-' selects the previous +feature relative to the current feature in the feature list as ordered by +pixel coordinate. These keys are useful when redefining the user +coordinate with the 'u' key and when examining features in zoom mode. + +The key 'f' computes ("fits") a velocity to the defined features. +This is done by taking a weighted average of the redshifts, + +.nf + z = (measured - true) / true +.fi + +of the individual lines. The default weights are always one but a different +weight may be entered with the 'u' key. The average redshift is +converted to a Cz velocity (redshift times the speed of light) and +corrected to a heliocentric frame if possible. + +The heliocentric correction requires observatory and observation information. +The observatory is determined either from the OBSERVAT keyword in the +image header or by the "rv.observatory" package parameter. For a +discussion of how an observatory is defined and used see the help +for \fBobservatory\fR. In addition to the observatory the right +ascension, declination, coordinate epoch, and date and time of the +observation are required. If the time is in the date string it has +precedence over the time keyword. This information is sought in the image +header using the keywords defined in the \fBkeywpars\fR parameter +file. If there is insufficient information for the heliocentric +velocity correction only the observed velocity will be given. The +type of velocity (both velocity and redshift) is indicated by +identifiers such as Vobs and Vhelio. + +Note that a new velocity is only computed after typing 'f', 'l', +":features", or when exiting and writing the results to the database. +In other words, adding new features or deleting existing features +does not automatically update the velocity determination. + +Features may be deleted with the key 'd'. All features are deleted +when the 'a' key immediately precedes the delete key. Deleting the +features does not reset the velocity. The 'i' key initializes +everything by removing all features and reseting the velocity. + +It is common to transfer the feature identifications and velocities +from one image to another. When a new image without a database entry +is examined, such as when going to the next image in the input list, +changing image lines or columns with 'j', 'k' and 'o', or selecting +a new image with the ":image" command, the current feature list and +velocity are kept. Alternatively, a database record from a different +image may be read with the ":read" command. When transferring feature +identifications between images the feature coordinates will not agree exactly +with the new image feature positions and several options are available to +reregister the feature positions. The key 'c' centers the feature nearest +the cursor using the current position as the starting point. When preceded +with the 'a' key all the features are recentered (the user must refit +the coordinate function if desired). As an aside, the recentering +function is also useful when the parameters governing the feature +centering algorithm are changed. An additional options is the ":add" +command to add features from a database record. This does not overwrite +previous features as does ":read". + +Note that when a set of spectra all have the same features in nearly +the same location the task \fBrvreidlines\fR may be used to reidentify +the lines and compute a new velocity. + +In addition to the single keystroke commands there are commands initiated +by the key ':' (colon commands). As with the keystroke commands there are +a number of standard graphics features available beginning with ":." (type +":.help" for these commands). The rvidlines colon commands allow the task +parameter values to be listed and to be reset within the task. A parameter +is listed by typing its name. The colon command ":show" lists all the +parameters. A parameter value is reset by typing the parameter name +followed by the new value; for example ":match 10". Other colon commands +display the feature list and velocities (:features), control reading and +writing records to the database (:read and :write), and set the graph +display format. + +The feature identification process for an image is completed by typing 'q' +to quit. Attempting to quit an image without explicitly logging the +results or recording changes in the feature database produces a warning +message unless the \fIautowrite\fR parameter is set. If this parameter is +not set prompts are given asking whether to save the results to the log +file and the database, otherwise the results are automatically saved. As +an immediate exit the 'I' interrupt key may be used. This does not save +the feature information and may leave the graphics in a confused state. + +The information recorded in the logfile, if one is specified, includes +information about the observatory used for heliocentric corrections +(to verify the correct observatory was used), the list of features +used in the velocity computation, the wavelength and velocity RMS, +and lines with the observed and heliocentric redshifts and velocities. +These lines include an error in the mean derived from the weighted +RMS and the number of lines used, and the number of lines. This output +format is designed so that if there are multiple velocities recorded +in the same log file they can be easily extracted with the match command: + +.nf + cl> match Vhelio logfile + im1 45 : Vhelio = 15.06 km/s, Mean err = 4.593 km/s, Lines = 7 + im1 40 : Vhelio = 17.77 km/s, Mean err = 3.565 km/s, Lines = 7 + im2 45 : Vhelio = 24.44 km/s, Mean err = 3.741 km/s, Lines = 7 + im2 40 : Vhelio = 14.65 km/s, Mean err = 11.2 km/s, Lines = 7 + ... +.fi +.ih +DATABASE RECORDS +The database specified by the parameter \fIdatabase\fR is a directory of +simple text files. The text files have names beginning with 'id' followed +by the entry name, usually the name of the image. The database text files +consist of a number of records. A record begins with a line starting with the +keyword "begin". The rest of the line is the record identifier. Records +read and written by \fBrvidlines\fR have "identify" as the first word of the +identifier. Following this is a name which may be specified following the +":read" or ":write" commands. If no name is specified then the image name +is used. For 1D spectra the database entry includes the aperture number +and so to read a solution from a aperture different than the current image +and aperture number must be specified. For 2D/3D images the entry name +has the 1D image section which is what is specified to read the entry. +The lines following the record identifier contain +the feature information and redshift (without heliocentric correction). + +The database files have the name "identify" and the prefix "id" because +these files may also be read by the \fBidentify\fR task for changing +the dispersion function based on the rest wavelengths. +.ih +EXAMPLES +1. The radial velocity of the spectrum, kstar1, is to be determined. +The user creates a list of line features to be used in the file +klines.dat. + +.nf + cl> rvidlines kstar1 coord=klines.dat + a. The spectrum is drawn + b. A line is marked with 'm' + c. Enter the rest wavelength + d. Compute a velocity with 'f' + e. Find other lines in the list with 'l' + f. Exit with 'q' + Write velocity data to the logfile (yes)? y + Write feature data to the database (yes)? y + cl> match Vhelio logfile + kstar1 1 : Vhelio = 25.1 km/s, Mean err = 1.123 km/s, Lines = 10 +.fi + +2. For echelle or multispec spectra the keys 'o', 'j', and 'k' may +be used to switch between spectra. Note that the inheritance of features +in echelle orders is not very useful. So the 'i' can be used to +initialize. For similar spectra the 'a''c' key combination may +be used to recenter all lines and the a new 'f' fit can be done. + +3. For images which are two or three dimensional it is necessary to +specify the image axis for the data vector and the number of pixels at each +point across the vector direction to sum. One way specify a vector is to +use an image section to define a vector. For example, to select column +20: + +.nf + cl> rvidlines obj[20,*] +.fi + +The alternative is to use the section parameter. Below are some examples +of the section parameter syntax for an image "im2d" which is 100x200 +and "im3d" which is 100x200x50. On the left is the section string syntax +and on the right is the image section + +.nf + Section parameter | Image section | Description + ------------------|---------------------|--------------------- + first line | im2d[*,1] | First image line + middle column | im2d[50,*] | Middle image column + last z | im3d[100,200,*] | Last image z vector + middle last y | im3d[50,*,50] | Image y vector + line 20 | im2d[*,20] | Line 20 + column 20 | im2d[20,*] | Column 20 + x 20 | im2d[*,20] | Line 20 + y 20 | im2d[20,*] | Column 20 + y 20 30 | im2d[20,*,30] | Column 20 + z 20 30 | im3d[20,30,*] | Image z vector + x middle | im3d[*,100,25] | Middle of image + y middle | im3d[50,*,25] | Middle of image + z middle | im3d[50,100,*] | Middle of image +.fi + +The most common usage should be "middle line", "middle column" or "middle z". + +The summing factors apply to the axes across the specified vector. For +3D images there may be one or two values. The following shows which axes +are summed, the second and third columns, when the vector axis is that shown +in the first column. + +.nf + Vector axis | Sum axis in 2D | Sum axes in 3D + ------------------|---------------------|-------------------- + 1 | 2 | 2 3 + 2 | 1 | 1 3 + 3 | - | 1 2 +.fi + +.ih +REVISIONS +.ls RVIDLINES V2.11 +This task will now work in the units of the input spectra. +.le +.ls RVIDLINES V2.10.3 +This is a new task in this version. +.le +.ih +SEE ALSO +center1d, fxcor, gtools, identify, keywpars, observatory, +rvcorrect, rvreidlines +.endhelp diff --git a/noao/rv/doc/rvpackage.spc b/noao/rv/doc/rvpackage.spc new file mode 100644 index 00000000..216f622b --- /dev/null +++ b/noao/rv/doc/rvpackage.spc @@ -0,0 +1,948 @@ +.EQ +delim $$ +.EN +.RP +.TL +Specifications for the Radial Velocity Analysis Package + +.AU +Michael J. Fitzpatrick +.AI +.K2 "" "" "*" +Revised January 1990 + +.AB +.PP +Specifications are presented for an IRAF package to compute radial velocity, +redshift and dispersion information from both one and two dimensional +IRAF images. Requirements and specifications for each necessary task are +described as well as the algorithms used. Specifications of user input +and program output are also discussed. Detailed manual pages of the tasks +are included following this document. +.AE + +.NH +Introduction +.PP +The following document describes the specifications for the radial velocity +package. This package will be designed to produce radial velocity, redshift +and dispersion data for both one and two dimensional images. To this end +both cross correlation and Fourier techniques will be employed, thus allowing +the user to choose the method of correlation best suited to his data. Since +the needs of the individual astronomer will differ, the tasks in this package +will use different algorithms for computation but will share some common +output. This common output may later be used to compare the results of one +method over another, or one parameter set over another. +.PP +Most radial velocity work is done by cross correlating a standard template star +with an unknown object spectrum. This is most often the case with a one +dimensional data set in which the value of interest is the heliocentric radial +velocity of the object star measured with respect to the template star +(which is usually a radial velocity standard of known velocity). Several + methods will be used to provide this information: +.IP \(bu +A standard Fourier correlation technique in which the data are transformed +and then mulitplied one by the complex conjugate of the other and reverse +transformed, thus procuding a normalized cross correlation function. +Filtering of the data while in Fourier space is allowed. Error calculations +are also better prepared because of the nature of the algorithms. +.IP \(bu +A squared difference method in which the sums of the squared difference between +the intensities of the two spectra are computed at each trial shift. This +produces an unnormalized function which may be used to compute a relative +shift and hence velocity. Restictions on this task will be rather loose +to allow it to be used more efficiently as a "quick-look" device. +.IP \(bu +A direct correlation method, identical in operation to the squared difference +task yet producing a normalized correlation function. +.LP +All of the resulting functions are fit with a user specified function +providing a more accurate velocity. The details of these functions and +relative merits of the methods are discussed below. +.PP +A second desire of astronomers using this package is to correlate a galaxy +spectrum against a standard template spectrum. While this may be done with +one dimensional data to produce a redshift value, it is often used with +two dimensional data in which the aim is produce a velocity dispersion of the +galaxy with respect to a distance \fIr\fR from the center. Using this +information at different position angles across the galaxy image, it is +possible to map a velocity field +within the galaxy, describing it's rotation. Again, two methods will be used +to provide this information. +.IP \(bu +A Fourier quotient method in which the ratio of the Fourier transforms of +the galaxy to the stellar spectra are fit to the Fourier transform of a chosen +broadening function, the results of which provide the velocity dispersion, +redshift, and relative line strength parameter. +.IP \(bu +A Fourier difference method in which the difference of the Fourier transforms +of the galaxy and star spectra are fit to the Fourier transform of a chosen +broadening function, the results of which provide the velocity dispersion, +redshift, and relative line strength parameter. +.LP +The details of these functions and methods and their relative merits +are discussed below. +.PP +Each of the tasks in this package will also act as an interactive parameter +editor, permitting the user to change task parameter values and immediately +examine the effect on the data. The user may then save these parameters for +a batch (non-interactive) run or process each of the images individually. +.PP +Although it will be generally assumed that the data have been prepared using +other applications available within IRAF, a limited set of data preparation +commands will be available within each of the major tasks. (A more in depth +description of these tasks is found below.) These commands will perform the +following functions: +.IP \(bu +Filtering of the data while in Fourier space. Often times it may be necessary +to filter certain frequency components from the data that may artificially +weight the correlation. A choice of filter functions will be available and +the user may specify the fourier components over which the filter will operate. +.IP \(bu +Removal of a local continuum. While this task is easily accomplished with +either the \fICONTINUUM\fR task or selective filtering, it is sometimes +desireable to remove a continuum from the data at this step of the analysis. +The user specifies the order of a polynomial or spline to be fit to the +data to remove low frequency trends in the data. This fitted function may be +either subtracted or divided from the data. +.IP \(bu +Masking of regions to be used in the correlation. To exclude sparse +line regions, +bad pixels, or telluric features, it will sometimes be necessary to input a +specific region to be used in the correlation. The user is able to specify in +either pixel number or wavelength the regions to be included in the +correlation. Since a broad error in the chip or wide feature may weight the +continuum fitting, continuum fitting will also take advantage of regions via +the \fICONTINUUM.SAMPLES\fR parameter. + +.NH +Input Requirements and Specifications +.PP +The following requirements and specifications will be met with regard +to input format to all of the tasks: +.IP \(bu +The object and template stars may both be specified as lists. Both lists +may be positioned forward and backward from interactive operation with a colon +command. In interactive mode the user is required to position each list +separately. In batch mode each object spectrum is correlated to each +template in the list before moving on to the next object. +.IP \(bu +The user may specify an aperture list to be used in the correlation. +This aperture list will be used in both the object and template spectrum. +It may be used to specify an echelle order or simply the row number in +a two dimensional image to be used if for some reason data have been stacked. +In the case of a two dimensional object/template spectrum and it's one +dimensional counterpart, the aperture number will apply only to the two +dimensional data. +.IP \(bu +The new IRAF echelle and multispec formats will be supported. +.IP \(bu +Data are required to be binned linearly in logarithm of the wavelength for +Fourier tasks. The squared difference or direct correlation +task may use either log-wavelength, +wavelength, or pixel scaled data. For pixel scaled data, output will +contain only pixel shift information since velocity information cannot be +computed. Data may be rebinned automaticall with the appropriate task through +use of the \fIPROCESSPARS\fR pset (see below). +.KS +.IP \(bu +The following information must be contained in each object image header in +order for the heliocentric correction to be done properly: +.nf +.ta 1i 2i 3i + ra - Right Ascension of object + dec - Declination of object + date-obs - UT Date of observation + ut - UT time of observation + epoch - Epoch of observation + exptime/otime - Exposure time of frame + w0/crval1 - Starting wavelength in Angstroms or log(Angstroms) + wpc/crdelt1 - Wavelength increment in Angstroms or log(Angstroms) +.fi +Keyword translation is handled by the \fIRVKEYWORDS\fR pset as discussed +below. Warning messages will be issued for missing keywords, which may +affect the accuracy of the results. +.KE +.IP \(bu +The user may input a number of rows that will be averaged according to +user specifications to be used in the correlation for the \fIXCOR2D\fR +task. For two dimensional data it may be desired to average a number of +rows into bins for computation rather than doing each row independantly. +Presently the template spectrum is assumed to be a one dimensional spectrum, +if not only the first row will be used in the correlation. +.IP \(bu +The \fIMKBINS\fR task may be used to create bins of approximately equal +intensity. A description of this task and the database structure used +is described below. + +.NH 2 +Rebinning of Input Data +.PP +Input data should be dispersion corrected, and while certain tasks require that +the data be presented on a logarithmic scale, it shall be possible to input +data which are not logarithmically binned. In this case, and if required by the +task, the data shall be rebinned automatically from the data I/O routines using +the same (or equivalent) starting wavelength and wavelength per channel values. +An informational message will be enetered into the log file indicating that +the data have been rebinned. +.PP +The parameters controlling data rebinning will be retrieved from +the \fIprocesspars\fR pset and the image header. The interpolation function +may be changed with the \fI:rb_func [s_value]\fR command followed by +a \fI:rebin\fR command to perform the action. This ability will be common to +all tasks. When data have been rebinned, a note will be made to the log file. +In batch operation of any task, the data will be rebinned automatically if +required and the appropriate notes made to the log file. +.PP +The \fIw0\fR, \fIwpc\fR and \fInpts\fR parameters will be obtained from the +current image header in the \fIprocesspars\fR value is INDEF, otherwise these +may be set to overide the current value. +.PP +If the user is not satisfied with rebinning the data using the current +dispersion or number of points, the \fIdo_rebin\fR parameter should be turned +off and the data rebinned outside the task using one of the other available +tasks. If \fIdo_rebin\fR is disabled and data must be rebinned, the task +will abort with an error message. +.NH 2 +Continuum Removal From the Data +.PP +It shall be possible for the user to continuum normalize the data in a manner +identical to that done by the \fIonedspec.continuum\fR task. The data +input to the Fourier tasks should be normalized by subtracting the continuum +and dividing by the average to get a mean of zero with excursions of order +unity. The \fIrvfquot\fR and \fIrvfdiff\fR tasks need to know the value of the +spectrum average in order to compute the photon counting statustucs before +normalization so it is advised that continuum +normalization be left to the task (i.e. use the normalization commands +available in the tasks as opposed to the \fIcontinuum\fR task) +The apodized, normalized spectrum may be previewed by issuing a \fI:cont\fR +command to do the normalization and a \fIn\fR keystroke to show a split-plot +of the flattened data +.PP +Interactive flattening of the data behaves exactly like the \fIcontinuum\fR +task, except that the data are divided by the average once the continuum has +been subtracted. If the \fIprocesspars.type\fR parameter is set to "ratio" +then the data will be normalized to a mean of unity and will not be divided +by the average. + +.NH +Output Requirements and Specifications +.PP +Output from the tasks will take the form of either graphics drawn to the +standard graphics device, metacode to a graphics spool file, or text +(sometimes verbose) output to a spool file and the screen (the abridged +version). With the exception of the pset tasks, all other tasks in this +package may have graphics and or text output. +.NH 2 +Graphics Output +.NH 3 +Graphics Metacode +.PP +The simplest graphical output from the tasks \fIrvfquot\fR and \fIrvfdiff\fR, +will be metacode for the quotient or difference plots (if the \fIfit_plot\fR +or \fIdiff_plot\fR parameters are set) and the FFT's of the data (if +the \fIfft_plot\fR parameter is set). +The simplest graphical output from the tasks \fIrvsqdiff\fR and \fIrvxcor\fR +gin + +will be metacode of the correlation plot and it's fitted function (s) directed +to a user named spool file. +.PP +Metacode from the \fIrvdisp\fR task will be written to a user defined file +and consist only of the computed dispersion curves and fit. +.PP +These plots may later be viewed with the \fIgkimosaic\fR task to quickly view +the results of a batch process. Each time the user uses either the 'g' or 'y' +commands to fit to new points, metacode for the new fit will also be written. +.NH 3 +Standard Graphics Plots +.PP +Plots drawn to the screen from the four main cross correlation tasks will +consist of the following: +.IP \(bu +An overplot of the two spectra upon task startup and every time a new image +is read (except when the \fIspec_plot\fR parameter is set). The mean of the +data will be normalized to unity to allow for the overplotting of the two +spectra, which may be at different intensity scales. The mean is used instead +of the maximum so that cosmic ray events will not affect the plotting. +.IP \(bu +A plot of the Fourier transform of each spectrum to aide the user in choosing +a proper filter. This plot will be generated for each spectrum's transform +and shown to the user by typing the 'f' command. After viewing the plots +the user may issue commands to select an appropriate filter. +.IP \(bu +A graph of the fitting function. The fitted function will be overplot on the +correlation function once the endpoints have been selected and the fit +completed. This plot is also written to the metacode file if specified. +.IP \(bu +For the tasks \fIrvxcor\fR and \fIrvsqdiff\fR a correlation plot produced +by those methods. This plot is also written to the metacode file if specified. +.IP \(bu +For the \fIrvfquot\fR task a plot of the ratio of the galaxy to stellar +spectrum projected onto a unit vector $exp(-2 pi i k zeta / n)$ where $zeta$ +is the logarithmic redshift. For two dimensional galaxy spectra, +each bin will produce a quotient plot if the \fIquot_plot\fR parameter +is set. +.IP \(bu +For the \fIrvfdiff\fR task a plot of the difference of the galaxy and stellar +spectrum. For two dimensional galaxy spectra, +each bin will produce a difference plot if the \fIdiff_plot\fR parameter +is set or a summary plot if the \fIsummary_plot\fR parameter is set. +.NH 2 +Text Output +.PP +Text output to the logfile common to each task will be the following: +.IP \(bu +An optional header explaining the meaning of each parameter if the \fIheader\fR +parameter is set. +.IP \(bu +The initial parameters of the reduction, one to a line consisting of a +'#P' in the first two columns identifying the line as a parameter, the +parameter name, and it's value. Each time a parameter is changed from the +command loop, a new line will be written to the log file showing the new +value of the parameter. +.IP \(bu +A keyword formatted the same as the parameter line identifying the +image name (IMAGE), the object name (OBJECT), the template image +name (TEMPLATE), the bin number used (BIN_NO), the correlation or +reduction method (CORM) and the fitting function used (FITF). +.IP \(bu +A date/time string identifying the date/time of reduction. +.IP \(bu +Any error or warning messages issued from the task. +.IP \(bu +A data record containing values input to or computed by the task. +For the \fIrvxcor\fR and \fIrvsqdiff\fR tasks, the data record will +contain: +.RS +.IP \(bu +Heliocentric Julian Date +.IP \(bu +Computed pixel shift and error of fit to CCF +.IP \(bu +FWHM of CCF peak in pixels +.IP \(bu +Height of the peak +.IP \(bu +Observed radial velocity +.IP \(bu +Heliocentric radial velocity +.IP \(bu +The derived velocity dispersion. +.IP \(bu +Comments of reduction, identifying errors or trouble spots. +.RE +For the \fIrvfquot\fR and \fIrvfdiff\fR tasks, the data record will +contain: +.RS +.IP \(bu +Heliocentric Julian Date +.IP \(bu +Observed redshift, line strength parameter and dispersion +.IP \(bu +Heliocentric redshift +.IP \(bu +Error of fit to difference or quotient +.IP \(bu +Comments of reduction, identifying errors or trouble spots. +.RE +.NH 2 +Database Records +.PP +Dispersion calculations require that the solution from fitting the +dispersion curve (i.e. a curve produced by convolving Gaussians +of known width with stellar spectra and comparing the input gaussian +width with the derived correlation peak width) be used by the \fIrvxcor\fR +and \fIrvsqdiff\fR tasks to convert the derived correlation peak widths +to true dispersions. Since this is usually done empirically, the +task \fIrvdisp\fR will be used to convolve a stellar spectrum with +user specified widths and fit the resulting curve with a polynomial +of order $n$. The parameters used to create this curve as well as the +coefficients of the polynomial will be written in the form of a database +record. +.PP +The name of the database file may then be passed to either the \fIrvxcor\fR +or \fIrvsqdiff\fR tasks which will use the coefficients to convert +the correlation widths. The correlation tasks will also check each +record in a file to find one in which the parameters used for the +dispersion curve calculation match those used for the correlation. +Failing a match of parameters, no dispersion calculation will be done, however +a velocity value of the FWHM width will be printed. +Changing parameters in a task will also force a search search for a new +record to match the parameters. +.PP +Below is an example database record used by the \fIrvdisp\fR, \fIrvxcor\fR +and \fIrvsqdiff\fR tasks. +.nf + + #T Aug 31 14:50 + begin + image star001 + object HR1762 + corrfunc fourier + fitfunc parabola + filterpars + filter yes + filtertype hanning + cuton 5 + cutoff 150 + fullon 0 + fulloff 0 + apodize 0.1 + order 4 + vstart 10.0 + vincrement 5.0 + npts 10 + coeffs 4 + 0.21345 + 0.82548 + 0.02345 + 0.00342 +.fi + +.NH +Interactive Parameter Editing +.PP +One common trait of all the tasks is the ability to change +the value of parameters interactively using colon commands. The user +is able to evaluate the result of each parameter change and then decide +on the best value for his reduction. The basic idea is to allow the user to +examine the effects of different parameter values on a typical set of +data and then process the input list with the chosen parameters. The other +envisioned use is of an astronomer that has completely different data and +wishes to reduce each star individually. +.PP +One other point that should be noted is the interaction of parameters between +tasks in the package. For instance, the filtering parameters set by +the \fIfilterpars\fR pset are used by the \fIrvdisp\fR, \fIrvxcor\fR +and \fIrvsqdiff\fR tasks. Similarly, parameters used in the \fIrvdisp\fR +task should match as closely as possible those used in the correlation +tasks since the computation of the dispersion value relies on the fit +to the dispersion curve (which may or may not be the same for different +parameters). For this reason, many of the colon commands will be the +same between different tasks. +.PP +The \fI':update'\fR command is provided to save the chosen parameters to the +task or pset parameter files. +This command will also update the \fIfilterpars\fR +pset if given an argument of 'filter' (likewise for the other package psets). +Similarly, the \fI':unlearn'\fR command is provided to +reset the parameters to their default values. It should, however, be used +with care and as a last resort to reset the parameters to their defaults. +Each time a parameter is changed which will affect the output, a note is made +in the spool file reflecting the new parameter value. + +.br +.NH +Use of Parameter Sets in the Package +.PP +.NH 2 +Image Header Keyword Translation +.PP +The following parameters control translation of image header keywords. If +the exposure time for the frame is given by the "EXPTIME" keyword in your +image header, as opposed to the "OTIME" keyword, just change the value of +the keyword. +.nf + + (ra = "RA") Right Ascension keyword + (dec = "DEC") Declination keyword + (ut = "UT") UT of observation keyword + (exptime = "OTIME") Exposure time keyword + (epoch = "EPOCH") Epoch of observation keyword + (date_obs = "DATE-OBS") Date of observation keyword + (w0 = "W0") Starting wavelength keyword + (wpc = "WPC") Wavelength per channel keyword\n + (hjd = "HJD") Heliocentric Julian date + (vobs = "VOBS") Observed velocity keyword + (vhelio = "VHELIO") Heliocentric velocity keyword + (vlsr = "VLSR") LSR velocity keyword +.fi +.NH 2 +Processing Parameters +.PP +The following parameters control operation of the continuum removal and +data rebinning. INDEF values in the rebinning parameters indicate that +those values should be obtained from the image header. +.nf + (do_cont = yes) Do continuum normalization? + (interactive = no) Fit continuum interactively? + (type = "difference") Type of output (diff|ratio) + (sample = "*") Sample of points to use in fit + (naverage = 1) Number of points in sample averaging + (function = "spline3") Fitting function + (order = 1) Order of fitting function + (low_reject = 2.) Low rejection in sigma of fit + (high_reject = 2.) High rejection in sigma of fit + (niterate = 10) Number of rejection iterations + (grow = 1.) Rejection growing radius + (scale_conser = yes) Maintain scale of input image. + (obj_only = no) Normalize only object image? + + (do_rebin = yes) Rebin data if necessary? + (interp_mode = "poly5") Rebin interpolation method + (rb_order = 1) Order of fitting function + (w0 = INDEF) Starting wavelength + (wpc = INDEF) Wavelength increment + (npts = INDEF) No. of output points + + (ccf_output = "ccfdemo") Output file/image name for ccf dump + (out_type = "image") Type of output file to create + (out_axis = "lag") X-axis for output + +.fi +.NH 2 +Filter Parameters +.PP +The following parameters control filtering of the data while in Fourier +space. +.nf + + (filter = yes) Filter the data before correlation? + (filt_type = "ramp") Filter window type + (cuton = 1) Cuton wavenumber for filter + (cutoff = 100) Cutoff wavenumber for filter + (fullon = 10) Wavenumber at which filter reaches one + (fulloff = 200) Wavenumber at which filter reaches zero +.fi +.NH 2 +Fourier Plotting Parameters +.PP +The following parameters control filtering of the data while in Fourier +space. +.nf + (plot = "amplitude") What form of FFT plot? + (overlay = yes) Overlay the filter function on the plot? + (split_plot = yes) Produce a split plot on the screen? + (one_image = "object") What image is plotted if one screen + (when = "before") Plot FFT before or after filtering + (log_scale = yes) Plot on a log scale? + (x_axis = "frequency") What is the x-axis scaling? + (fft_zoom = 4.) Zoom factor if not displaying whole FFT +.fi + +.NH +Cross Correlation and Fourier Techniques Used +.PP +The requirements and specifications of the correlation and Fourier techniques +to be used are described below along with the gory detail of the algorithms +themselves. +.NH 2 +Requirements and Specifications +.LP +The cross correlation techniques used must provide the following operations: +.IP \(bu +Each one dimensional correlation must produce a value of the relative shift +between the object and template spectrum. +.IP \(bu +Each value of the shift derived from the correlation function shall have an +error estimate attatched to it. +.IP \(bu +Each correlation method must be independant of the data format (i.e. longslit +data which have been averaged into rows, echelle orders, or aperture numbers). +.IP \(bu +There shall be no restriction on the length of the data to be operated upon. +.IP \(bu +The user shall be able to control the range over which the resulting +correlation function is useful. For example, the user may filter out +wavenumbers that are not to be used in the correlation, adjust the range +over which a shift will be searched, or control the number of points in the +correlation function to be fit. +.LP +The following correlation methods will be made available by the package: +.IP \(bu +A squared difference method in which an unnormalized correlation function is +produced by summing the squared difference between the object and template +spectra at a given trial shift. +.IP \(bu +A standard Fourier correlation method in which the data are transformed and +one multiplied by the conjugate of the other and the resultant inverse +transformed to produce a normalized correlation function. +.IP \(bu +A Fourier quotient method in which a galaxy and stellar spectrum are transformed +and their ratio fit to a broadening function, the parameters of which will +describe the relative line strength, velocity dispersion and redshift of +the galaxy spectrum. +.IP \(bu +A Fourier difference method in which a galaxy and stellar spectrum +are transformed and their difference fit to a broadening function, the +parameters of which will describe the relative line strength, velocity +dispersion and redshift of the galaxy spectrum. +.NH 2 +Algorithms +.PP +The basic specific algorithms to be employed are briefly described below. +.NH 3 +Fourier Cross Correlation +.PP +The Fourier cross correlation is to be done in the standard way: The object +and template spectrum are transformed into Fourier space and once there the +object transform is multiplied by the complex conjugate of the template +transform. The resultant is then inverse transformed back to real space +producing a normalized cross correlation function, the peak of which is +at a lag corresponding to the pixel shift between the two spectra. +The error computation +and the algorithm in general will follow the work of Tonry & Davis (1979, +Ast. J, \fI84\fR, 1511). +.NH 3 +Squared Difference Correlation +.PP +This method is most commonly known at NOAO as "Daryl's program" but actually +was described by Weiss et al (1978, Astron. Astrophys., \fI63\fR, 247). The +method works as follows: +.EQ + d sub j ~=~ sum from i=n1 to n2 (x sub i ~-~ y sub i+j ) sup 2 +.EN +where $x sub i$ denotes the intensity of the reference spectrum and $y sub i+j$ +denotes the intensity of the object spectrum at a trial shift $j$. +The resulting $d sub j$ array produces a curve whose minimum is at the pixel +shift between the two spectra. Unfortunately, this method produces an +unnormalized correlation function, thus making an estimate of the quality +of the correlation impossible. +.NH 3 +Fourier Quotient Method +.PP +This method was first described by Sargent et al (1977, Astrophys. J, \fI212\fR, +326) and is still a useful method for obtaining velocity dispersions in +galaxies. It is assumed that the galaxy spectrum is a convolution of an +appropriate mean stellar spectrum with a Doppler broadening function. +From the convolution theorem then, the +Fourier transform of the galaxy spectrum would be the product of the transform +of the stellar spectrum with the transform of the broadening function. The +broadening function is usually assumed to be a Gaussian characterized by a +dispersion $sigma$ and a redshift $z$. +By computing the transforms of the galaxy and template (stellar) spectra, it is +possible to fit the ratio of the galaxy transform to the stellar transform, +adopting the values of $sigma$ and $z$ which yield the best fit. +.PP +Therefore, from the definition of the discrete Fourier transform +F(k) of a function F(j), we find that the broadening function is described +in terms of the transforms of the galaxy spectrum G(j) and the +star spectrum S(j) as +.EQ + { G tilde (k) } over { S tilde (k) } ~~=~~ gamma~ exp left [ - 1 over 2 +left ( {2 pi ks} over n right ) sup 2 ~+~ { { 2 pi k zeta} over n } right ]~~ ; +.EN +.EQ + s ~==~ sigma over { c~ DELTA~ ln lambda} ,~~~~~~~ + zeta ~==~ { ln (1 + z) } over { DELTA~ ln lambda } +.EN +The parameters \fIs\fR and $zeta$ +are the velocity dispersion and logarithmic redshift measured in pixels +respectively. The parameter $gamma$ +is a normalization factor which measures the strength of the galaxy lines +with respect to the stellar lines. +.NH 3 +Fourier Difference Method +.PP +The Fourier difference method is similar to the quotient method in the +assumption that a galaxy spectrum can be treated as a mean stellar spectrum +convolved with a broadening function. It does, however, try to remedy +the inherent deficiency of weighting certain points too heavily that +appears in the Fourier Quotient method. The Fourier difference method is +best described by noting that the galaxy and stellar spectra are fit to +each other rather than to the broadening function, thus making the error +analysis more straightforward. If the noise in the stellar spectrum +is negligable, however, then the two methods are comparable. +.PP +For a given galaxy spectrum \fIG\fR, a stellar spectrum \fIS\fR, and a +broadening function \fIB\fR, we wish to minimize the residual in the Fourier +domain denoted +by +.EQ + chi tilde sup 2 ~=~ sum from j=0 to N-1 ~( G tilde "" sub j sup * ~-~ +B tilde "" sub j sup * G tilde "" sub j sup * )~( G tilde "" sub j ~-~ +B tilde "" sub j G tilde "" sub j ) +.EN +Where $G tilde$, $S tilde$, and $B tilde$ are the Fourier transforms of +the galaxy, star, and broadening function respectively. +This should simplify the numerical fitting because the convolution is now +a simple multiplication in Fourier space. + +.NH +Remaining Task Algorithms +.PP +\fBNOTE:\fI At this writing, the details of these algorithms are not +yet defined.\fR +.NH 2 +Telluric Line Removal +.PP +A task shall be written to automatically remove telluric or other artificial +features. The cross correlation techniques will be employed to compute the +relative shift between the object and template spectra. The relative line +depths will also be computed and the spectra divided to remove the lines +in the template spectrum from the object spectrum. +.NH 2 +Fitting (Emmision) Line Profiles +.PP +A task shall be written to do line profile fitting for the purpose of velocity +analysis. It will be possible to trace the various profile parameters (center, +width, etc) and derive velocity information. This task may also be used to +do postprocessing of the correlation function. + +.NH +Filtering of the Data in Fourier Space +.PP +To remove noise in the data once it has been transformed into the Fourier +domain, it must be possible to filter out unwanted frequencies from the data. +Filtering the data in the Fourier domain by attenuating or eliminating +certain frequencies has the same effect as smoothing the data in real space. +Since the data are assumed to be binned linearly in log wavelength, no +phase shifts are introduced by the filtering. +.NH 2 +Requirements and Specifications +.LP +The following filtering requirements must be met +.IP \(bu +A choice of filtering functions must be made available to the user. +.IP \(bu +The user must specify the wavenumbers over which the filter will operate. +.IP \(bu +The data must be binned linearly with the logarithm of the wavelength so as +not to introduce any phase shifts when filtering. +.IP \(bu +Filtering of data must be possible from any of the tasks using Fourier +techniques. +.IP \(bu +Those wavenumbers outside the specified cuton and cutoff numbers will be set to +zero, while those inside the range will be attenuated according to the +filter function chosen. +.IP \(bu +The specified range over which the filter extends must be the same for both the +object and reference spectrum. +.LP +The following filtering functions will be made available to the user: +.IP \(bu +\fBSquare\fR - A square step function in which the user specifies the +beginning and ending wavenumbers. +.IP \(bu +\fBRamp\fR - A ramp function in which the user must specify the cuton +wavenumber, the wavenumber at which the filter reaches full value, the +wavenumber at which the filter begins to decline and the cutoff wavenumber. +.IP \(bu +\fBHanning\fR - The user must specify the cuton and cutoff wavenumbers. +The data are attentuated according to the function: +.EQ +w sub j ~=~ 1 over 2 left [ 1. ~-~ cos left ( { 2 pi j } over { N-1 } right ) right ] +.EN +.nf +.na + where j = (wavenumber - cuton_wavenumer) + N = (cutoff - cuton) + 1 +.ad +.fi +.IP \(bu +\fBWelch\fR - The user must specify the cuton and cutoff wavenumbers. +The data are attentuated according to the function: +.EQ +w sub j ~=~ 1 ~-~ left [ { j ~-~ 1 over 2 ( N - 1 ) } over { 1 over 2 ( N + 1 ) } right ] sup 2 +.EN +.nf +.na + where j = (wavenumber - cuton_wavenumer) + N = (cutoff - cuton) + 1 +.ad +.fi + +.NH +Dispersion Calculations +.PP +Often times when computing the velocity dispersion from a correlation function, +the simplest thing to be done is to convert the full width at half maximum +(FWHM) of the fitted peak to a velocity. However, this is not fully correct +since the width of the correlation function is "an average of the widths of +galaxy lines quadratically added to the widths of template lines, and is +therefore the quadratic sum of two stellar widths and the velocity broadening +width". If the function fit to the peak is a polynomial (e.g a parabola), +what is required is a method in which to convert a simple FWHM pixel width of +the ccf to a true dispersion. +.PP +When the correlation peak is fit and a width determined, we must define +a relationship between the width $w$ and the width of a Gaussian profile +(the intrinsic dispersion), $gamma$. For a given fit to the +peak, this can be expressed (following Tonry & Davis) as +.EQ +gamma ~=~ f(w) ~=~ s sub 1 ~+~ s sub 2 w ~+~ s sub 3 w sup 2 ~+~ s sub 4 w sup 3 +.EN +.LP +The coefficients for this function are computed by empirically convolving +Gaussians of known velocity width with stellar spectra, thus producing +a plot of dispersion versus width which can be fit to obtain the coefficients +of the polynomial. +It must be remembered that the coefficients $s sub i$ must be recalculated +at each new instrumental setup since the function $f(w)$ is used to also +remove the instrumental distortions that can be caused by varying slit widths. +.PP +The \fIrvdisp\fR task may be used to compute the polynomial coefficients +and produce a database record of the input parameters and coefficients +that will be used bythe correlation tasks. Multiple records per file +are permitted, allowing for varying instrumental setups and parameters since +the correlation tasks will search for a match of parameters. +.NH 2 +Requirements and Specifications +.PP +To meet the needs of the astronomer in calculating dispersions, a task will +be written that meets the following specifications: +.IP \(bu +The user must specify the number of points to be computed, the velocity +increment, and the starting dispersion velocity, +thus producing a lookup table at a specified resolution. +.IP \(bu +The user will specify the name of a database file which will contain the +$s sub i$ coefficients as well as the points used in the fit and parameters +of the task. +.IP \(bu +Each of the tasks that can compute a dispersion can be furnished the +name of this database file and use the information contained to compute +a dispersion value from the width of the correlation function. +.IP \(bu +The task will be able to run in interactive or batch mode. In batch mode the +task will compute the dispersions and output to the database automatically. +In interactive mode the user may adjust parameters as in other tasks in this +package, allowing him to produce database files for various instrumental +setups at one time. +.IP \(bu +The task must be able to call one of the other one dimensional correlation +routines to compute the correlation functions. +.IP \(bu +The task must be able to call one of the other available fitting functions. +.IP \(bu +The task must be able to filter the data if a Fourier method is chosen. + +.NH +Fitting Functions +.PP +A set of non-linear least squares routines is needed to fit the computed +correlation function to obtain a shift, or to fit the entire spectum to +flatten it. Polynomial fitting routines are well known and easy enough to +implement, but we also require more complex functions. Not only is it +desireable to fit a parabola (second order polynomial) to the peak of the +correlation function (which is a real function), but +a Gaussian is sometimes desired. Also, when +fitting the ratio or difference between the transforms of the galaxy and +stellar spectra, a gaussian is needed to fit the complex transform of the +broadening function. +.PP +Since a variety of fitting functions are needed and to ease in the +incorporation of other fitting functions in the future, the non-linear +least squares package \fInlfit\fR written by Lindsay Davis for the \fIAPPHOT\fR +package will be used. This has the distinct advatange that all that is +required to add a new function is to write routines to evaluate the +function and it's derivatives, simplifying things greatly. +.NH 2 +Requirements and Specifications +.PP +The following fitting functions will be provided and are chosen through +the tasks parameters or commands: +.KS +.IP \(bu +Parabola. +.IP \(bu +One dimensional real Gaussian. +.IP \(bu +One dimensional complex Gaussian. +.IP \(bu +$N sup th$-order polynomial. +.KE + +.EQ +delim off +.EN +.NH +Tasks +.PP +The required tasks for this package are the following: +.nf + +.na + mkbins - Create bins of approximately equal flux intensity + observatory - Observatory location database + processpars - Batch processing parameters for RV package + filterpars - Edit the filter function parameters + rvcorrect - Compute radial velocity corrections + rvdisp - Produce velocity dispersions from CCF widths + rvemfit - Fit emmission features in spectra + rvfdiff - Redshifts and dispersions via Fourier Difference techniques + rvfquot - Redshifts and dispersions via Fourier Quotient techniques + rvkeywords - Keyword translation table for RV image headers + rvselect - Select output fields from an RV record + rvskyline - Telluric line removal/fitting task + rvstats - Print information to aide in RV parameter selection + rvsummary - Print a summary table of output from RV tasks + rvsqdiff - Radial velocities via a squared difference correlation + rvxcor - Radial velocities via Fourier cross correlation + xcor2d - Cross correlation of two dimensional data +.ad +.fi + +.NH 2 +Usage +.LP +Some examples of typical usage are listed below. +.IP \(bu +A user has a series of Longslit spectra of galaxies at differing position +angles and wishes to correlate them with a template spectrum to +obtain redshift and dispersion information. +The user then uses the \fIrvfdiff\fR +or \fIrvfquot\fR tasks to correlate the spectra and compute the dispersions. +.IP \(bu +A user is interested in obtaining radial velocities of a series of spectra +obtained over several nights with different instrumental setups. +The \fIrvdisp\fR task is used to create dispersion tables for each instrumental +setup. One of the correlation tasks is then used to correlate each set +of spectra. +.IP \(bu +A user has a small series of unusual spectra of different spectral types +and wishes to obtain radial velocities. +The \fIrvdisp\fR task is used to create dispersion tables for each instrumental +setup. The user then chooses the correlation method he wishes to use and +interactively adjusts parameters for each object spectrum, writing the results +to the logfile when satisfied. +.IP \(bu +A user has a large number of low signal-to-noise spectra to be correlated +to obtain a list of radial velocities. +The \fIrvdisp\fR task is used to create dispersion tables for each new +instrumental setup (if any). The user then chooses the correlation method +he wishes to use and after setting up the parameters, processes the list +as a background job. After returning from coffee, he examines the +output list and graphics spool file for bad fits which can be done by hand +later. +.IP \(bu +A user has an old set of spectra for which he was only able to obtain an +observed radial velocity and wishes to do the heliocentric velocity corrections. +The user may then use the use the \fIimages.hedit\fR tasks to insert the +observed velocity into the image header. The \fIrvcorrect\fR task is then +called to correct each image with respect to the sun (or even the Local +Standard of Rest). + +.NH 1 +Bibliography +.PP +.XP +Press, W.H. et al 1986, \fINumerical Recipes\fR, Cambridge Univ. Press, + Cambridge, Ch 12. +.XP +Rabiner, L.R. and Gold, B. 1975 \fITheory and Application of Digital + Signal Processing\fR, Prentice Hall, Englewood Cliffs, Ch 3. +.XP +Sargent, Schechter, Boksenberg and Shortridge, 1977, "Velocity Dispersions + for 13 Galaxies", \fIAstrop. J.\fR \fB212\fR p326. +.XP +Tonry, J. and Davis, M. 1979, "A Survey of Galaxy Redshift. I. Data + Reduction Techniques", \fIAstron. J.\fR \fB84,\fR p 1511 +.XP +Weiss, W.W. et al 1978, "A Statistical Approach for the Determination + of Relative Zeeman and Doppler Shifts in Spectrograms", \fIAstron. + Astrophys.\fR \fB63\fR, p 247. +.XP +Willmarth, D.W and Abt, H.A., 1985, "Radial Velocities From CCD Detectors" + in \fIIAU Coll. No. 88, Stellar Radial Velocities\fR, p 99 +.XP +Wyatt, W.F., 1985, "The CfA System for Digital Correlations" in + \fIIAU Coll. No 88, Stellar Radial Velocities\fR, p 123 +.PP + +.NH +Detailed Manual Pages +.PP + The individual manual pages for these tasks follow this document. diff --git a/noao/rv/doc/rvplan.ms b/noao/rv/doc/rvplan.ms new file mode 100644 index 00000000..7b81ee1a --- /dev/null +++ b/noao/rv/doc/rvplan.ms @@ -0,0 +1,91 @@ +.OM +.TO +RV folks +.FR +Doug Tody +.SU +RV development plans +.PP +The purpose of this memo is to introduce the RV "level zero specifications" +document enclosed, to explain what that means and what our plans for future +RV package development are, and how the new programming team approach being +used for RV and other projects works. +.SH +Programming Teams +.PP +As was mentioned in our RV meeting a while back, we are experimenting +with the use of small programmer teams for major projects such as RV. +In the case of RV, the programming team is Mike and Frank, with Mike being +the programmer in charge of the project, and Frank the reviewer and critic. +Frank and Mike work together on a daily basis and every few weeks the three +of us have a team meeting to review progress. Similar teams are being set +up for other projects, e.g., Mike (reviewer-critic) and Lindsey (programmer) +are the team for the new PHOTCAL package. +.PP +For each project we maintain a project directory where all design +specifications, email, etc. for the project are kept. You are welcome +to browse this if you wish to know more about the details of the project. +In the case of RV, the project directory is /u2/fitz/iraf/rvproject on +tucana. All of the email exchanged by the team members during the package +design, or mail exchanged with scientists or other users, is saved in the +rvmail file in this directory. If you have detailed comments on any feature +of a package like RV, it is best to send them to one of the team members via +email so that they get logged for the rest of us to read. +.SH +RV Development Plans +.PP +Based upon your input in the RV review meeting a while back, we have come +up with the following plan for the next phase in the development of the +RV package. This plan is intended to serve our immediate needs for radial +velocity analysis as quickly as possible, while providing a fully featured +package in the longer term. +.RS +.IP \(bu +\fBLevel Zero Task\fR. This is intended to provide a basic radial +velocity capability, providing the most needed functions but avoiding +the more ambitious features planned for the eventual full IRAF +package. It is the specifications for the level zero task which are +enclosed for you to review and comment on. Once completed, the level +zero task will be frozen and will continue to be available +indefinitely, without change, providing a stable tool for basic radial +velocity analysis while development and testing of the full package +goes forward. Although the level zero task will provide limited +functionality, those algorithms and features provided are intended to +be about as good as can be done (please let us know if you think +otherwise!) and will have undergone lots of testing with real and +artificial data by the time the software is released. +.IP \(bu +\fBBaseline Package\fR. This will be more or less what Mike has in the +current prototype version of RV, most likely with many changes reflecting +what we learn from the level zero task. +.IP \(bu +\fBFull Package\fR. This will be a second version of the baseline release +adding all the desirable but lower priority functions. Many changes to the +baseline package are sure to be needed once user testing begins, and these +will be incorporated into the full package along with the remaining tasks +not planned for the baseline package. +.RE +.PP +In addition to the above, the current prototype RV package will continue +to be available for use while the new software is under development. +.PP +As you will see from the draft specifications prepared by Mike and +Frank, the level zero task provides fourier cross correlation for both +raw pixel arrays and wavelength calibrated data, including those +features we thought were necessary for even the level zero task for it +to be useful. These include automatic log-lambda mapping of the input +data, continuum fitting and subtraction, fourier filtering, weighting +of the correlation peak fit to minimize sampling errors, and optional +correction to heliocentric velocities. Important changes to the user +interface have also taken place. The database capabilities (RVSELECT) +have been left out, but will be provided in the baseline version of the +package (the lists.fields task can be used to make lists of selected +quantities from the output of the level zero task). Other important +but less essential functions such as the fourier quotient algorithm, +redshift and deredshift functions, etc., will also be deferred to the +baseline package. +.PP +Comments on our plans for further development of the package, or the +draft specifications for level zero, are most welcome. If you need +some feature in level zero which doesn't appear to be there, try to let +us know as soon as possible. diff --git a/noao/rv/doc/rvreidlines.hlp b/noao/rv/doc/rvreidlines.hlp new file mode 100644 index 00000000..763e813a --- /dev/null +++ b/noao/rv/doc/rvreidlines.hlp @@ -0,0 +1,405 @@ +.help rvreidlines Aug93 noao.rv +.ih +NAME +rvreidlines -- Reidentify spectral lines and measure velocities +.ih +USAGE +rvreidlines reference images +.ih +PARAMETERS +.ls reference +Spectrum with previously identified features to be used as reference for +other spectra. If there are multiple apertures, lines, or columns in the +image a master reference is defined by the \fIsection\fR parameter. +The other apertures, lines, or columns selected by \fIstep\fR are +reidentified if needed. +.le +.ls images +List of dispersion corrected spectral images in which the features in the +reference image are to be reidentified. In two and three dimensional +images the reidentifications are done by matching apertures, lines, +columns, or bands with those in the reference image. +.le +.ls interactive = no +Examine and fit features and velocities interactively? If the task is run +interactively a query (which may be turned off during execution) will be +given for each vector reidentified after printing the results of the +automatic determination and the user may chose to enter the interactive +\fBrvidlines\fR task. +.le +.ls section = "middle line" +If the reference image is not one dimensional or given as a one dimensional +image section then this parameter selects the master reference image +vector. The master reference is used when reidentifying other vectors in +the reference image or when other images contain apertures not present in +the reference image. This parameter also defines the direction +(columns, lines, or z) of the image vectors to be reidentified. + +The section parameter may be specified directly as an image section or +in one of the following forms + +.nf +line|column|x|y|z first|middle|last|# [first|middle|last|#]] +first|middle|last|# [first|middle|last|#] line|column|x|y|z +.fi + +where each field can be one of the strings separated by | except for # +which is an integer number. The field in [] is a second designator which +is used with 3D data. See the example section for \fBrvidlines\fR for +examples of this syntax. Abbreviations are allowed though beware that 'l' +is not a sufficient abbreviation. +.le +.ls newaps = yes +Reidentify new apertures in the images which are not in the reference +image? If no, only apertures found in the reference image will be +reidentified in the other images. If yes, the master reference spectrum +is used to reidentify features in the new aperture and then the +new aperture features will be added to the reference apertures. All +further identifications of the new aperture will then use this result. +.le +.ls override = no +Override previous solutions? If there are previous measurements for a +particular image vector being identified, because of a previous +\fBrvidlines\fR or \fBrvreidlines\fR, this parameter selects whether +to simply skip the reidentification or do a reidentification and +velocity measurement and overwrite the results in the logfile and database. +.le + +The following parameters are used for selecting and reidentifying additional +lines, columns, or apertures in two dimensional formats. +.ls trace = no +There are two methods for defining additional reference lines, columns, or +bands in two and three dimensional format images as selected by the +\fIstep\fR parameter. When \fItrace\fR is no the master reference line or +column is used for each new reference vector. When this parameter is yes +then as the reidentifications step across the image the last reidentified +features are used as the reference. This "tracing" is useful if there is a +coherent shift in the features such as with long slit spectra. However, +any features lost during the tracing will be lost for all subsequent lines +or columns while not using tracing always starts with the initial set of +reference features. +.le +.ls step = "10" +The step from the reference aperture, line, column, or band used for +selecting and/or reidentifying additional lines, columns, or bands in a two +or three dimensional reference image. For three dimensional images there +may be two numbers to allow independent steps along different axes. For +multiaperture images the step is typically 1 while for long slit or +Fabry-Perot images the step is large enough to map any significant changes +in the feature positions. If the step is zero then only the reference +line, column, or band is used. +.le +.ls nsum = "10" +Number of lines, columns, or bands across the designated vector axis to be +summed when the image is a two or three dimensional spatial spectrum. +It does not apply to multispec format spectra. If the image is three +dimensional an optional second number can be specified for the higher +dimensional axis (the first number applies to the lower axis number and +the second to the higher axis number). If a second number is not specified +the first number is used for both axes. +.le +.ls shift = "0" +Shift in user coordinates to be added to the reference features before +centering when stepping to other lines, columns, or bands in the reference +image. Generally no shift is used by setting the value to zero. +The shift is used as a slope with positive values increasing towards +larger line or column numbers. This parameter is not used for +reidentifications from the reference image to other images. +If the image is three dimensional then two numbers may be specified +for the two axes. +.le +.ls nlost = 0 +When reidentifying features by tracing, if the number of features not found +in the new image vector exceeds this number then the reidentification +record is not written to the logfile and database and the trace is terminated. A warning is printed in the log and in the verbose output. +.le + +The following parameters define the finding and recentering of features. +See also \fBcenter1d\fR and \fBrvidlines\fR. +.ls cradius = 5. +Centering radius in pixels. If a reidentified feature falls further +than this distance from the previous line or column when tracing or +from the reference feature position when reidentifying a new image +then the feature is not reidentified. +.le +.ls threshold = 10. +In order for a feature center to be determined, the range of pixel +intensities around the feature must exceed this threshold. This parameter +is used to exclude noise peaks and terminate tracing when the signal +disappears. However, failure to properly set this parameter, particularly +when the data values are very small due to normalization or flux +calibration, is a common error leading to failure of the task. +.le + +The following parameters select and control the automatic addition of +new features during reidentification. +.ls addfeatures = no +Add new features from a line list during each reidentification? If +yes then the following parameters are used. This function can be used +to compensate for lost features from the reference solution, particularly +when tracing. Care should be exercised that misidentified features +are not introduced. +.le +.ls coordlist = "" +User coordinate list consisting of an ordered list of rest spectral line +coordinates. +.le +.ls match = 10. +The maximum difference for a match between the feature coordinate function +value and a coordinate in the coordinate list (after correction by the +velocity). +.le +.ls maxfeatures = 50 +Maximum number of the strongest features to be selected automatically from +the coordinate list. +.le +.ls minsep = 2. +The minimum separation, in pixels, allowed between feature positions +when defining a new feature. +.le + +The following parameters determine the input and output of the task. +.ls database = "database" +Database containing the feature data for the reference image and in which +the features for the reidentified images are recorded. +.le +.ls logfiles = "logfile" +List of file in which to record the velocity results and to keep a +processing log. If a null file, "", is given then no log is kept. +.le +.ls verbose = no +Print reidentification and velocity information on the standard output? +.le +.ls keywpars = "" +The image header keyword translation table as described in +the \fIkeywpars\fR named pset. This defines the header keywords used +to obtain the observation information needed for computing the +heliocentric velocity. +.le +.ls graphics = "stdgraph" +Graphics device. The default is the standard graphics device which is +generally a graphics terminal. +.le +.ls cursor = "" +Cursor input file. If a cursor file is not given then the standard graphics +cursor is read. +.le +ADDTIONAL PARAMETERS +The measured velocities are corrected to a heliocentric frame of reference +if possible. This requires determining various parameters about the +observation. The latitude, longitude, and altitude of the observation +are determined from the observatory database. The observatory is +defined by either the OBSERVAT image header keyword or the "observatory" +package parameter in that order. See the help for \fBobservatory\fR +for additional information. + +The date, universal time, right ascension, declination, and coordinate epoch +for the observation are obtained from the image header. The keywords +for these parameters are defined in the \fBkeywpars\fR parameter set. +.ih +DESCRIPTION +\fBRvreidlines\fR takes spectral lines previously identified in a reference +image and recorded in a database and identifies them in other spectra and +determines a radial velocity. If the images are +two or three dimensional or multiaperture format and a \fIstep\fR greater +than zero is specified then additional vectors +(lines/columns/bands/apertures) in the reference image will be reidentified +from the initial master reference vector (as defined by an image section or +\fIsection\fR parameter) provided they have not been reidentified +previously or the \fIoverride\fR flag is set. For multiple aperture +spectra images, called multiaperture, the step size is typically 1; i.e. +reidentify features in all spectra. For two and three dimensional images, +such as long slit and Fabry-Perot spectra, the step(s) should be large enough +to minimize execution time and storage requirements but small enough to +follow shifts in the features (see the discussion below on tracing). The +set of reference identifications is applied to other images in the same +lines, columns, bands, or apertures. In multiaperture images the same +apertures are matched in the reference image regardless of actual line +order; i.e. the apertures need not be in the same order or even have all +apertures present. + +The reidentification of other features in other reference image vectors +may be done in two ways selected by the parameter \fItrace\fR. If not +tracing, the initial reference vector is applied to the other selected +vectors. If tracing, the reidentifications are made with respect to the +last set of identifications as successive steps away from the reference +vector are made. The tracing method is appropriate for two and three +dimensional spatial images, such as long slit and Fabry-Perot spectra, in +which the positions of features traced vary smoothly. This allows +following large displacements from the initial reference by using suitably +small steps. It has the disadvantage that features lost during the +reidentifications will not propagate (unless the \fIaddfeatures\fR option +is used). By not tracing, the original set of features is used for every +other vector in the reference image. + +When reidentifying other vectors in the reference image the parameter +\fBshift\fR may be used to add a shift(s) to the features positions +before recentering. The shift is added to lines, columns, or bands, greater +than the current line, column, or band and subtracted if less. If tracing +the shifts are the same from step to step while if not tracing the +shifts are added to the shifts from the previous step. Thus, in both +cases an approximation of a slope is used. This allows large +slopes in the features to be followed even when not tracing but the +shift value must be predetermined. + +When tracing, the parameter \fInlost\fR is used to terminate the +tracing whenever this number of features has been lost. This parameter, +in conjunction with the other centering parameters which define +when a feature is not found, may be useful for tracing features +which disappear before reaching the limits of the image. + +When reidentifying features in other images, the reference +features are those from the same aperture, line, column, or band of the +reference image. However, if the \fInewaps\fR parameter is set +apertures in multiaperture spectra which are not in the reference +image may be reidentified against the master reference aperture and +added to the list of aperture to be reidentified in other images. +This is useful when specta with different aperture numbers are +stored as one dimensional images. + +There are two centering algorithms; a flux bisecting algorithm called +\fBcenter1d\fR and a gaussian fitting algorithm. These algorithms +are described in the help for \fBrvidlines\fR. The algorithm used +and whether the feature is emission or absorption is the same one used +in the reference image. The only caveat is that multiple gaussian +fitting provided by the interactive 'b' key in \fBrvidlines\fR is +not done by this task and those lines will be fit by gaussians +independently. + +When recentering, if a feature position shifts by more than the +amount set by the parameter \fIcradius\fR from the starting position +(possibly after adding a shift) or the feature strength (peak to valley) is +less than the detection \fIthreshold\fR then the new feature is discarded. +The \fIcradius\fR parameter should be set large enough to find the correct +peak in the presence of any shifts but small enough to minimize incorrect +identifications. The \fIthreshold\fR parameter is used to eliminate +identifications with noise. Failure to set this parameter properly for the +data (say if data values are very small due to a calibration or +normalization operation) is the most common source of problems in using +this task. + +In two and three dimensional images, though not multiaperture images, the +number of lines, columns, or bands given by the parameter \fInsum\fR are summed +to form the one dimensional image vector in which the features are +identified. This increases the accuracy for reidentifying weak +features. + +If the parameter \fIaddfeatures\fR is set additional features may be added +after the initial reidentification and velocity determination using a line +list of rest wavelengths. A maximum number of added features, a matching +distance in user coordinates, and a minimum separation from other features +are additional parameters. This option is similar to that available in +\fBrvidlines\fR and is described more fully in the help for that task. + +A statistics line is generated for each reidentified vector. The line +contains the name of the image being reidentified (which for two +dimensional images includes the image section and for multiaperture +spectra includes the aperture number), the number of features found +relative to the number of features in the reference, the number of +features used in the velocity determination (currently there is +no rejection of lines) relative to the number found, the +mean pixel and user coordinate shfits relative to the reference +coordinates, and the measured velocity and RMS in the velocity. +The velocity is the heliocentric velocity if the necessary observation +information in the image and observatory database are found. + +If the task is run with the \fIinteractive\fR flag the statistics line +is printed to the standard output (the terminal) and a query is +made whether to fit the lines and measure the velocity interactively. +A response +of yes or YES will put the user in the interactive graphical mode +of \fBrvidlines\fR. See the description of this task for more +information. The idea is that one can monitor the statistics information, +particularly the velocity RMS, and select only those which may be +questionable to examine interactively. A response of no or NO will +continue on to the next spectrum. The capitalized responses +turn off the query and act as permanent response for all other +reidentifications. + +This statistics line, including headers, is written to any specified +log files. The log information includes the image being +reidentified and the reference image. +In addition the set of lines, the observatory information used, +and the computed observed and heliocentric velocities and redshifts +are recorded. This is the same information as is produced +by \fBrvidlines\fR. +.ih +DATABASE RECORDS +The database specified by the parameter \fIdatabase\fR is a directory of +simple text files. The text files have names beginning with 'id' followed +by the entry name, usually the name of the image. The database text files +consist of a number of records. A record begins with a line starting with the +keyword "begin". The rest of the line is the record identifier. Records +read and written by \fBrvreidlines\fR have "identify" as the first word of the +identifier. Following this is a name which may be specified following the +":read" or ":write" commands. If no name is specified then the image name +is used. For 1D spectra the database entry includes the aperture number +and so to read a solution from a aperture different than the current image +and aperture number must be specified. For 2D/3D images the entry name +has the 1D image section which is what is specified to read the entry. +The lines following the record identifier contain +the feature information and redshift (without heliocentric correction). + +The database files have the name "identify" and the prefix "id" because +these files may also be read by the \fBidentify\fR task for changing +the dispersion function based on the rest wavelengths. +.ih +EXAMPLES +1. To generate a rotation curve for a long slit spectrum of a +galaxy first use \fBrvidlines\fR to mark some lines at the center of the +galaxy. If the velocities are to be absolute then you give the rest +wavelengths and do a fit. However to get velocities relative to the center +use the measured wavelengths by simply accepting the prompted measured +wavelengths. Then run \fBrvreidlines\fR. The \fInsum\fR and \fIstep\fR +parameters allow controlling the summing size and spacing. + +.nf + rv> rvid lsgal sec="mid col" nsum=5 + Mark lines and then quit. + Write velocity data to the logfile (yes)? + Write feature data to the database (yes)? + rv> rvreid lsgal "" sec="mid col" nsum=5 step=5 trace+ v+ + + RVREIDLINES: NOAO/IRAF V2.10.3 valdes Sat 14:47:55 21-Aug-93 + Reference image = lsgal, New image = lsgal + Image Data Found Fit Pix Shift User Shift Velocity RMS + lsgal[45,*] 7/7 7/7 -0.0181 -0.0212 -1.37 11.3 + lsgal[40,*] 7/7 7/7 0.0147 0.0193 1.34 8.73 + lsgal[35,*] 7/7 7/7 0.0931 0.116 8.01 9.16 + lsgal[30,*] 7/7 7/7 -0.0224 -0.0265 -1.78 27.6 + lsgal[25,*] 7/7 7/7 0.0558 0.07 4.83 33.7 + lsgal[20,*] 7/7 7/7 -0.0317 -0.0379 -3.08 33.6 + lsgal[15,*] 5/7 5/5 0.015 0.0201 0.799 43.7 + lsgal[10,*] 7/7 7/7 0.395 0.489 33.7 54.9 + lsgal[5,*] 4/7 4/4 -1.22 -1.51 -106. 84.3 + lsgal[55,*] 7/7 7/7 0.014 0.0184 1.41 10.5 + lsgal[60,*] 7/7 7/7 -0.0897 -0.109 -7.59 7.21 + lsgal[65,*] 7/7 7/7 -0.0109 -0.0122 -0.957 10.9 + lsgal[70,*] 7/7 7/7 -0.074 -0.0902 -6.55 14.6 + lsgal[75,*] 7/7 7/7 -0.00203 -0.00136 0.227 54.3 + lsgal[80,*] 6/7 6/6 0.08 0.0997 6.66 96.7 + lsgal[85,*] 6/7 6/6 0.289 0.357 27.2 104. + lsgal[90,*] 6/7 6/6 0.459 0.568 40.5 33.2 + lsgal[95,*] 6/7 6/6 0.926 1.14 78.5 65.5 + lsgal[100,* 5/7 5/5 0.696 0.86 59.1 44.2 + rv> match Vobs logfile | fields "" 2,6,11 | \ + >>> graph point- mark=vebar szmark=-1 +.fi + +The last command extracts the Vobs results from the logfile using +\fBmatch\fR, the column number, velocity, and mean error are extract +using \fBfields\fR, and graphs the points with error bars. One +drawback to this method is that the nubmer of columns summed is +constant and so the signal-to-noise decreases with the galaxy light. +.ih +REVISIONS +.ls RVREIDLINES V2.11 +This task will now work in the units of the input spectra. +.le +.ls RVREIDLINES V2.10.3 +This task in new in the version. +.le +.ih +SEE ALSO +center1d, fxcor, keywpars, observatory, rvcorrect, rvidlines +.endhelp diff --git a/noao/rv/fftmode.x b/noao/rv/fftmode.x new file mode 100644 index 00000000..40e45e44 --- /dev/null +++ b/noao/rv/fftmode.x @@ -0,0 +1,795 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" +include "rvplots.h" +include "rvfilter.h" + + +# FFT_COLON - Procedure to process the colon commands defined below. Most +# commands are for interactive editing of parameters to the task. + +int procedure fft_colon (rv, cmdstr) + +pointer rv #I RV struct pointer +char cmdstr[SZ_LINE] #I Command + +pointer sp, cmd +int strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + + if (strdic(Memc[cmd], Memc[cmd], SZ_LINE, FILT_KEYWORDS) != 0) { + # Process the FILTERPARS pset commands. + call filt_colon (rv, cmdstr) + + } else { + # Now process the mode specific colon commands. + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, PLOT_KEYWORDS)) { + case PLT_FILTER: + call cmd_filter (rv) + + case PLT_FFT_ZOOM: + call cmd_fft_zoom (rv) + + case PLT_LOG_SCALE: + call cmd_log_scale (rv) + + case PLT_ONE_IMAGE: + call cmd_one_image (rv) + + case PLT_OVERLAY: + call cmd_overlay (rv) + + case PLT_PLOT: + call cmd_plot (rv) + + case PLT_SPLIT_PLOT: + call cmd_split_plotx (rv) + + case PLT_WHEN: + call cmd_when (rv) + + default: + # Default action + call rv_mode_prompt (rv) + call rv_errmsg ("Type '?' for a list of commands.") + call sfree (sp) + return (ERR) + } + } + + call sfree (sp) + return (OK) +end + + +# FFT_CURSOR - Get the next command from the user in the input cursor loop +# and perform the requested function. + +int procedure fft_cursor (rv) + +pointer rv #I RV struct pointer + +pointer gp, sp, cmd, filt +int wcs, key +int ofnpts, rfnpts +real x, y +char ckey +bool prompt + +int fft_colon(), clgcur(), stridx(), spc_cursor() +int rv_parent(), fft_pow2(), rv_chk_filter() + +define exit_ 99 +define replot_ 98 + +begin + # Update the mode counter. + RV_MODES(rv) = (RV_MODES(rv)*10) + FFT_MODE + + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Nab some pointers. + ofnpts = fft_pow2 (RV_NPTS(rv)) + rfnpts = fft_pow2 (RV_RNPTS(rv)) + gp = RV_GP(rv) + + +# if (RVF_LASTKEY(rv) == 'p' && RV_FILTER(rv) != NONE) +# key = 'p' +# else + key = 'b' + repeat { + + RV_CMD(rv) = key + ckey = key + if (stridx(ckey,":?iqrsx") == 0) + RVF_LASTKEY(rv) = key + prompt = true +replot_ RV_NEWGRAPH(rv) = NO + switch (key) { # switch on the keystroke + case '?': + # List options + call gpagefile (gp, FM_HELP, "FFT Mode Options: ") + + case ':': + # Process a colon command. + if (fft_colon(rv,Memc[cmd]) == OK) { + if (RV_NEWGRAPH(rv) == YES) { + key = RVF_LASTKEY(rv) + goto replot_ + } + } + prompt = false + + case 'b': + # Display power spectra before filtering + RVP_WHEN(rv) = BEFORE + RVP_PLOT(rv) = POWER_PLOT + call fft_plot (rv, RVP_PLOT(rv)) + + case 'f': + # Display FFT's after filtering. + if (RV_FILTER(rv) == NONE) { + call rv_mode_prompt (rv) + call rv_errmsg ("Filtering is currently disabled.") + prompt = false + } else { + RVP_WHEN(rv) = AFTER + RVP_PLOT(rv) = AMPLITUDE_PLOT + call fft_plot (rv, RVP_PLOT(rv)) + } + + case 'g': + # Display FFT's before filtering. + RVP_WHEN(rv) = BEFORE + RVP_PLOT(rv) = AMPLITUDE_PLOT + call fft_plot (rv, RVP_PLOT(rv)) + + case 'i': + # Print period trend information. + call rv_mode_prompt (rv) + call fft_inverse (rv, x, y, wcs) + prompt = false + + case 'I': + call error (0, "Interrupt") + + case 'o': + # Display filtered and unfiltered object spectrum. + if (RV_FILTER(rv) == OBJ_ONLY || RV_FILTER(rv) == BOTH) { + if (rv_chk_filter(rv, OBJECT_SPECTRUM) != OK) { + call rv_mode_prompt (rv) + call rv_errmsg ("Invalid filter specified.") + prompt = false + } else { + call malloc (filt, ofnpts, TY_REAL) + call gclear (gp) + if (RV_CONTINUUM(rv)==BOTH || + RV_CONTINUUM(rv)==OBJ_ONLY) { + call amovr (OCONT_DATA(rv,1), Memr[filt], + RV_NPTS(RV)) + call split_plot (rv, gp, TOP, OCONT_DATA(rv,1), + RV_NPTS(rv), OBJECT_SPECTRUM, NORM_PLOT) + } else { + call amovr (OBJPIXY(rv,1), Memr[filt], RV_NPTS(rv)) + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), + RV_NPTS(rv), OBJECT_SPECTRUM, SPECTRUM_PLOT) + } + call rv_do_filter (rv, RV_OSAMPLE(rv), Memr[filt], + RV_NPTS(rv), Memr[filt], ofnpts, NO) + call split_plot (rv, gp, BOTTOM, Memr[filt], + RV_NPTS(rv), OBJECT_SPECTRUM, FILTER_PLOT) + call mfree (filt, TY_REAL) + } + } else { + call rv_mode_prompt (rv) + call rv_errmsg ("Filtering disabled for object spectrum.") + prompt = false + } + + case 'p': + # Display power spectra after filtering. + if (RV_FILTER(rv) == NONE) { + call rv_mode_prompt (rv) + call rv_errmsg ("Filtering is currently disabled.") + prompt = false + } else { + RVP_WHEN(rv) = AFTER + RVP_PLOT(rv) = POWER_PLOT + call fft_plot (rv, RVP_PLOT(rv)) + } + + case 'q': + # Quit this mode. + break + + case 'r': + # Replot. + if (RVF_LASTKEY(rv) != 'r') + key = RVF_LASTKEY(rv) + goto replot_ + + case 's': + # Display the spectra. + if (rv_parent(rv) == SPEC_MODE) { + goto exit_ + } else if (spc_cursor (rv) == QUIT) { + RV_MODES(rv) = (RV_MODES(rv) - FFT_MODE) / 10 + call sfree (sp) + return (QUIT) + } else { + key = RVF_LASTKEY(rv) + goto replot_ + } + + case 't': + # Display filtered and unfiltered template spectrum. + if (RV_FILTER(rv) == TEMP_ONLY || RV_FILTER(rv) == BOTH) { + if (rv_chk_filter(rv, REFER_SPECTRUM) != OK) { + call rv_mode_prompt (rv) + call rv_errmsg ("Invalid filter specified.") + prompt = false + } else { + call malloc (filt, rfnpts, TY_REAL) + call gclear (gp) + if (RV_CONTINUUM(rv)==BOTH || + RV_CONTINUUM(rv)==TEMP_ONLY) { + call amovr (RCONT_DATA(rv,1), Memr[filt], + RV_RNPTS(rv)) + call split_plot (rv, gp, TOP, RCONT_DATA(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, NORM_PLOT) + } else { + call amovr (REFPIXY(rv,1), Memr[filt], RV_RNPTS(rv)) + call split_plot (rv, gp, TOP, REFPIXY(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, SPECTRUM_PLOT) + } + call rv_do_filter (rv, RV_RSAMPLE(rv), Memr[filt], + RV_RNPTS(rv), Memr[filt], rfnpts, NO) + call split_plot (rv, gp, BOTTOM, Memr[filt], + RV_RNPTS(rv), REFER_SPECTRUM, FILTER_PLOT) + call mfree (filt, TY_REAL) + } + } else { + call rv_mode_prompt (rv) + call rv_errmsg ("Filtering disabled for template spectrum.") + prompt = false + } + + case 'x': + # Return to correlation mode. + RV_MODES(rv) = (RV_MODES(rv) - FFT_MODE) / 10 + call sfree (sp) + return (QUIT) + + default: + # Unknown command. + call rv_mode_prompt (rv) + call rv_errmsg ("Type '?' for a list of commands.") + prompt = false + } + + if (prompt) + call rv_mode_prompt (rv) + ckey = key + if (stridx(ckey,":?iqrsx") == 0) + RVF_LASTKEY(rv) = key + + } until (clgcur("cursor",x,y,wcs,key,Memc[cmd],SZ_LINE) == EOF) + +exit_ call sfree (sp) + RV_MODES(rv) = (RV_MODES(rv) - FFT_MODE) / 10 + return (OK) +end + + +# FFT_PLOT - Do the plotting for the FFT plotting subpackage and determine +# the type of plot to draw. + +procedure fft_plot (rv, flags) + +pointer rv #I RV struct pointer +int flags #I Type of plot to draw + +begin + # Get the graphics pointer and clear the workstation. + if (RV_GP(rv) != NULL) + call gclear (RV_GP(rv)) + else + return + + # Call the plot primitives. + switch (flags) { + case AMPLITUDE_PLOT: + call fft_fplot (rv, RVP_SPLIT_PLOT(rv)) + case POWER_PLOT: + call fft_pplot (rv, RVP_SPLIT_PLOT(rv)) + default: + call error (0, "Invalid FFT plot specification.") + } +end + + +# FFT_FLTPLOT - Plot the (filtered) spectrum to the screen. + +procedure fft_fltplot (rv, gp, vec, npts) + +pointer rv #I RV struct pointer +pointer gp #I graphics descriptor +real vec[ARB] #I Data to be plotted +int npts #I Npts of data to plot + +pointer sp +pointer objx, title, idsys +int i +real x1, x2, y1, y2 +double dex() + +begin + if (gp == NULL) + return + + call smark (sp) + call salloc (objx, npts, TY_REAL) + call salloc (idsys, SZ_LINE, TY_CHAR) + call salloc (title, 4*SZ_LINE, TY_CHAR) + + call gclear (gp) + + # Scale the vector. + if (RV_DCFLAG(rv) == -1) { + do i = 1, npts + Memr[objx+i-1] = real (i) + } else { + do i = 1, npts + Memr[objx+i-1] = dex (RV_OW0(rv) + (i-1) * RV_OWPC(rv)) + } + + # Scale the WCS. + call gascale (gp, Memr[objx], npts, 1) + call gascale (gp, vec, npts, 2) + + # Force a pretty Y scaling. + call ggwind (gp, x1, x2, y1, y2) + y1 = y1 - (0.02*y1) + y2 = y2 + (0.02*y2) + call gswind (gp, x1, x2, y1, y2) + + # Do the title and labeling. + call sysid (Memc[idsys], SZ_LINE) + call sprintf (Memc[title], 4*SZ_LINE, + "%s\nObject='%s' Star='%s'\nnpts=%d aperture=%d") + call pargstr (Memc[idsys]) + call pargstr (IMAGE(rv)) + call pargstr (OBJNAME(rv)) + call pargi (npts) + call pargi (RV_APNUM(rv)) + call glabax (gp, Memc[title], "wavelength", "intensity") + + # Draw the vectors. + call gpline (gp, Memr[objx], vec, npts) + + call gflush (gp) + call sfree (sp) +end + + +# FFT_GFILTER - Fill an array with the requested filter function so that +# it may be overplotted on the FFT plot. + +procedure fft_gfilter (rv, filt, npts, y2) + +pointer rv #I RV struct pointer +real filt[npts] #U FFT data array +int npts #I no. elements in fft[] +real y2 #I Upper limit of plot + +pointer sp, buf +int i, npts2 +real tmp + +begin + call smark (sp) + call salloc (buf, 2*npts, TY_REAL) + call aclrr (Memr[buf], 2*npts) + + npts2 = 2 * npts # initializations + if (RVP_LOG_SCALE(rv) == YES) + y2 = 10.0 ** y2 + call amovkr (y2, Memr[buf], npts2) + + # Now apply the filter to get the function. + call rv_filter (rv, Memr[buf], npts) + + # Now recover the filter function. + do i = 1, npts { + tmp = Memr[buf+i-1] + if (RVP_LOG_SCALE(rv) == YES && tmp != 0.0) + filt[i] = log10 (tmp) + else + filt[i] = tmp + } + + call sfree (sp) +end + + +# PLOT_OVERLAY - Plot the filter function overlayed on the FFT plot. + +procedure fft_fltoverlay (rv, gp, fnpts, y2) + +pointer rv #I RV struct pointer +pointer gp #I Graphics decriptor +int fnpts #I Npts in FFT +real y2 #I Current Y2 of window + +pointer sp, filt +real startp, endp +int rv_chk_filter(), fft_pow2() + +begin + if (gp == NULL || RVP_OVERLAY(rv) == NO) + return + + # Check for a nonsensical filter specification. + if (RV_WHERE(rv) == TOP && rv_chk_filter(rv,OBJECT_SPECTRUM) != OK) + return + if (RV_WHERE(rv) == BOTTOM && rv_chk_filter(rv,REFER_SPECTRUM) != OK) + return + + fnpts = max (fft_pow2 (RV_NPTS(rv)), fft_pow2 (RV_RNPTS(rv)) ) / 2 + + # Allocate working space. + call smark (sp) + call salloc (filt, 2*fnpts, TY_REAL) + + # Get the filter to be plotted. + y2 = y2 - (0.075 * y2) + call fft_gfilter (rv, Memr[filt], 2*fnpts, y2) + + # Compute the endpoint. + if (RV_WHERE(rv) == BOTTOM) { + startp = 1. + endp = real(fnpts) / RVP_FFT_ZOOM(rv) + } else { + startp = 0. + endp = (real(fnpts) / RVP_FFT_ZOOM(rv)) / (2. * real(fnpts)) + } + fnpts = fnpts * 2 + + # Now plot the filter function. + call gseti (gp, G_PLCOLOR, C_RED) + call gvline (gp, Memr[filt], int(fnpts/RVP_FFT_ZOOM(rv)), startp, endp) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv),"flt_overlay:\tstart=%g end=%g\n") + call pargr (startp) ; call pargr (endp) + call d_printf (DBG_FD(rv),"\t\tnew=%d np=%d rnp=%d fnp=%d\n") + call pargi (fnpts) ;call pargi (RV_NPTS(rv)) + call pargi (RV_RNPTS(rv)) ; call pargi (RV_FFTNPTS(rv)) + call flush (DBG_FD(rv)) + } + + + call sfree (sp) +end + + +# FFT_FPLOT - Plot the (two) Fourier transforms to the screen. + +procedure fft_fplot (rv, flag) + +pointer rv #I RV struct pointer +int flag #I Type of flag to print (SINGLE/SPLIT) + +pointer gp +pointer sp, rfft, title, bp, ylbl +int fnpts +int fft_pow2() +real x1, x2, y1, y2, startp, endp + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (rfft, 2*fft_pow2(RV_NPTS(rv)), TY_REAL) + call salloc (title, 2*SZ_LINE, TY_CHAR) + call salloc (ylbl, SZ_LINE, TY_CHAR) + call salloc (bp, SZ_LINE, TY_CHAR) + + # Clear the screen. + call gclear (gp) + + if (flag == SINGLE_PLOT) { + if (RVP_ONE_IMAGE(rv) == OBJECT_SPECTRUM) { + if (RV_CONTINUUM(rv) != NONE) { + call get_fft (rv,OCONT_DATA(rv,1), RV_NPTS(rv), Memr[rfft], + fnpts) + } else { + call get_fft (rv,OBJPIXY(rv,1), RV_NPTS(rv), Memr[rfft], + fnpts) + } + } else { + if (RV_CONTINUUM(rv) != NONE) { + call get_fft (rv,RCONT_DATA(rv,1), RV_RNPTS(rv), Memr[rfft], + fnpts) + } else { + call get_fft (rv,REFPIXY(rv,1), RV_RNPTS(rv), Memr[rfft], + fnpts) + } + } + + # Draw the plot to the screen + fnpts = max (RV_FFTNPTS(rv), fnpts) / 2 + call gascale (gp, Memr[rfft], int(fnpts/RVP_FFT_ZOOM(rv)), 2) + call ggwind (gp, x1, x2, y1, y2) + + call get_anplot_title (rv, title) + if (RVP_LOG_SCALE(rv) == YES) + call strcpy ("log(|G(k)|)", Memc[ylbl], SZ_FNAME) + else + call strcpy ("|G(k)|", Memc[ylbl], SZ_FNAME) + + # Draw the top axis labels + startp = 0.0 + endp = (real(fnpts) / RVP_FFT_ZOOM(rv)) / (2. * real(fnpts)) + call gseti (gp, G_WCS, 1) + call gsview (gp, 0.115, 0.95, 0.125, 0.8) + call gswind (gp, startp, endp, y1, y2) + call gseti (gp, G_XDRAWAXES, 2) + call glabax (gp, "", "", Memc[ylbl]) + + # Draw the bottom axis labels + startp = 1.0 + endp = real(fnpts) / RVP_FFT_ZOOM(rv) + call gseti (gp, G_WCS, 2) + call gsview (gp, 0.115, 0.95, 0.125, 0.8) + call gswind (gp, startp, endp, y1, y2) + call gseti (gp, G_XDRAWAXES, 1) + call gseti (gp, G_YDRAWAXES, 3) + call glabax (gp, "", "Wavenumber", Memc[ylbl]) + + # Do the plot title + call gseti (gp, G_WCS, 3) + call gsview (gp, 0.115, 0.95, 0.125, 0.845) + call gswind (gp, startp, endp, y1, y2) + call gseti (gp, G_XDRAWAXES, 0) + call gseti (gp, G_YDRAWAXES, 0) + call glabax (gp, Memc[title], "", "") + call gsview (gp, 0.115, 0.95, 0.125, 0.8) + + call gvline (gp, Memr[rfft], int(fnpts/RVP_FFT_ZOOM(rv)), + startp, endp) + + # Lastly, annotate ther plot so we know what we're looking at. + call gctran (gp, 0.73, 0.73, x1, y1, 0, 1) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + if (RVP_ONE_IMAGE(rv) == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Object FFT", "") + else + call gtext (gp, x1, y1, "Template FFT", "") + call gctran (gp, 0.73, 0.69, x1, y1, 0, 1) + if (RV_FILTER(rv) == BOTH || RV_FILTER(rv) == OBJ_ONLY) { + call fft_fltoverlay (rv, gp, fnpts*2, y2) + if (RVP_WHEN(rv) == BEFORE) + call gtext (gp, x1, y1, "Before Filter", "") + else + call gtext (gp, x1, y1, "After Filter", "") + } + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gseti (gp, G_XDRAWAXES, 3) # reset gio flags + + } else if (flag == SPLIT_PLOT) { + + # Plot the Object power stectrum along the top. + if (RV_CONTINUUM(rv) == OBJ_ONLY || RV_CONTINUUM(rv) == BOTH) { + call split_plot (rv, gp, TOP, OCONT_DATA(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, FOURIER_PLOT) + } else { + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, FOURIER_PLOT) + } + + # Template power spectrum along the bottom. + if (RV_CONTINUUM(rv) == TEMP_ONLY || RV_CONTINUUM(rv) == BOTH) { + call split_plot (rv, gp, BOTTOM, RCONT_DATA(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, FOURIER_PLOT) + } else { + call split_plot (rv, gp, BOTTOM, REFPIXY(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, FOURIER_PLOT) + } + + } + + call sfree (sp) +end + + +# FFT_INVERSE - Print the inverse of the X-axis of the current plot. The intent +# of this routine is to provide an easy mechanism for users to translate the +# frequency of a point on the power spectrum into a period trend in the data. +# It may also be used to translate wavelengths into approximate wavenumbers. + +procedure fft_inverse (rv, x, y, wcs) + +pointer rv #I RV struct pointer +real x, y #I Current cursor (x,y) +int wcs #I WCS of cursor read + +pointer gp +real period +real x1, x2, y1, y2, xx, yy +int fnpts, fft_pow2() + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + # Switch based on the plot flags. + call ggview (gp, x1, x2, y1, y2) + call gctran (gp, x, y, x, y, wcs, 1) + call gctran (gp, x, y, xx, yy, 1, 0) + + fnpts = fft_pow2 (max(RV_NPTS(rv),RV_RNPTS(rv))) / 2 + if (xx < x1 || xx > x2) { # outside plot window + call printf ("Period trend in the data = INDEF.") + return + } else { + period = (1. / x) * real(fnpts * 2.) + call printf ( + "Period trend in the data = %.2f pixels (K = %d, f = %.3f).") + call pargr (period) + call pargi (int(x)) + call pargr (x/real(fnpts)) + } +end + + +# FFT_PPLOT - Plot the (two) Fourier power spectra to the screen. + +procedure fft_pplot (rv, flag) + +pointer rv #I RV struct pointer +int flag #I Type of flag to print (SINGLE/SPLIT) + +pointer gp +pointer sp, rfft, title, bp, xlbl, ylbl +int fnpts +int fft_pow2() +real startp, endp +real x1, x2, y1, y2 + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + call salloc (xlbl, SZ_LINE, TY_CHAR) + call salloc (ylbl, SZ_LINE, TY_CHAR) + call salloc (title, 3*SZ_LINE, TY_CHAR) + call salloc (rfft, fft_pow2(RV_NPTS(rv)), TY_REAL) + + # Clear the screen. + call gclear (gp) + + if (flag == SINGLE_PLOT) { + if (RVP_ONE_IMAGE(rv) == OBJECT_SPECTRUM) { + if (RV_CONTINUUM(rv) != NONE) { + call get_fft (rv,OCONT_DATA(rv,1), RV_NPTS(rv), Memr[rfft], + fnpts) + } else { + call get_fft (rv,OBJPIXY(rv,1), RV_NPTS(rv), Memr[rfft], + fnpts) + } + } else { + if (RV_CONTINUUM(rv) != NONE) { + call get_fft (rv,RCONT_DATA(rv,1), RV_RNPTS(rv), Memr[rfft], + fnpts) + } else { + call get_fft (rv,REFPIXY(rv,1), RV_RNPTS(rv), Memr[rfft], + fnpts) + } + } + + # Draw the plot to the screen + fnpts = max (RV_FFTNPTS(rv), fnpts) / 2 + call gascale (gp, Memr[rfft], int(fnpts/RVP_FFT_ZOOM(rv)), 2) + call ggwind (gp, x1, x2, y1, y2) + + call get_anplot_title (rv, title) + if (RVP_LOG_SCALE(rv) == YES) + call strcpy ("log(|G(k)|)", Memc[ylbl], SZ_FNAME) + else + call strcpy ("|G(k)|", Memc[ylbl], SZ_FNAME) + + # Draw the bottom axis labels + startp = 1.0 + endp = real(fnpts) / RVP_FFT_ZOOM(rv) + call gseti (gp, G_WCS, 2) + call gsview (gp, 0.115, 0.95, 0.125, 0.8) + call gswind (gp, startp, endp, y1, y2) + call gseti (gp, G_XDRAWAXES, 1) + call gseti (gp, G_YDRAWAXES, 3) + call glabax (gp, "", "Wavenumber", Memc[ylbl]) + + # Draw the top axis labels + startp = 0.0 + endp = (real(fnpts) / RVP_FFT_ZOOM(rv)) / (2. * real(fnpts)) + call gseti (gp, G_WCS, 1) + call gsview (gp, 0.115, 0.95, 0.125, 0.8) + call gswind (gp, startp, endp, y1, y2) + call gseti (gp, G_XDRAWAXES, 2) + call glabax (gp, "", "", Memc[ylbl]) + + # Do the plot title + call gseti (gp, G_WCS, 3) + call gsview (gp, 0.115, 0.95, 0.125, 0.845) + call gswind (gp, startp, endp, y1, y2) + call gseti (gp, G_XDRAWAXES, 0) + call gseti (gp, G_YDRAWAXES, 0) + call glabax (gp, Memc[title], "", "") + call gsview (gp, 0.115, 0.95, 0.125, 0.8) + + call gvline (gp, Memr[rfft], int(fnpts/RVP_FFT_ZOOM(rv)), + startp, endp) + + # Lastly, annotate the plot so we know what we're looking at. + call gctran (gp, 0.73, 0.73, x1, y1, 0, 1) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + if (RVP_ONE_IMAGE(rv) == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Object PS", "") + else + call gtext (gp, x1, y1, "Template PS", "") + call gctran (gp, 0.73, 0.69, x1, y1, 0, 1) + if (RV_FILTER(rv) == BOTH || RV_FILTER(rv) == OBJ_ONLY) { + call fft_fltoverlay (rv, gp, fnpts*2, y2) + if (RVP_WHEN(rv) == BEFORE) + call gtext (gp, x1, y1, "Before Filter", "") + else + call gtext (gp, x1, y1, "After Filter", "") + } + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gseti (gp, G_XDRAWAXES, 3) # reset gio flags + + } else if (flag == SPLIT_PLOT) { + + # Plot the Object power stectrum along the top. + if (RV_CONTINUUM(rv) == OBJ_ONLY || RV_CONTINUUM(rv) == BOTH) { + call split_plot (rv, gp, TOP, OCONT_DATA(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, PS_PLOT) + } else { + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, PS_PLOT) + } + + # Template power spectrum along the bottom. + if (RV_CONTINUUM(rv) == TEMP_ONLY || RV_CONTINUUM(rv) == BOTH) { + call split_plot (rv, gp, BOTTOM, RCONT_DATA(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, PS_PLOT) + } else { + call split_plot (rv, gp, BOTTOM, REFPIXY(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, PS_PLOT) + } + + } + + call sfree (sp) +end diff --git a/noao/rv/fftutil.x b/noao/rv/fftutil.x new file mode 100644 index 00000000..b69166ea --- /dev/null +++ b/noao/rv/fftutil.x @@ -0,0 +1,227 @@ +include <math.h> +include "rvpackage.h" +include "rvflags.h" +include "rvplots.h" + +# GET_FFT - Take the input real array and return the absolute value of it's +# DFT. The array rfft must be sized to at least to the power of two greater +# than npts. + +procedure get_fft (rv, rinpt, npts, rfft, fnpts) + +pointer rv #I RV struct pointer +real rinpt[ARB] #I Input real array +int npts #I No. pts in rinpt +real rfft[ARB] #O Output abs value of DFT +int fnpts #O No. pts in output array. + +pointer sp, tp, cpr, cpi, fft +int i, last, ishift +real xtmp, cx_abs() + +begin + fnpts = RV_FFTNPTS (rv) # Get FFT size + + call smark (sp) + call salloc (tp, fnpts, TY_REAL) # Allocate temp vector + call salloc (cpr, fnpts, TY_REAL) # Allocate temp vector + call salloc (cpi, fnpts, TY_REAL) + call salloc (fft, 2*fnpts, TY_REAL) + call aclrr (Memr[tp], fnpts) + call aclrr (Memr[cpr], fnpts) + call aclrr (Memr[cpi], fnpts) + call amovr (rinpt, Memr[tp], npts) + + # Do forward transform + ishift = 0 + if (RV_WHERE(rv) == TOP) { + call prep_spec (rv, RV_OSAMPLE(rv), npts, fnpts, RV_NPTS(rv), + tp, cpr, ishift, YES) + } else { + call prep_spec (rv, RV_RSAMPLE(rv), npts, fnpts, RV_RNPTS(rv), + tp, cpr, ishift, YES) + } + call afftrr (Memr[cpr], Memr[cpi], Memr[cpr], Memr[cpi], fnpts) + if (RVP_WHEN(rv) == AFTER) { + if (RV_WHERE(rv) == TOP) { + if (RV_FILTER(rv) == OBJ_ONLY || RV_FILTER(rv) == BOTH) { + call cx_pak (Memr[cpr], Memr[cpi], Memr[fft], fnpts/2) + call rv_filter (rv, Memr[fft], fnpts/2) + call cx_unpak (Memr[fft], Memr[cpr], Memr[cpi], fnpts) + } + } else { + if (RV_FILTER(rv) == TEMP_ONLY || RV_FILTER(rv) == BOTH) { + call cx_pak (Memr[cpr], Memr[cpi], Memr[fft], fnpts/2) + call rv_filter (rv, Memr[fft], fnpts/2) + call cx_unpak (Memr[fft], Memr[cpr], Memr[cpi], fnpts) + } + } + } + + # Get the absolute value of the transform + last = fnpts / 2 + 1 + do i = 2, last { + xtmp = cx_abs (Memr[cpr+i-1], Memr[cpi+i-1]) + if (RVP_LOG_SCALE(rv) == YES) { + if (xtmp != 0.0) # Divide by zero check in log + rfft[i-1] = log10 (xtmp) + else + rfft[i-1] = 0.0 + } else + rfft[i-1] = xtmp + } + + call sfree (sp) +end + + +# GET_PSPEC - Take the input real array and return the log of the power +# spectrum. The array pspec must be sized to at least to the power of two +# greater than npts. + +procedure get_pspec (rv, rinpt, npts, pspec, fnpts) + +pointer rv #I RV struct pointer +real rinpt[ARB] #I Input real array +int npts #I No. pts in rinpt +real pspec[ARB] #O Output abs value of DFT +int fnpts #O No. pts in output array. + +pointer sp, tp, cpr, cpi, fft +int i, j, ishift +real xtmp + +begin + fnpts = RV_FFTNPTS (rv) # Get FFT size + + call smark (sp) + call salloc (tp, fnpts, TY_REAL) # Allocate temp vector + call salloc (cpr, fnpts, TY_REAL) # Allocate temp vector + call salloc (cpi, fnpts, TY_REAL) # Allocate temp vector + call salloc (fft, 2*fnpts, TY_REAL) # Allocate temp vector + call aclrr (Memr[tp], fnpts) + call aclrr (Memr[cpr], fnpts) + call aclrr (Memr[cpi], fnpts) + call amovr (rinpt, Memr[tp], npts) + + # Do forward transform + ishift = 0 + if (RV_WHERE(rv) == TOP) { + call prep_spec (rv, RV_OSAMPLE(rv), npts, fnpts, RV_NPTS(rv), + tp, cpr, ishift, YES) + } else { + call prep_spec (rv, RV_RSAMPLE(rv), npts, fnpts, RV_RNPTS(rv), + tp, cpr, ishift, YES) + } + call afftrr (Memr[cpr], Memr[cpi], Memr[cpr], Memr[cpi], fnpts) + if (RVP_WHEN(rv) == AFTER) { + if (RV_WHERE(rv) == TOP) { + if (RV_FILTER(rv) == OBJ_ONLY || RV_FILTER(rv) == BOTH) { + call cx_pak (Memr[cpr], Memr[cpi], Memr[fft], fnpts/2) + call rv_filter (rv, Memr[fft], fnpts/2) + call cx_unpak (Memr[fft], Memr[cpr], Memr[cpi], fnpts) + } + } else { + if (RV_FILTER(rv) == TEMP_ONLY || RV_FILTER(rv) == BOTH) { + call cx_pak (Memr[cpr], Memr[cpi], Memr[fft], fnpts/2) + call rv_filter (rv, Memr[fft], fnpts/2) + call cx_unpak (Memr[fft], Memr[cpr], Memr[cpi], fnpts) + } + } + } + + # Get the power spectrum + j = fnpts / 2 + 1 + do i = 2, j { + xtmp = (Memr[cpr+i-1]*Memr[cpr+i-1]) + (Memr[cpi+i-1]*Memr[cpi+i-1]) + if (RVP_LOG_SCALE(rv) == YES) { + if (xtmp != 0.0) + pspec[i-1] = log10 (xtmp) + else + pspec[i-1] = 0.0 + } else + pspec[i-1] = xtmp + } + + call sfree (sp) +end + + +# FFT_COSBEL - Apply a cosine bell to the data. + +procedure fft_cosbel (v, npts, code, percent) + +real v[ARB] #U Data vector +int npts #I Number of data points +int code #I Direction code + # <0 for forward, >=0 for reverse +real percent #I percent of end to mask + +int ndpercent, index, i +real f + +begin + if (IS_INDEF(percent)) + return + + ndpercent = int (npts * percent) # Compute no. of endpoints + + if (code < 0) { # Forward application of window + do i = 1,ndpercent { + f = (1.0 - cos(PI*real(i-1)/real(ndpercent))) / 2.0 + index = npts - i + 1 + v[i] = f * v[i] + v[index] = f * v[index] + } + } else if (code >= 0) { # Reverse application of window + do i = 1,ndpercent { + f = (1.0 - cos(PI*real(i-1)/real(ndpercent))) / 2.0 + if (abs(f) < 1.0e-3) + f = 1.0e-3 + index = npts - i + 1 + v[i] = v[i] / f + v[index] = v[index] / f + } + } +end + + +# FFT_FIXWRAP - Fix the wrap around ordering that results from the Numerical +# Recipes FFT routines. Re-ordering is done such that points 1 to N/2 are +# switched in the array with points N/2+1 to N. Re-ordering is done in-place. + +procedure fft_fixwrap (v, npts) + +real v[ARB] #U Data array in wrap around order +int npts #I length of data array + +real temp +int i + +begin + do i = 1, npts/2 { + temp = v[i] + v[i] = v[i+npts/2] + v[i+npts/2] = temp + } +end + + +# FFT_POW2 - Find the power of two that is greater than N. +# Returns INDEFI if a power can't be found less than 2^15. + +int procedure fft_pow2 (N) +int N #I Number of data points + +int i, nn + +begin + nn = 0 + do i = 1, 31 { + nn = 2 ** i + if (nn >= N) # return 2**i > N + return (nn) + } + + return (INDEFI) +end diff --git a/noao/rv/filtpars.par b/noao/rv/filtpars.par new file mode 100644 index 00000000..be075ea1 --- /dev/null +++ b/noao/rv/filtpars.par @@ -0,0 +1,8 @@ +# PSET file for filtering operations + +f_type,s,h,"ramp","ramp|welch|hanning|square",,Filter window type +cuton,i,h,0,,,Cuton component for filter +cutoff,i,h,0,,,Cutoff component for filter +fullon,i,h,0,,,Component at which (ramp) filter reaches full value +fulloff,i,h,0,,,Component at which (ramp) filter reaches zero +mode,s,h,'ql' diff --git a/noao/rv/filtpars.x b/noao/rv/filtpars.x new file mode 100644 index 00000000..e37d8bbf --- /dev/null +++ b/noao/rv/filtpars.x @@ -0,0 +1,342 @@ +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" +include "rvfilter.h" + +.help filtpars +.nf ___________________________________________________________________________ +FILTPARS - Support routines for the 'filtpars' named external pset. + + This file include routines for opening/closing the filter structure +as well as command handling. Command handling is limited to changing the +parameter values or resetting them to the default values. Routines included +here are as follows. + + filt_open (rv) + filt_close (rv) + filt_get_pars (rv) + filt_parupdate (rv) + filt_unlearn (rv) + filt_show (rv, fd) + filt_colon (rv, cmdstr) + cmd_filttype (rv) + cmd_cuton (rv) + cmd_cutoff (rv) + cmd_fullon (rv) + cmd_fulloff (rv) + + The 'cmd_' prefix indicates that the routine is called from a colon +command to either print the current value or set the new value for that +field. Other routines should be self-explanatory + +.endhelp _____________________________________________________________________ + +# Default values for the FILTERPARS pset +define DEF_FILT_TYPE RAMP # Filter type +define DEF_CUTON 0 # Filter cuton component no. +define DEF_CUTOFF 0 # Filter cutoff component no. +define DEF_FULLON 0 # Filter fullon component no. +define DEF_FULLOFF 0 # Filter fulloff component no. + + +# FILT_OPEN - Open the Process parameters substructure. This is used to +# reduce the size of the already over-burdened main RV struct. + +procedure filt_open (rv) + +pointer rv #I RV struct pointer + +pointer filt + +begin + iferr (call calloc (filt, SZ_FILTSTRUCT, TY_STRUCT)) + call error (0, "Error allocating sub-structure RV_FILTP.") + + RV_FILTP(rv) = filt + + # Initlialize the values + call filt_get_pars (rv) # set to defaults +end + + +# FILT_CLOSE - Close the process structure. + +procedure filt_close (rv) + +pointer rv #I RV struct pointer + +begin + call mfree (RV_FILTP(rv), TY_STRUCT) +end + + +# FILT_GET_PARS - Read the filter pset into the struct. + +procedure filt_get_pars (rv) + +pointer rv #U RV struct pointer + +pointer fp, clopset() +char buffer[SZ_FNAME] +int clgpseti(), cod_filttype() +errchk clopset + +begin + fp = clopset ("filtpars") + + RVF_CUTON(rv) = clgpseti (fp, "cuton") + RVF_CUTOFF(rv) = clgpseti (fp, "cutoff") + RVF_FULLON(rv) = clgpseti (fp, "fullon") + RVF_FULLOFF(rv) = clgpseti (fp, "fulloff") + + call clgpset (fp, "f_type", buffer, SZ_LINE) + RVF_FILTTYPE(rv) = cod_filttype (buffer) + RVF_LASTKEY(rv) = 'p' # plot power spec. by default + + call clcpset (fp) +end + + +# FILT_PARUPDATE - Update the parameter file with the current values in the +# filter structure. + +procedure filt_parupdate (rv) + +pointer rv #I RV struct pointer + +pointer sp, bp +pointer fp, clopset() + +begin + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + # Update filter params + fp = clopset ("filtpars") + + call clppseti (fp, "cuton", RVF_CUTON(rv)) + call clppseti (fp, "cutoff", RVF_CUTOFF(rv)) + call clppseti (fp, "fullon", RVF_FULLON(rv)) + call clppseti (fp, "fulloff", RVF_FULLOFF(rv)) + + call nam_filttype (rv, Memc[bp]) + call clppset (fp, "f_type", Memc[bp]) + + call clcpset (fp) + call sfree (sp) +end + + +# FILT_UNLEARN -- Reset all of the filter parameters to their default values. + +procedure filt_unlearn (rv) + +pointer rv #I RV struct pointer + +begin + RVF_FILTTYPE(rv) = DEF_FILT_TYPE # RAMP + RVF_CUTON(rv) = DEF_CUTON # 0 + RVF_CUTOFF(rv) = DEF_CUTOFF # 0 + RVF_FULLON(rv) = DEF_FULLON # 0 + RVF_FULLOFF(rv) = DEF_FULLOFF # 0 + + RVF_LASTKEY(rv) = 'f' +end + + +# FILT_SHOW - Show the current filter parameters. + +procedure filt_show (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I output file descriptor + +pointer sp, bp + +begin + if (fd == NULL) + return + + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + call fprintf (fd, "%6tFilterpars PSET Values\n") + call fprintf (fd, "%6t----------------------\n\n") + + # Print the filter info + call fprintf (fd, "Cuton %25t= %-10d\n") + call pargi (RVF_CUTON(rv)) + call fprintf (fd, "Cutoff %25t= %-10d\n") + call pargi (RVF_CUTOFF(rv)) + call fprintf (fd, "Fullon %25t= %-10d\n") + call pargi (RVF_FULLON(rv)) + call fprintf (fd, "Fulloff %25t= %-10d\n") + call pargi (RVF_FULLOFF(rv)) + + call nam_filttype (rv, Memc[bp]) + call fprintf (fd, "Filter type %25t= '%-.10s'\n") + call pargstr (Memc[bp]) + + call fprintf (fd, "\n\n") + call sfree (sp) +end + + +# FILT_COLON -- Process the FILTERPARS task colon commands. + +procedure filt_colon (rv, cmdstr) + +pointer rv #I pointer to the RV structure +char cmdstr[SZ_LINE] #I command string + +pointer sp, cmd, buf +int strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, FILT_KEYWORDS)) { + case FILT_FILT_TYPE: + # Function type of filter + call cmd_filttype (rv) + + case FILT_CUTON: + # Cuton frequency component + call cmd_cuton (rv) + + case FILT_CUTOFF: + # Cutoff frequency component + call cmd_cutoff (rv) + + case FILT_FULLON: + # Fullon frequency component + call cmd_fullon (rv) + + case FILT_FULLOFF: + # Fulloff frequency component + call cmd_fulloff (rv) + } + + call sfree (sp) +end + + +# CMD_CUTOFF - Set/Show the cutoff wavenumber for the filter. + +procedure cmd_cutoff (rv) + +pointer rv + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + RVF_CUTOFF(rv) = ival + if (RV_AUTODRAW(rv) == YES && RV_FILTER(rv) != NONE) + RV_NEWGRAPH(rv) = YES + } else { + call printf ("filtpars.cutoff = %d") + call pargi (RVF_CUTOFF(rv)) + } +end + + +# CMD_CUTON - Set/Show the cuton wavenumber for the filter. + +procedure cmd_cuton (rv) + +pointer rv + +int ival, nscan() + +begin + call gargi(ival) + if (nscan() == 2) { + RVF_CUTON(rv) = ival + if (RV_AUTODRAW(rv) == YES && RV_FILTER(rv) != NONE) + RV_NEWGRAPH(rv) = YES + } else { + call printf ("filtpars.cuton = %d") + call pargi (RVF_CUTON(rv)) + } +end + + +# CMD_FILTTYPE - Set the type of filter to be used in FFT correlation. + +procedure cmd_filttype (rv) + +pointer rv + +pointer sp, buf, bp +int cod_filttype() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + RVF_FILTTYPE(rv) = cod_filttype (Memc[buf+1]) + if (RV_AUTODRAW(rv) == YES && RV_FILTER(rv) != NONE) + RV_NEWGRAPH(rv) = YES + } else { + call nam_filttype (rv, Memc[bp]) + call printf ("filtpars.filttype = '%s'") + call pargstr (Memc[bp]) + } + + call sfree (sp) +end + + +# CMD_FULLOFF - Set/Show the wavenumber at which the filter falls to zero. + +procedure cmd_fulloff (rv) + +pointer rv + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + RVF_FULLOFF(rv) = ival + if (RV_AUTODRAW(rv) == YES && RV_FILTER(rv) != NONE) + RV_NEWGRAPH(rv) = YES + } else { + call printf ("filtpars.fulloff = %d") + call pargi (RVF_FULLOFF(rv)) + } +end + + +# CMD_FULLON - Set/Show the wavenumber at which the filter reaches full value. + +procedure cmd_fullon (rv) + +pointer rv + +int ival, nscan() + +begin + call gargi (ival) + if (nscan() == 2) { + RVF_FULLON(rv) = ival + if (RV_AUTODRAW(rv) == YES && RV_FILTER(rv) != NONE) + RV_NEWGRAPH(rv) = YES + } else { + call printf ("filtpars.fullon = %d") + call pargi (RVF_FULLON(rv)) + } +end diff --git a/noao/rv/fitcom.com b/noao/rv/fitcom.com new file mode 100644 index 00000000..f4aa54c2 --- /dev/null +++ b/noao/rv/fitcom.com @@ -0,0 +1,12 @@ +# Common fitting result parameters. + +real mresid # Mean residual of fit +real sresid # Sigma of residuals +real ccfvar # Variance of CCF +real chisqr # Chis squared of fit +int nfit # Number of points fit +int nfitpars # Number of fitted parameters +int niter # Number of iterations +int binshift # Bin of peak shift in CCF + +common /fitcom/ mresid, sresid, ccfvar, chisqr, nfit, nfitpars, niter, binshift diff --git a/noao/rv/fxcor.par b/noao/rv/fxcor.par new file mode 100644 index 00000000..96e972de --- /dev/null +++ b/noao/rv/fxcor.par @@ -0,0 +1,49 @@ +# Parameter file for the FXCOR task + +# Input parameters +objects,s,a,,,,"List of object spectra" +templates,s,a,,,,"List of template spectra" +apertures,s,h,"*",,,"Apertures to be used" +cursor,*gcur,h,"",,,"Graphics input cursor +" +# Data preparation parameters +continuum,s,h,"both","object|template|both|none",,"Continuum subtract spectra?" +filter,s,h,"none","object|template|both|none",,"Fourier filter the spectra?" +rebin,s,h,"smallest","smallest|largest|object|template",,"Rebin to which dispersion?" +pixcorr,b,h,no,,,"Do a pixel-only correlation?" +osample,s,h,"*",,,"Object regions to be correlated ('*' => all)" +rsample,s,h,"*",,,"Template regions to be correlated" +apodize,r,h,0.2,0.0,0.5,"Apodize end percentage +" +# Fitting function parameters +function,s,h,"gaussian","parabola|gaussian|lorentzian|center1d|sinc",,"Function to fit correlation" +width,r,h,INDEF,,,"Width of fitting region in pixels" +height,r,h,0.0,,,"Starting height of fit" +peak,b,h,no,,,"Is height relative to ccf peak?" +minwidth,r,h,3.,3.,,"Minimum width for fit" +maxwidth,r,h,21.,,,"Maximum width for fit" +weights,r,h,1.,,,"Power defining fitting weights" +background,r,h,0.0,,,"Background level for fit" +window,r,h,INDEF,,,"Size of window in the correlation plot" +wincenter,r,h,INDEF,,,"Center of peak search window +" +# Output parameters +output,f,h,"",,,"Root spool filename for output" +verbose,s,h,"long","short|long|nolog|nogki|txtonly|stxtonly",,"Verbose output to spool file?" +imupdate,b,h,no,,,"Update the image header?" +graphics,s,h,"stdgraph",,,"Graphics output device +" +# Control parameters +interactive,b,h,yes,,,"Interactive graphics?" +autowrite,b,h,yes,,,"Automatically record results?" +autodraw,b,h,yes,,,"Automatically redraw fit results?" +ccftype,s,h,"image","image|text",,"Output type of ccf +" +# PSET parameters +observatory,s,h,"kpno",,,"Observation location database" +continpars,pset,h,"",,,"Continuum processing parameters" +filtpars,pset,h,"",,,"Filter parameters pset" +keywpars,pset,h,"",,,"Header keyword translation pset +" +# Mode parameter +mode,s,h,"ql" diff --git a/noao/rv/keywpars.par b/noao/rv/keywpars.par new file mode 100644 index 00000000..e18342ed --- /dev/null +++ b/noao/rv/keywpars.par @@ -0,0 +1,19 @@ +# PSET file for image header keywords used by RV package + +ra,s,h,"RA",,,"Right Ascension keyword" +dec,s,h,"DEC",,,"Declination keyword" +ut,s,h,"UT",,,"UT of observation keyword" +utmiddle,s,h,"UTMIDDLE",,,"UT of mid-point of observation keyword" +exptime,s,h,"EXPTIME",,,"Exposure time keyword" +epoch,s,h,"EPOCH",,,"Epoch of observation keyword" +date_obs,s,h,"DATE-OBS",,,"Date of observation keyword +" +# Output Image Header Keywords +hjd,s,h,"HJD",,,"Heliocentric Julian date keyword" +mjd_obs,s,h,"MJD-OBS",,,"Modified Julian Date of observation keyword" +vobs,s,h,"VOBS",,,"Observed velocity keyword" +vrel,s,h,"VREL",,,"Relative velocity keyword" +vhelio,s,h,"VHELIO",,,"Heliocentric velocity keyword" +vlsr,s,h,"VLSR",,,"LSR velocity keyword" +vsun,s,h,"VSUN",,,"Epoch of solar motion keyword" +mode,s,h,"ql" diff --git a/noao/rv/keywpars.x b/noao/rv/keywpars.x new file mode 100644 index 00000000..2730b345 --- /dev/null +++ b/noao/rv/keywpars.x @@ -0,0 +1,643 @@ +include "rvpackage.h" +include "rvcomdef.h" +include "rvkeywords.h" + +.help keywpars +.nf ___________________________________________________________________________ +KEYWPARS - Support routines for the 'keywpars' named external pset. + + This file include routines for opening/closing the keyword structure +as well as command handling. Command handling is limited to changing the +parameter values or resetting them to the default values. Routines included +here are as follows. + + keyw_open (rv) + keyw_close (rv) + keyw_get_pars (rv) + keyw_parupdate (rv) + keyw_unlearn (rv) + keyw_show (rv) + keyw_colon (rv, cmdstr) + cmd_ra (rv) + cmd_dec (rv) + cmd_ut (rv) + cmd_utmid (rv) + cmd_exptime (rv) + cmd_epoch (rv) + cmd_date_obs (rv) + cmd_hjd (rv) + cmd_mjd_obs (rv) + cmd_vobs (rv) + cmd_vrel (rv) + cmd_vhelio (rv) + cmd_vlsr (rv) + cmd_vsun (rv) + + The 'cmd_' prefix indicates that the routine is called from a colon +command to either print the current value or set the new value for that +field. Other routines should be self-explanatory + +.endhelp _____________________________________________________________________ + +# Default values for the RVKEYWORDS pset +define DEF_RA "RA" # Right Ascension +define DEF_DEC "DEC" # Declination +define DEF_EXPTIME "EXPTIME" # Exposure time +define DEF_UT "UT" # UT of observation +define DEF_UTMID "UTMIDDLE" # UT middle of observation +define DEF_EPOCH "EPOCH" # Epoch of observation +define DEF_DATE_OBS "DATE-OBS" # Date of observation +define DEF_HJD "HJD" # Heliocentric Julian date +define DEF_MJD_OBS "MJD-OBS" # Modified Julian Date +define DEF_VOBS "VOBS" # Observed radial velocity +define DEF_VHELIO "VHELIO" # Heliocentric radial velocity +define DEF_VLSR "VLSR" # LSR radial velocity +define DEF_VSUN "VSUN" # Solar motion data + + +# KEYW_OPEN - Open the Keyword translation substructure. This is used to +# reduce the size of the already over-burdened main RV struct. Since this is +# in reality a single pointer and not a structure, the pointer allocated is +# of type TY_CHAR. Access to individual elements is controlled by the defined +# macros in the file "rv$rvkeywords.h". + +procedure keyw_open (rv) + +pointer rv #I RV struct pointer + +pointer keyw + +begin + iferr (call calloc (keyw, LEN_KEYWSTRUCT, TY_CHAR)) + call error (0, "Error allocating sub-structure RV_KEYW.") + + RV_KEYW(rv) = keyw + + # Initlialize the values + call keyw_get_pars (rv) +end + + +# KEYW_CLOSE - Close the keyword structure + +procedure keyw_close (rv) + +pointer rv #I RV struct pointer + +begin + call mfree (RV_KEYW(rv), TY_CHAR) +end + + +# KEYW_GET_PARS - Get the Keyword tranlation parameters from the RVKEYWORDS +# pset. + +procedure keyw_get_pars (rv) + +pointer rv #I RV struct pointer + +pointer fp, clopset() +errchk clopset + +begin + fp = clopset ("keywpars") + + call clgpset (fp, "ra", KW_RA(rv), LEN_KEYWEL) + call clgpset (fp, "dec", KW_DEC(rv), LEN_KEYWEL) + call clgpset (fp, "ut", KW_UT(rv), LEN_KEYWEL) + call clgpset (fp, "utmiddle", KW_UTMID(rv), LEN_KEYWEL) + call clgpset (fp, "exptime", KW_EXPTIME(rv), LEN_KEYWEL) + call clgpset (fp, "epoch", KW_EPOCH(rv), LEN_KEYWEL) + call clgpset (fp, "date_obs", KW_DATE_OBS(rv), LEN_KEYWEL) + call clgpset (fp, "hjd", KW_HJD(rv), LEN_KEYWEL) + call clgpset (fp, "mjd_obs", KW_MJD_OBS(rv), LEN_KEYWEL) + call clgpset (fp, "vobs", KW_VOBS(rv), LEN_KEYWEL) + call clgpset (fp, "vrel", KW_VREL(rv), LEN_KEYWEL) + call clgpset (fp, "vhelio", KW_VHELIO(rv), LEN_KEYWEL) + call clgpset (fp, "vlsr", KW_VLSR(rv), LEN_KEYWEL) + call clgpset (fp, "vsun", KW_VSUN(rv), LEN_KEYWEL) + + call clcpset (fp) +end + + +# KEYW_PARUPDATE - Update the pset with the current values of the struct. + +procedure keyw_parupdate (rv) + +pointer rv #I RV struct pointer + +pointer fp, clopset() + +begin + # Update filter params + fp = clopset ("keywpars") + + call clppset (fp, "ra", KW_RA(rv)) + call clppset (fp, "dec", KW_DEC(rv)) + call clppset (fp, "ut", KW_UT(rv)) + call clppset (fp, "utmiddle", KW_UTMID(rv)) + call clppset (fp, "exptime", KW_EXPTIME(rv)) + call clppset (fp, "epoch", KW_EPOCH(rv)) + call clppset (fp, "date_obs", KW_DATE_OBS(rv)) + call clppset (fp, "hjd", KW_HJD(rv)) + call clppset (fp, "mjd_obs", KW_MJD_OBS(rv)) + call clppset (fp, "vobs", KW_VOBS(rv)) + call clppset (fp, "vrel", KW_VREL(rv)) + call clppset (fp, "vhelio", KW_VHELIO(rv)) + call clppset (fp, "vlsr", KW_VLSR(rv)) + call clppset (fp, "vsun", KW_VSUN(rv)) + + call clcpset (fp) +end + + +# KEYW_UNLEARN - Unlearn the pset and replace with the default values. + +procedure keyw_unlearn (rv) + +pointer rv #I RV struct pointer + +begin + call strcpy (DEF_RA, KW_RA(rv), LEN_KEYWEL) + call strcpy (DEF_DEC, KW_DEC(rv), LEN_KEYWEL) + call strcpy (DEF_UT, KW_UT(rv), LEN_KEYWEL) + call strcpy (DEF_UTMID, KW_UTMID(rv), LEN_KEYWEL) + call strcpy (DEF_EXPTIME, KW_EXPTIME(rv), LEN_KEYWEL) + call strcpy (DEF_EPOCH, KW_EPOCH(rv), LEN_KEYWEL) + call strcpy (DEF_DATE_OBS, KW_DATE_OBS(rv), LEN_KEYWEL) + call strcpy (DEF_HJD, KW_HJD(rv), LEN_KEYWEL) + call strcpy (DEF_MJD_OBS, KW_MJD_OBS(rv), LEN_KEYWEL) + call strcpy (DEF_VOBS, KW_VOBS(rv), LEN_KEYWEL) + call strcpy (DEF_VHELIO, KW_VHELIO(rv), LEN_KEYWEL) + call strcpy (DEF_VLSR, KW_VLSR(rv), LEN_KEYWEL) + call strcpy (DEF_VSUN, KW_VSUN(rv), LEN_KEYWEL) +end + + +# KEYW_SHOW - Show the current keyword translation parameters. + +procedure keyw_show (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I output file descriptor + +begin + if (fd == NULL) + return + + call fprintf (fd, "%6tRVKeywords PSET Values\n") + call fprintf (fd, "%6t----------------------\n\n") + + # Print the keyword translation info + call fprintf (fd, "RA keyword%30t= '%s'\n") + call pargstr (KW_RA(rv)) + call fprintf (fd, "DEC keyword%30t= '%s'\n") + call pargstr (KW_DEC(rv)) + call fprintf (fd, "UT keyword%30t= '%s'\n") + call pargstr (KW_UT(rv)) + call fprintf (fd, "UTMIDDLE keyword%30t= '%s'\n") + call pargstr (KW_UTMID(rv)) + call fprintf (fd, "OTIME keyword%30t= '%s'\n") + call pargstr (KW_EXPTIME(rv)) + call fprintf (fd, "EPOCH keyword%30t= '%s'\n") + call pargstr (KW_EPOCH(rv)) + call fprintf (fd, "DATE-OBS keyword%30t= '%s'\n") + call pargstr (KW_DATE_OBS(rv)) + call fprintf (fd, "VHJD keyword%30t= '%s'\n") + call pargstr (KW_HJD(rv)) + call fprintf (fd, "MJD_OBS keyword%30t= '%s'\n") + call pargstr (KW_MJD_OBS(rv)) + call fprintf (fd, "VOBS keyword%30t= '%s'\n") + call pargstr (KW_VOBS(rv)) + call fprintf (fd, "VHELIO keyword%30t= '%s'\n") + call pargstr (KW_VHELIO(rv)) + call fprintf (fd, "VLSR keyword%30t= '%s'\n") + call pargstr (KW_VLSR(rv)) + call fprintf (fd, "VSUN keyword%30t= '%s'\n") + call pargstr (KW_VSUN(rv)) + + call fprintf (fd, "\n\n") +end + + + +# KEYW_COLON -- Process the RVKEYWORDS task colon commands. + +procedure keyw_colon (rv, cmdstr) + +pointer rv #I pointer to the RV structure +char cmdstr[SZ_LINE] #I command string + +pointer sp, cmd, buf +int strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, KEY_KEYWORDS)) { + case KEY_RA: + # Right ascension keyword + call cmd_ra (rv) + + case KEY_DEC: + # Declination keyword + call cmd_dec (rv) + + case KEY_UT: + # Universal time of observation keyword + call cmd_ut (rv) + + case KEY_UTMID: + # Universal time of observation keyword + call cmd_utmid (rv) + + case KEY_EXPTIME: + # Frame exposure time keyword + call cmd_exptime (rv) + + case KEY_EPOCH: + # Epoch of observation keyword + call cmd_epoch (rv) + + case KEY_DATE_OBS: + # Date of observation keyword + call cmd_date_obs (rv) + + case KEY_HJD: + # Heliocentric Julian Date Keyword + call cmd_hjd (rv) + + case KEY_MJD_OBS: + # Observed RV keyword + call cmd_mjd_obs (rv) + + case KEY_VOBS: + # Observed RV keyword + call cmd_vobs (rv) + + case KEY_VREL: + # Relative RV keyword + call cmd_vrel (rv) + + case KEY_VHELIO: + # Heliocentric RV keyword + call cmd_vhelio (rv) + + case KEY_VLSR: + # LSR RV keyword + call cmd_vlsr (rv) + + case KEY_VSUN: + # Solar motion epoch for LSR + call cmd_vsun (rv) + + default: + } + + call sfree (sp) +end + + +# CMD_RA - Set/Show the RA image header keyword. + +procedure cmd_ra (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_RA(rv), LEN_KEYWEL) + } else { + call printf ("RA keyword = '%s'") + call pargstr (KW_RA(rv)) + } + + call sfree (sp) +end + + +# CMD_DEC - Set/Show the DEC image header keyword. + +procedure cmd_dec (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_DEC(rv), LEN_KEYWEL) + } else { + call printf ("DEC keyword = '%s'") + call pargstr (KW_DEC(rv)) + } + + call sfree (sp) +end + + +# CMD_UT - Set/Show the UT image header keyword. + +procedure cmd_ut (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_UT(rv), LEN_KEYWEL) + } else { + call printf ("UT keyword = '%s'") + call pargstr (KW_UT(rv)) + } + + call sfree (sp) +end + + +# CMD_UTMID - Set/Show the UTMID image header keyword. + +procedure cmd_utmid (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_UTMID(rv), LEN_KEYWEL) + } else { + call printf ("UTMIDDLE keyword = '%s'") + call pargstr (KW_UTMID(rv)) + } + + call sfree (sp) +end + + +# CMD_EXPTIME - Set/Show the EXPTIME image header keyword. + +procedure cmd_exptime (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_EXPTIME(rv), LEN_KEYWEL) + } else { + call printf ("EXPTIME keyword = '%s'") + call pargstr (KW_EXPTIME(rv)) + } + + call sfree (sp) +end + + +# CMD_EPOCH - Set/Show the EPOCH image header keyword. + +procedure cmd_epoch (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_EPOCH(rv), LEN_KEYWEL) + } else { + call printf ("EPOCH keyword = '%s'") + call pargstr (KW_EPOCH(rv)) + } + + call sfree (sp) +end + + +# CMD_DATE_OBS - Set/Show the DATE-OBS image header keyword. + +procedure cmd_date_obs (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_DATE_OBS(rv), LEN_KEYWEL) + } else { + call printf ("DATE-OBS keyword = '%s'") + call pargstr (KW_DATE_OBS(rv)) + } + + call sfree (sp) +end + + +# CMD_HJD - Set/Show the HJD image header keyword. + +procedure cmd_hjd (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_HJD(rv), LEN_KEYWEL) + } else { + call printf ("HJD keyword = '%s'") + call pargstr (KW_HJD(rv)) + } + + call sfree (sp) +end + + +# CMD_MJD_OBS - Set/Show the MJD-OBS image header keyword. + +procedure cmd_mjd_obs (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_MJD_OBS(rv), LEN_KEYWEL) + } else { + call printf ("MJD_OBS keyword = '%s'") + call pargstr (KW_MJD_OBS(rv)) + } + + call sfree (sp) +end + + +# CMD_VOBS - Set/Show the VOBS image header keyword. + +procedure cmd_vobs (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_VOBS(rv), LEN_KEYWEL) + } else { + call printf ("VOBS keyword = '%s'") + call pargstr (KW_VOBS(rv)) + } + + call sfree (sp) +end + + +# CMD_VREL - Set/Show the VREL image header keyword. + +procedure cmd_vrel (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_VREL(rv), LEN_KEYWEL) + } else { + call printf ("VREL keyword = '%s'") + call pargstr (KW_VREL(rv)) + } + + call sfree (sp) +end + + +# CMD_VHELIO - Set/Show the VHELIO image header keyword. + +procedure cmd_vhelio (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_VHELIO(rv), LEN_KEYWEL) + } else { + call printf ("VHELIO keyword = '%s'") + call pargstr (KW_VHELIO(rv)) + } + + call sfree (sp) +end + + +# CMD_VLSR - Set/Show the VLSR image header keyword. + +procedure cmd_vlsr (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_VLSR(rv), LEN_KEYWEL) + } else { + call printf ("VLSR keyword = '%s'") + call pargstr (KW_VLSR(rv)) + } + + call sfree (sp) +end + + +# CMD_VSUN - Set/Show the VSUN image header keyword. + +procedure cmd_vsun (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf + +begin + call smark (sp) + call salloc (buf, LEN_KEYWEL, TY_CHAR) + + call gargstr (Memc[buf], LEN_KEYWEL) + if (Memc[buf] != EOS) { + call strcpy (Memc[buf+1], KW_VSUN(rv), LEN_KEYWEL) + } else { + call printf ("Epoch of solar motion keyword = '%s'") + call pargstr (KW_VSUN(rv)) + } + + call sfree (sp) +end diff --git a/noao/rv/mkpkg b/noao/rv/mkpkg new file mode 100644 index 00000000..35bdd6c3 --- /dev/null +++ b/noao/rv/mkpkg @@ -0,0 +1,88 @@ +# MKPKG file for the RV Package + +$call relink +$exit + +update: + $call relink + $call install + ; + +relink: + $set LIBS = "-lasttools -lsmw -lxtools -ldeboor -lcurfit -liminterp -lllsq -lnlfit" + $update libpkg.a + $omake x_rv.x + $link -o xx_rv.e x_rv.o libpkg.a $(LIBS) + ; + +install: + $move xx_rv.e noaobin$x_rv.e + ; + +libpkg.a: + @rvidlines # Update the libraries + + aplists.x rvflags.h <smw.h> rvpackage.h + coloncmds.x rvcont.h rvflags.h rvpackage.h rvsample.h \ + <ctype.h> <error.h> <fset.h> + complex.x <mach.h> <math.h> + contin.x <error.h> rvcont.h rvflags.h rvpackage.h <pkg/gtools.h> + continpars.x rvcomdef.h rvcont.h rvflags.h rvpackage.h + deblend.x <error.h> <gset.h> <mach.h> fitcom.com rvflags.h \ + rvpackage.h + fftmode.x rvcomdef.h rvfilter.h rvflags.h rvpackage.h \ + rvplots.h <gset.h> + fftutil.x rvflags.h rvpackage.h rvplots.h <math.h> + filtpars.x rvcomdef.h rvfilter.h rvflags.h rvpackage.h + keywpars.x rvcomdef.h rvkeywords.h rvpackage.h + numrep.x <mach.h> <math.h> + plotpars.x rvcomdef.h rvflags.h rvpackage.h rvplots.h + prepspec.x rvflags.h rvpackage.h rvsample.h <math.h> + readtlist.x rvflags.h rvpackage.h <imhdr.h> + rvanplot.x <gset.h> rvflags.h rvpackage.h <math.h> + rvbatch.x rvcont.h rvflags.h rvpackage.h + rvcolon.x rvcomdef.h rvflags.h rvpackage.h <gio.h> <gset.h> + rvcorrel.x rvfilter.h rvflags.h rvpackage.h <math.h> + rvcursor.x rvcont.h rvfilter.h rvflags.h rvpackage.h rvplots.h \ + <fset.h> <gset.h> <pkg/gtools.h> + rvdatacheck.x rvflags.h rvpackage.h rvsample.h + rvdrawfit.x rvsinc.com rvflags.h rvpackage.h <gset.h> + rverrmsg.x rvflags.h rvpackage.h + rvfftcorr.x rvcont.h rvflags.h rvpackage.h <math.h> + rvfgauss.x fitcom.com rvflags.h rvpackage.h \ + <gset.h> <math.h> <math/nlfit.h> + rvfilter.x rvfilter.h rvflags.h rvpackage.h <math.h> + rvfitfunc.x fitcom.com rvflags.h rvpackage.h rvsinc.com <gset.h> + rvfparab.x fitcom.com rvflags.h rvpackage.h \ + <gset.h> <math.h> <math/nlfit.h> + rvfuncs.x <mach.h> <math.h> + rvgetim.x <smw.h> <units.h> rvflags.h rvkeywords.h \ + rvpackage.h rvsample.h + rvimutil.x rvflags.h rvkeywords.h rvpackage.h <imhdr.h> + rvinit.x rvsinc.com rvcont.h rvflags.h rvpackage.h \ + rvsample.h <error.h> <pkg/gtools.h> + rvlinefit.x <error.h> <gset.h> <mach.h> rvflags.h rvpackage.h + rvparam.x rvflags.h rvpackage.h rvsample.h <gio.h> <gset.h> + rvplot.x <gset.h> rvflags.h rvpackage.h rvplots.h rvsample.h + rvrebin.x <error.h> rvcont.h rvflags.h rvpackage.h + rvrvcor.x rvflags.h rvkeywords.h rvpackage.h \ + <error.h> <imio.h> <time.h> + rvsample.x rvflags.h rvpackage.h rvsample.h <ctype.h> <gset.h> + rvsinc.x rvsinc.com rvflags.h rvpackage.h <mach.h> <math.h> + rvstrings.x rvcont.h rvfilter.h rvflags.h rvpackage.h rvplots.h + rvsumplot.x <gset.h> rvflags.h rvpackage.h + rvutil.x rvcomdef.h rvflags.h rvkeywords.h rvpackage.h \ + rvsample.h <gset.h> + rvvfit.x fitcom.com rvcont.h rvflags.h rvpackage.h <gset.h> + rvwparam.x rvcomdef.h rvcont.h rvflags.h rvpackage.h <time.h> + rvwrite.x rvcont.h rvflags.h rvkeywords.h rvpackage.h \ + rvsample.h <imhdr.h> + specmode.x rvcomdef.h rvflags.h rvpackage.h rvsample.h <gset.h> + splitplot.x <gset.h> rvflags.h rvpackage.h rvplots.h rvsample.h + t_fxcor.x <ctype.h> rvcomdef.h rvflags.h rvpackage.h rvsample.h \ + <error.h> <gset.h> <imhdr.h> + titles.x <gset.h> rvflags.h rvpackage.h + wrtccf.x rvcont.h rvfilter.h rvflags.h rvpackage.h <imhdr.h> + zzdebug.x rvcomdef.h rvflags.h rvpackage.h \ + <gio.h> <gset.h> <error.h> + ; diff --git a/noao/rv/numrep.x b/noao/rv/numrep.x new file mode 100644 index 00000000..75c6f9e6 --- /dev/null +++ b/noao/rv/numrep.x @@ -0,0 +1,199 @@ +include <math.h> +include <mach.h> + +# NUMREP.X - A collection of routines recoded from Numerical Recipes by +# Press, Flannery, Teukolsky, and Vetterling. Used by permission of the +# authors. Copyright(c) 1986 Numerical Recipes Software. + + +# FOUR1 - Replaces DATA by it's discrete transform, if ISIGN is input +# as 1; or replaces DATA by NN times it's inverse discrete Fourier transform +# if ISIGN is input as -1. Data is a complex array of length NN or, equiv- +# alently, a real array of length 2*NN. NN *must* be an integer power of +# two. + +procedure four1 (data, nn, isign) + +real data[ARB] #U Data array (returned as FFT) +int nn #I No. of points in data array +int isign #I Direction of transform + +double wr, wi, wpr, wpi # Local variables +double wtemp, theta +real tempr, tempi +int i, j, istep +int n, mmax, m + +begin + n = 2 * nn + j = 1 + for (i=1; i<n; i = i + 2) { + if (j > i) { # Swap 'em + tempr = data[j] + tempi = data[j+1] + data[j] = data[i] + data[j+1] = data[i+1] + data[i] = tempr + data[i+1] = tempi + } + m = n / 2 + while (m >= 2 && j > m) { + j = j - m + m = m / 2 + } + j = j + m + } + mmax = 2 + while (n > mmax) { + istep = 2 * mmax + theta = TWOPI / double (isign*mmax) + wtemp = dsin (0.5*theta) + wpr = -2.d0 * wtemp * wtemp + wpi = dsin (theta) + wr = 1.d0 + wi = 0.d0 + for (m=1; m < mmax; m = m + 2) { + for (i=m; i<=n; i = i + istep) { + j = i + mmax + tempr = real (wr) * data[j] - real (wi) * data[j+1] + tempi = real (wr) * data[j + 1] + real (wi) * data[j] + data[j] = data[i] - tempr + data[j+1] = data[i+1] - tempi + data[i] = data[i] + tempr + data[i+1] = data[i+1] + tempi + } + wtemp = wr + wr = wr * wpr - wi * wpi + wr + wi = wi * wpr + wtemp * wpi + wi + } + mmax = istep + } +end + + +# REALFT - Calculates the Fourier Transform of a set of 2N real valued +# data points. Replaces this data (which is stored in the array DATA) by +# the positive frequency half of it's complex Fourier Transform. The real +# valued first and last components of the complex transform are returned +# as elements DATA(1) and DATA(2) respectively. N must be an integer power +# of 2. This routine also calculates the inverse transform of a complex +# array if it is the transform of real data. (Result in this case must be +# multiplied by 1/N). A forward transform is perform for isign == 1, other- +# wise the inverse transform is computed. + +procedure realft (data, N, isign) + +real data[ARB] #U Input data array & output FFT +int N #I No. of points +int isign #I Direction of transfer + +double wr, wi, wpr, wpi, wtemp, theta # Local variables +real c1, c2, h1r, h1i, h2r, h2i +real wrs, wis +int i, i1, i2, i3, i4 +int N2P3 + +begin + # Initialize + theta = PI/double(N) + c1 = 0.5 + + if (isign == 1) { + c2 = -0.5 + call four1 (data,n,1) # Forward transform is here + } else { + c2 = 0.5 + theta = -theta + } + + wtemp = sin (0.5 * theta) + wpr = -2.0d0 * wtemp * wtemp + wpi = dsin (theta) + wr = 1.0D0 + wpr + wi = wpi + n2p3 = 2*n + 3 + + for (i=2; i<=n/2; i = i + 1) { + i1 = 2 * i - 1 + i2 = i1 + 1 + i3 = n2p3 - i2 + i4 = i3 + 1 + wrs = sngl (wr) + wis = sngl (wi) + # The 2 transforms are separated out of Z + h1r = c1 * (data[i1] + data[i3]) + h1i = c1 * (data[i2] - data[i4]) + h2r = -c2 * (data[i2] + data[i4]) + h2i = c2 * (data[i1] - data[i3]) + # Here they are recombined to form the true + # transform of the original real data. + data[i1] = h1r + wr*h2r - wi*h2i + data[i2] = h1i + wr*h2i + wi*h2r + data[i3] = h1r - wr*h2r + wi*h2i + data[i4] = -h1i + wr*h2i + wi*h2r + + wtemp = wr # The reccurrence + wr = wr * wpr - wi * wpi + wr + wi = wi * wpr + wtemp * wpi + wi + } + + if (isign == 1) { + h1r = data[1] + data[1] = h1r + data[2] + data[2] = h1r - data[2] + } else { + h1r = data[1] + data[1] = c1 * (h1r + data[2]) + data[2] = c1 * (h1r - data[2]) + call four1 (data,n,-1) + } + +end + + +# TWOFFT - Given two real input arrays DATA1 and DATA2, each of length +# N, this routine calls cc_four1() and returns two complex output arrays, +# FFT1 and FFT2, each of complex length N (i.e. real length 2*N), which +# contain the discrete Fourier transforms of the respective DATAs. As +# always, N must be an integer power of 2. + +procedure twofft (data1, data2, fft1, fft2, N) + +real data1[ARB], data2[ARB] #I Input data arrays +real fft1[ARB], fft2[ARB] #O Output FFT arrays +int N #I No. of points + +int nn3, nn2, jj, j +real rep, rem, aip, aim + +begin + nn2 = 2 + N + N + nn3 = nn2 + 1 + + jj = 2 + for (j=1; j <= N; j = j + 1) { + fft1[jj-1] = data1[j] # Pack 'em into one complex array + fft1[jj] = data2[j] + jj = jj + 2 + } + + call four1 (fft1, N, 1) # Transform the complex array + fft2[1] = fft1[2] + fft2[2] = 0.0 + fft1[2] = 0.0 + for (j=3; j <= N + 1; j = j + 2) { + rep = 0.5 * (fft1[j] + fft1[nn2-j]) + rem = 0.5 * (fft1[j] - fft1[nn2-j]) + aip = 0.5 * (fft1[j + 1] + fft1[nn3-j]) + aim = 0.5 * (fft1[j + 1] - fft1[nn3-j]) + fft1[j] = rep + fft1[j+1] = aim + fft1[nn2-j] = rep + fft1[nn3-j] = -aim + fft2[j] = aip + fft2[j+1] = -rem + fft2[nn2-j] = aip + fft2[nn3-j] = rem + } + +end diff --git a/noao/rv/plotpars.x b/noao/rv/plotpars.x new file mode 100644 index 00000000..720ec436 --- /dev/null +++ b/noao/rv/plotpars.x @@ -0,0 +1,320 @@ +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" +include "rvplots.h" + +.help plotpars +.nf ___________________________________________________________________________ +PLOTPARS - Support routines for the 'plotpars' named external pset. + + This file include routines for opening/closing the FFT plot structure +as well as command handling. Command handling is limited to changing the +parameter values or resetting them to the default values. Routines included +here are as follows. + + plot_open (rv) + plot_close (rv) + plot_get_pars (rv) + plot_parupdate (rv) + plot_unlearn (rv) + plot_show (rv, fd) + plot_colon (rv, cmdstr) + cmd_plot (rv) + cmd_overlay (rv) + cmd_split_plotx (rv) + cmd_one_image (rv) + cmd_when (rv) + cmd_log_scale (rv) + cmd_fft_zoom (rv) + + The 'cmd_' prefix indicates that the routine is called from a colon +command to either print the current value or set the new value for that +field. Other routines should be self-explanatory + +.endhelp _____________________________________________________________________ + +# The default Fourier plot parameters +define DEF_PLOT AMPLITUDE_PLOT # Default plot type +define DEF_OVERLAY YES # Default filter overlay +define DEF_SPLIT_PLOT SPLIT_PLOT # Default plot type +define DEF_ONE_IMAGE OBJECT_SPECTRUM # Deault for one image plot +define DEF_WHEN BEFORE # Default when to plot +define DEF_LOG_SCALE YES # Default Y-axis scaling +define DEF_FFT_ZOOM 1.0 # Default zoom + + +# PLOT_OPEN - Open the Process parameters substructure. This is used to +# reduce the size of the already over-burdened main RV struct. + +procedure plot_open (rv) + +pointer rv #I RV struct pointer + +pointer plot + +begin + iferr (call calloc (plot, SZ_PLOTSTRUCT, TY_STRUCT)) + call error (0, "Error allocating sub-structure RV_PLOTP.") + + RV_PLOTP(rv) = plot + + # Initlialize the values + call plot_unlearn (rv) # Set to defaults +end + + +# PLOT_CLOSE - Close the process structure. + +procedure plot_close (rv) + +pointer rv #I RV struct pointer + +begin + call mfree (RV_PLOTP(rv), TY_STRUCT) +end + + +# PLOT_UNLEARN -- Reset all of the plot parameters to their default values. + +procedure plot_unlearn (rv) + +pointer rv #I RV struct pointer + +begin + RVP_PLOT(rv) = DEF_PLOT + RVP_OVERLAY(rv) = DEF_OVERLAY + RVP_SPLIT_PLOT(rv) = DEF_SPLIT_PLOT + RVP_ONE_IMAGE(rv) = DEF_ONE_IMAGE + RVP_WHEN(rv) = DEF_WHEN + RVP_LOG_SCALE(rv) = DEF_LOG_SCALE + RVP_FFT_ZOOM(rv) = DEF_FFT_ZOOM +end + + +# PLOT_COLON -- Process the PLOTPARS task colon commands. + +procedure plot_colon (rv, cmdstr) + +pointer rv #I pointer to the RV structure +char cmdstr[SZ_LINE] #I command string + +pointer sp, cmd, buf +int strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, PLOT_KEYWORDS)) { + case PLT_PLOT: + call cmd_plot (rv) + case PLT_OVERLAY: + call cmd_overlay (rv) + case PLT_SPLIT_PLOT: + call cmd_split_plotx (rv) + case PLT_ONE_IMAGE: + call cmd_one_image (rv) + case PLT_WHEN: + call cmd_when (rv) + case PLT_LOG_SCALE: + call cmd_log_scale (rv) + case PLT_FFT_ZOOM: + call cmd_fft_zoom (rv) + default: + } + + call sfree (sp) +end + + +# CMD_PLOT - Set/Show the type of plot to draw. + +procedure cmd_plot (rv) + +pointer rv #I RV struct pointer + +pointer sp, bp +int cod_plotype() + +begin + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[bp], SZ_FNAME) + if (Memc[bp] != EOS) + RVP_PLOT(rv) = cod_plotype (Memc[bp+1]) + else { + call nam_plotype (rv, Memc[bp]) + call printf ("plot = `%s'\n") + call pargstr (Memc[bp]) + call flush (STDOUT) + } + + call sfree (sp) +end + + +# CMD_OVERLAY - Set/Show the filter overlay flag. + +procedure cmd_overlay (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + RVP_OVERLAY(rv) = btoi (bval) + RV_NEWGRAPH(rv) = YES + } else { + call printf ("overlay = %b\n") + call pargb (itob(RVP_OVERLAY(rv))) + } +end + + +# CMD_SPLIT_PLOTX - Set/Show the split plot toggle flag. + +procedure cmd_split_plotx (rv) + +pointer rv #I RV struct pointer + +bool bval +int nscan() + +begin + call gargb (bval) + if (nscan() == 2) { + if (bval) + RVP_SPLIT_PLOT(rv) = SPLIT_PLOT + else + RVP_SPLIT_PLOT(rv) = SINGLE_PLOT + } else { + call printf ("split_plot = %b\n") + if (RVP_SPLIT_PLOT(rv) == SPLIT_PLOT) + call pargb (true) + else + call pargb (false) + } +end + + +# CMD_ONE_IMAGE - Set/Show the type of image to draw on a single plot. + +procedure cmd_one_image (rv) + +pointer rv #I RV struct pointer + +pointer sp, bp + +begin + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[bp], SZ_FNAME) + if (Memc[bp] != EOS) { + if (Memc[bp+1] == 'o') + RVP_ONE_IMAGE(rv) = OBJECT_SPECTRUM + else if (Memc[bp+1] == 't' || Memc[bp+1] == 'r') + RVP_ONE_IMAGE(rv) = REFER_SPECTRUM + else + call rv_errmsg ("Choose one of 'object|template'.") + } else { + call printf ("one_image = `%s'\n") + if (RVP_ONE_IMAGE(rv) == OBJECT_SPECTRUM) + call pargstr ("object") + else + call pargstr ("template") + call flush (STDOUT) + } + + call sfree (sp) +end + + +# CMD_WHEN - Set/Show whether to plot before or after filtering. + +procedure cmd_when (rv) + +pointer rv #I RV struct pointer + +pointer sp, bp + +begin + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + call gargstr (Memc[bp], SZ_FNAME) + if (Memc[bp] != EOS) { + if (Memc[bp+1] == 'b') { + RVP_WHEN(rv) = BEFORE + RV_NEWGRAPH(rv) = YES + } else if (Memc[bp+1] == 'a') { + RVP_WHEN(rv) = AFTER + RV_NEWGRAPH(rv) = YES + } else + call rv_errmsg ("Choose one of `before|after'.") + } else { + call printf ("when = `%s'\n") + if (RVP_WHEN(rv) == BEFORE) + call pargstr ("before") + else + call pargstr ("after") + call flush (STDOUT) + } + call sfree (bp) +end + + +# CMD_LOG_SCALE - Set/Show whether to plot on a log scale. + +procedure cmd_log_scale (rv) + +pointer rv #I RV struct pointer + +bool bval, itob() +int nscan(), btoi() + +begin + call gargb (bval) + if (nscan() == 2) { + RVP_LOG_SCALE(rv) = btoi (bval) + RV_NEWGRAPH(rv) = YES + } else { + call printf ("log_scale = %b\n") + call pargb (itob(RVP_LOG_SCALE(rv))) + } +end + + +# CMD_FFT_ZOOM - Set/Show the FFT zooming factor. + +procedure cmd_fft_zoom (rv) + +pointer rv #I RV struct pointer + +real rval +int nscan() + +begin + call gargr (rval) + if (nscan() == 2) { + if (rval < 1.) + call rv_errmsg ("Warning: Zoom must be >= 1.0") + else + RVP_FFT_ZOOM(rv) = rval + RV_NEWGRAPH(rv) = YES + } else { + call printf ("zoom = %f\n") + call pargr (RVP_FFT_ZOOM(rv)) + } +end diff --git a/noao/rv/prepspec.x b/noao/rv/prepspec.x new file mode 100644 index 00000000..e309e692 --- /dev/null +++ b/noao/rv/prepspec.x @@ -0,0 +1,142 @@ +include <math.h> +include "rvpackage.h" +include "rvflags.h" +include "rvsample.h" + +# PREP_SPEC - Prepare the input spectra prior to a Fourier transform. Data +# are centered in the transform array according to the number of points covered +# by both spectra. Apply the DC bias and the cosine bell. + +procedure prep_spec (rv, ssp, npts, fftnpts, datanpts, data, tform, ishift, + apodize) + +pointer rv #I RV struct pointer +pointer ssp #I Sample struct pointer +int npts #I npts in global data array +int fftnpts #I Output size of prepared array +int datanpts #I npts in original data array +pointer data #I pointer to original temp space +pointer tform #I Prepared transform work space +int ishift #I Shift of spectrum +int apodize #I Apodize the data? + +pointer sp, tp +int i, iremain, num +real dc, rv_avgpix() + +define FORWARD -1 + +begin + call smark (sp) + call salloc (tp, fftnpts, TY_REAL) + + # Do some error checking. + if (data == NULL || tform == NULL) + call error (0, "NULL pointer passed to prep_spec()") + else if (ishift < 0) + call error (0, "Negative shift found preparing spectrum.") + + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv), "prep_spec:\t") + call d_printf (DBG_FD(rv), "ishift=%d np=%d dnp=%d fnp=%d\n") + call pargi (ishift); call pargi(npts) + call pargi (datanpts); call pargi(fftnpts) + } + + # Get things started. + call aclrr (Memr[tform], fftnpts) + #call amovr (Memr[data], Memr[tform+ishift], npts) + call amovr (Memr[data], Memr[tform+ishift], datanpts) + + # Generate size dependent parameters. + if (SR_COUNT(ssp) != ALL_SPECTRUM && apodize == YES) { + #call prep_samples (rv, ssp, Memr[tform+ishift], npts, apodize) + call prep_samples (rv, ssp, Memr[tform], npts, apodize) + } else { + num = datanpts + if (apodize == YES) { + call fft_cosbel (Memr[tform+ishift], num, FORWARD, + RV_APODIZE(rv)) + } + } + + # Center the data in the transform arrays. + if (fftnpts != npts) { + call aclrr (Memr[tp], fftnpts) + call amovr (Memr[tform], Memr[tp], npts) + call aclrr (Memr[tform], fftnpts) + iremain = (fftnpts-npts) / 2 + do i = 1,npts # get centered + Memr[tform+iremain+i-1] = Memr[tp+i-1] + } else + iremain = 0 + + # Now compute the bias to raise zero level to spectrum mean. + dc = rv_avgpix (Memr[tform], fftnpts) # compute DC level + call asubkr (Memr[tform], dc, Memr[tform], fftnpts) # apply DC bias + + call sfree (sp) +end + + +# PREP_SAMPLES - Prepare the data by masking according to the samples and +# apodizing each region. + +procedure prep_samples (rv, ssp, data, npts, apodize) + +pointer rv #I RV struct pointer +pointer ssp #I Sample struct pointer +real data[ARB] #U Data array +int npts #I Npts in array +int apodize #I Apodize the data? + +int i, j, k, np, left, right + +begin + left = 1 + if (SR_UNITS(ssp) == PIXELS) { + #right = nint (SRANGE(ssp,1) - RV_GLOB_W1(rv) + 1) + right = SRANGE(ssp,1) - RV_GLOB_W1(rv) + 1 + } else { + right = nint ((log10(SRANGE(ssp,1)) - RV_GLOB_W1(rv)) / + RV_OWPC(rv)) + 1 + } + do i = 1, SR_COUNT(ssp)+1 { + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv), "\tl=%g r=%g -- s=%g e=%g\n") + call pargi (left) ; call pargi (right) + call pargr (SRANGE(ssp,i)) ; call pargR (ERANGE(ssp,i)) + } + + k = 1 + j = left + np = right - left + 1 + while (k <= np) { + data[j] = 0.0 + j = j + 1 + k = k + 1 + } + if (i == SR_COUNT(ssp)+1) + return + + if (SR_UNITS(ssp) == PIXELS) { + #left = nint ((ERANGE(ssp,i) - RV_GLOB_W1(rv) + 1) + 1) + left = (ERANGE(ssp,i) - RV_GLOB_W1(rv) + 1) + 1 + } else { + left = nint ((log10(ERANGE(ssp,i)) - RV_GLOB_W1(rv)) / + RV_OWPC(rv)) + 1 + } + if (apodize == YES) + call fft_cosbel (data[right], left-right+1, -1, RV_APODIZE(rv)) + if (i == SR_COUNT(ssp)) { + right = npts + } else { + if (SR_UNITS(ssp) == PIXELS) { + right = SRANGE(ssp,i+1) - RV_GLOB_W1(rv) + 1 + } else { + right = nint ((log10(SRANGE(ssp,i+1)) - RV_GLOB_W1(rv)) / + RV_OWPC(rv)) + 1 + } + } + } +end diff --git a/noao/rv/readtlist.x b/noao/rv/readtlist.x new file mode 100644 index 00000000..ece1eb0b --- /dev/null +++ b/noao/rv/readtlist.x @@ -0,0 +1,78 @@ +include <imhdr.h> +include "rvflags.h" +include "rvpackage.h" + +# READ_TEMPLATE_LIST - What it says, read the list pointer and get all of +# image spectra. Checks for max number of template spectra and returns the +# number of templates read or ERR_READ. + +int procedure read_template_list (rv, list) + +pointer rv #I RV struct pointer +pointer list #I Template file list pointer + +pointer sp, name +int i, ntemps, npts + +int imtlen(), imtrgetim(), get_spec() +real rv_imtempvel() +errchk immap, imtrgetim, realloc, get_spec + +define error_ 99 + +begin + call smark (sp) + call salloc (name, SZ_FNAME, TY_CHAR) + + # Do some simple error checking + if (list == NULL) { + call rv_errmsg ("No input images in template list.") + goto error_ + } + ntemps = imtlen(list) + if (ntemps > MAXTEMPS) { + call eprintf("Too many images in template list (MAXTEMPS=%d)") + call pargi (MAXTEMPS) + call flush (STDERR) + goto error_ + } + + # Start reading the files and storing them + npts = 0 + call realloc (RV_TCODE(rv), ntemps, TY_INT) + call realloc (RV_TEMPVEL(rv), ntemps, TY_REAL) + RV_TEMPCODE(rv) = 0 + do i = 1, ntemps { + RV_TEMPNUM(rv) = i + if (imtrgetim(list, i, Memc[name], SZ_FNAME) == EOF) { + call rv_errmsg ("Error getting image name from list.") + goto error_ + } + + RV_TEMPCODE(rv) = RV_TEMPCODE(rv) + 1 + TEMPCODE(rv,i) = RV_TEMPCODE(rv) + TEMPVEL(rv,i) = rv_imtempvel (rv, Memc[name]) + } + + # Now read the first template. + RV_TEMPNUM(rv) = 1 + RV_NTEMPS(rv) = ntemps + call realloc (RV_RIMAGE(rv), SZ_FNAME, TY_CHAR) + if (imtrgetim(list, 1, RIMAGE(rv), SZ_FNAME) == EOF) + goto error_ + if (get_spec(rv,RIMAGE(rv),REFER_SPECTRUM) == ERR_READ) { + call sfree (sp) + call error (0,"Error reading template.") + } + RV_TEMPCODE(rv) = TEMPCODE(rv,1) + + call sfree (sp) + if (list != NULL) + call imtrew (list) # rewind list pointer + return (ntemps) + +error_ call sfree (sp) + if (list != NULL) + call imtrew (list) # rewind list pointer + return (ERR_READ) +end diff --git a/noao/rv/rv.cl b/noao/rv/rv.cl new file mode 100644 index 00000000..c9fbf72b --- /dev/null +++ b/noao/rv/rv.cl @@ -0,0 +1,23 @@ +#{ RV -- Radial Velocity Analysis Package + +# Define the package +package rv + +# Executables +task fxcor, + rvidlines, + rvreidlines = "rv$x_rv.e" + +task rvcorrect = "astutil$x_astutil.e" + +# PSET Tasks +task filtpars = "rv$filtpars.par" +task continpars = "rv$continpars.par" +task keywpars = "rv$keywpars.par" + +# Hidden tasks +task rvdebug = "rv$rvdebug.par" + hidetask ("rvdebug") + +keep +clbye() diff --git a/noao/rv/rv.hd b/noao/rv/rv.hd new file mode 100644 index 00000000..eb005b2f --- /dev/null +++ b/noao/rv/rv.hd @@ -0,0 +1,17 @@ +# Help directory for the RV package + +$doc = "noao$rv/doc/" +$rv = "noao$rv/" +$rvid = "noao$rv/rvidlines/" +#$astutil = "noao$astutil/" + +filtpars hlp=doc$filtpars.hlp, src=rv$filtpars.par +continpars hlp=doc$continpars.hlp, src=rv$continpars.par +keywpars hlp=doc$keywpars.hlp, src=rv$keywpars.par +fxcor hlp=doc$fxcor.hlp, src=rv$t_fxcor.x +rvidlines hlp=doc$rvidlines.hlp, src=rvid$t_identify.x +rvreidlines hlp=doc$rvreidlines.hlp, src=rvid$t_reidentify.x + +#rvcorrect hlp=astutil$doc/rvcorrect.hlp, src=astutil$t_rvcorrect.x + +revisions sys=rv$Revisions diff --git a/noao/rv/rv.men b/noao/rv/rv.men new file mode 100644 index 00000000..7b09ab8c --- /dev/null +++ b/noao/rv/rv.men @@ -0,0 +1,7 @@ + continpars - Edit continuum subtraction parameters + filtpars - Edit the filter function parameters + fxcor - Radial velocities via Fourier cross correlation + keywpars - Translate the image header keywords used in RV package + rvcorrect - Compute radial velocity corrections + rvidlines - Measure radial velocities from spectral lines + rvreidlines - Reidentify spectral lines and measure radial velocities diff --git a/noao/rv/rv.par b/noao/rv/rv.par new file mode 100644 index 00000000..b33d51b2 --- /dev/null +++ b/noao/rv/rv.par @@ -0,0 +1,12 @@ +# RV package parameter file + +dispaxis,i,h,1,1,3,"Image axis for 2D/3D images" +nsum,s,h,"1",,,"Number of lines/columns to sum for 2D/3D images" +z_threshold,r,h,0.2,,,"Redshift threshold for writing z values" +tolerance,r,h,0.00001,,,"Fitting tolerance in pixels" +maxiters,i,h,100,,,"Max number of fit iterations" +interp,s,h,"poly5","|nearest|linear|poly3|poly5|spline3|sinc|",,"Data rebinning interpolator" +line_color,i,h,1,1,9,"Overlay vector color" +text_color,i,h,1,1,9,"Graphics text color" +observatory,s,h,"observatory",,,Observatory +version,s,h,"February 23, 1993" diff --git a/noao/rv/rvanplot.x b/noao/rv/rvanplot.x new file mode 100644 index 00000000..cb6003c5 --- /dev/null +++ b/noao/rv/rvanplot.x @@ -0,0 +1,118 @@ +include <gset.h> +include <math.h> +include "rvpackage.h" +include "rvflags.h" + + +# RV_ANPLOT - Write the split-plot of the correlation function and anti- +# symmetric noise component to the metacode file, or screen. + +procedure rv_anplot (rv, gp) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer + +int i +real xp, yp, step +real vx1, vx2, vy1, vy2 # Viewport boundaries on input + +begin + if (gp == NULL) + return # No-op + + # Save the current viewport + call ggview (gp, vx1, vx2, vy1, vy2) + + # Clear the screen + call gclear (gp) + + # Draw the two plots to the screen + call split_plot (rv, gp, TOP, WRKPIXY(rv,1), RV_CCFNPTS(rv), + ANTISYM_PLOT, CORRELATION_PLOT) + call split_plot (rv, gp, BOTTOM, ANTISYM(rv,1), RV_CCFNPTS(rv), + OBJECT_SPECTRUM, ANTISYM_PLOT) + + # Restore the viewport to the way we found it originally + call gsview (gp, vx1-0.1, vx2, vy1, vy2) + call gflush (gp) + + # Now get the coords to draw the text + call gswind (gp, 0.0, 1.0, 0.0, 1.0) # set to NDC space + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + xp = 0.15 + step = 0.15 + do i = 1, 6 { + yp = -0.05 + call an_text (rv, gp, xp, yp, -i) # do the titles + yp = -0.1 + call an_text (rv, gp, xp, yp, i) # do the numbers + xp = xp + step + } + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gflush (gp) +end + + +# AN_TEXT - Write the text string to the screen at the specified point. + +procedure an_text (rv, gp, xp, yp, lnum) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +real xp, yp #I Position +int lnum #I Line to write + +pointer sp, bp +real sigmaa, eps + +begin + # Allocate working space + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + switch (lnum) { + case -1: + call strcpy ("Height", Memc[bp], SZ_LINE) + case -2: + call strcpy (" R", Memc[bp], SZ_LINE) + case -3: + call strcpy (" Sigma ", Memc[bp], SZ_LINE) + case -4: + call strcpy ("Epsilon", Memc[bp], SZ_LINE) + case -5: + if (RV_DCFLAG(rv) != -1) + call strcpy (" CZ", Memc[bp], SZ_LINE) + else + call strcpy ("Shift", Memc[bp], SZ_LINE) + case -6: + call strcpy (" +/-", Memc[bp], SZ_LINE) + case 1: + call sprintf (Memc[bp], SZ_LINE, "%-.4f") + call pargr (RV_HEIGHT(rv)) + case 2: + call sprintf (Memc[bp], SZ_LINE, "%-.4f") + call pargr (RV_R(rv)) + case 3: + sigmaa = RV_HEIGHT(rv) / (RV_R(rv) * SQRTOF2) + call sprintf (Memc[bp], SZ_LINE, "%-.5f") + call pargr (sigmaa) + case 4: + eps = (TWOPI * RV_FWHM(rv)) / (RV_R(rv)+1.0) / 8.0 + call sprintf (Memc[bp], SZ_LINE, "%-.5f") + call pargr (eps) + case 5: + call sprintf (Memc[bp], SZ_LINE, "%-.3f") + if (RV_DCFLAG(rv) != -1) + call pargd (RV_VCOR(rv)) + else + call pargr (RV_SHIFT(rv)) + case 6: + call sprintf (Memc[bp], SZ_LINE, "%-.3f") + call pargd (RV_ERROR(rv)) + } + + # Write the text + call gtext (gp, xp, yp, Memc[bp], "") + + call sfree (sp) +end diff --git a/noao/rv/rvbatch.x b/noao/rv/rvbatch.x new file mode 100644 index 00000000..f26b93d7 --- /dev/null +++ b/noao/rv/rvbatch.x @@ -0,0 +1,348 @@ +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" + +# RV_BATCH - Process the input list in batch mode with fixed parameters. + +procedure rv_batch (rv, infile, rinfile) + +pointer rv #I RV struct pointer +pointer infile #I Object input file list pointer +pointer rinfile #I Template input list pointer + +pointer sp, fd, rim +int ntemps, naps, tcount, apcount, stat +bool init_hdr, written + +int imtrgetim(), next_spec(), next_ap(), get_spec() +int rv_data_check() + +define write_ 99 + +begin + # Open debugging log + call op_debug (rv) + + call smark (sp) + call salloc (rim, SZ_FNAME, TY_CHAR) + + RV_RECORD(rv) = 0 + RV_TEMPNUM(rv) = 0 + ntemps = RV_NTEMPS(rv) + naps = NUMAPS(rv) + + RV_APNUM(rv) = 1 + RV_IMNUM(rv) = 1 + init_hdr = true + repeat { # For each of the object spectra + + # For each aperture in the list + do apcount = 1, naps { + + if ((RV_CONTINUUM(rv) == OBJ_ONLY || + RV_CONTINUUM(rv) == BOTH) && OBJCONT(rv) == NO) { + call do_continuum (rv, OBJECT_SPECTRUM) + } + RV_APNUM(rv) = APLIST(rv,apcount) + + # For each template spectrum + do tcount = 1, ntemps { + + # Check the data before continuing + RV_TEMPNUM(rv) = tcount + if (rv_data_check(rv) != OK) + break + + # Reset some parameters + call reset_errcom (rv) + + #REFCONT(rv) = NO + if ((RV_CONTINUUM(rv) == TEMP_ONLY || + RV_CONTINUUM(rv) == BOTH) && REFCONT(rv) == NO) + call do_continuum (rv, REFER_SPECTRUM) + + # Jump right into it and get the correlation + call rv_batch_xcor (rv, tcount, apcount, YES, YES, YES) + + # Initialize the output header file. + if (init_hdr) { + fd = RV_TXFD(rv) + if (fd != NULL) { + call rv_param (rv, fd, "fxcor") + call rv_tempcodes (rv, fd) + call rv_prdeltav (rv, fd) + call fprintf (fd, "# \n") + call rv_hdr (rv, fd) + } + init_hdr = false + } + +write_ call rv_imtitle (RIMAGE(rv), TEMPNAME(rv), SZ_FNAME) + if (RV_VERBOSE(rv) == OF_SHORT || + RV_VERBOSE(rv) == OF_STXTONLY) { + call rv_write_short (rv, fd) + } else { + call rv_verbose_fit (rv, RV_VBFD(rv)) + call rv_write_long (rv, fd) + } + if (RV_IMUPDATE(rv) == YES) # update image header + call rv_imupdate (rv) + call rv_eplot (rv, RV_MGP(rv)) + written = TRUE + RV_RECORD(rv) = RV_RECORD(rv) + 1 + + # Get the next template image to use + if (tcount+1 <= ntemps) { + if (imtrgetim(rinfile,tcount+1,Memc[rim],SZ_FNAME)!=EOF) { + call strcpy (Memc[rim], RIMAGE(rv), SZ_FNAME) + call rv_imtitle (Memc[rim],TEMPNAME(rv),SZ_FNAME) + RV_TEMPNUM(rv) = tcount + 1 + if (get_spec(rv,Memc[rim],REFER_SPECTRUM)==ERR_READ) + call error (0, "Error reading next template.") + RV_TEMPCODE(rv) = 'A' + tcount + } + } + + } # End of template loop + + # Update the image apertures + if (apcount < naps) + stat = next_ap (rv, written) + + # Here we need to reset the template stuff + if (ntemps == 1 || naps == 1) + next + if (imtrgetim(rinfile, 1, Memc[rim], SZ_FNAME) != EOF) { + RV_TEMPNUM(rv) = 1 + call strcpy (Memc[rim], RIMAGE(rv), SZ_FNAME) + call rv_imtitle (Memc[rim], TEMPNAME(rv), SZ_FNAME) + if (get_spec(rv,Memc[rim],REFER_SPECTRUM)==ERR_READ) + call error (0, "Error reading next template.") + RV_TEMPCODE(rv) = 'A' + } else { + call rv_errmsg("Error getting template name from list.") + break + } + } # End of aperture loop + + # Now we need to reset the apertures for the next images + CURAPNUM(rv) = 1 + RV_APNUM(rv) = APLIST(rv,1) + + # Check to see if we can get another image, otherwise quit + if (RV_IMNUM(rv)+1 <= RV_NOBJS(rv)) { + # Try to read the image if no error + if (next_spec (rv, infile, written) != OK) { + call rv_errmsg ("Error reading next object image.") + break + } + } else + break # That's it folks! + + # We got another object so we need to reset the template stuff + if (imtrgetim(rinfile, 1, Memc[rim], SZ_FNAME) != EOF) { + RV_TEMPNUM(rv) = 1 + call strcpy (Memc[rim], RIMAGE(rv), SZ_FNAME) + call rv_imtitle (Memc[rim], TEMPNAME(rv), SZ_FNAME) + if (get_spec(rv,Memc[rim],REFER_SPECTRUM)==ERR_READ) + call error (0, "Error reading next template.") + RV_TEMPCODE(rv) = 'A' + } else { + call rv_errmsg ("Error getting template name from list.") + break + } + } # End of object loop + + call sfree (sp) +end + + +# RV_BATCH_XCOR - Process the input list in batch mode with fixed parameters + +procedure rv_batch_xcor (rv, tcount, apcount, do_comp, do_plot, comp_win) + +pointer rv #I RV struct pointer +int tcount #I Template number in list +int apcount #I Aperture number in list +int do_comp #I Do xcor computation? +int do_plot #I Draw the ccf plot? +int comp_win #I Compute a new window center? + +real shift, sigma, max +int ishift, npts, istart, iend, stat +real rv_maxpix() +int rv_getshift(), rv_rvcorrect() + +begin + # Set some things up + call reset_errcom (rv) + RV_FITDONE(rv) = NO + + # Let 'em know what we're up to. + if (RV_INTERACTIVE(rv) == YES && do_comp == YES) { + call printf ("Cross-Correlating %s[%d] with %s[%d].\n") + call pargstr(IMAGE(rv)) + call pargi(RV_OAPNUM(rv)) + call pargstr(RIMAGE(rv)) + call pargi(RV_RAPNUM(rv)) + call flush (STDOUT) + } + + # Now do the debug output + if (DBG_DEBUG(rv) == YES) { + call d_printf (DBG_FD(rv), "rvxbatch: imnum=%d ap=%d temp=%d ") + call pargi(RV_IMNUM(rv));call pargi(apcount);call pargi(tcount) + call d_printf (DBG_FD(rv), " object=:%s: temp=:%s:\n") + call pargstr(IMAGE(rv));call pargstr(RIMAGE(rv)) + } + + # Jump right into it and get the correlation + if (do_comp == YES) + call rv_fftcorr (rv, NO) + + # Compute window center and size + call rv_gwindow (rv, comp_win, istart, npts) + + # If interactive, draw the ccf plot here now that everything's computed + if (RV_INTERACTIVE(rv) == YES && do_plot == YES) + call rv_plot (rv, CORRELATION_PLOT) + + # Get the endpoints to fit + ishift = rv_getshift (WRKPIXY(rv,istart), npts, MAXIMUM) + istart - 1 + max = rv_maxpix (WRKPIXY(rv,istart), npts) + if (!IS_INDEF(RV_FITWIDTH(rv))) { + if (RV_FITWIDTH(rv) < RV_MINWIDTH(rv)) + RV_FITWIDTH(rv) = int (RV_MINWIDTH(rv)) + else if (RV_FITWIDTH(rv) > RV_MAXWIDTH(rv)) + RV_FITWIDTH(rv) = int (RV_MAXWIDTH(rv)) + + istart = ishift - int (RV_FITWIDTH(rv) / 2) + if (((RV_FITWIDTH(rv)/2.)-int(RV_FITWIDTH(rv)/2.)) > 0.0) + iend = ishift + int (RV_FITWIDTH(rv) / 2) + else + iend = ishift + int (RV_FITWIDTH(rv) / 2 - 1) + npts = int (iend - istart + 1) + + # Call the fitting routine and get center of fit and sigma + call rv_fit (rv, WRKPIXX(rv,1), WRKPIXY(rv,1), istart, iend, + npts, ishift, shift, sigma) + if (RV_ERRCODE(rv) == ERR_FIT) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Fit did not converge.") + else + call rv_err_comment (rv, "Fit did not converge.", "") + return + } + RV_SHIFT(rv) = shift + RV_SIGMA(rv) = sigma + + # do velocity corrections + stat = rv_rvcorrect (rv, shift, sigma, RV_VOBS(rv), RV_VCOR(rv), + RV_ERROR(rv)) + + if (RV_INTERACTIVE(rv) == YES) + call rv_writeln (rv, STDOUT) + + } else if (IS_INDEF(RV_FITWIDTH(rv))) { + if (RV_PEAK(rv) == NO) { + if (max < RV_FITHGHT(rv) && RV_INTERACTIVE(rv) == YES) { + call printf ("No points fit - height set too high.\n") + return + } + call rv_yfit (rv, RV_FITHGHT(rv), YES) + } else + call rv_yfit (rv, (RV_FITHGHT(rv)*WRKPIXY(rv,ishift)), YES) + } +end + + +# RV_GWINDOW - Get the window size and center sizes from the input parameters +# or current setting. Does some bounds checking to limit the window to the +# actual ccf plot. Explanation of the window parameters: +# +# RV_WINPAR - Input "window" parameter +# RV_WINCENPAR - Input "wincenter" parameter +# RV_WINDOW - Size of window (in lags) +# RV_WINCENTER - Array index into CCF +# RV_WINL - Left edge of window in +/- lags +# RV_WINR - Right edge of window in +/- lags + +procedure rv_gwindow (rv, comp_win, istart, npts) + +pointer rv #I RV struct pointer +int comp_win #I Compute a new window center? +int istart #O Start of window +int npts #O Npts in window + +int rv_getshift() +real rv_vel2shift + +begin + # Get the window size parameters + if (IS_INDEF(RV_WINPAR(rv))) { + RV_WINDOW(rv) = 20 + } else { + if (RV_DCFLAG(rv) == -1) + RV_WINDOW(rv) = RV_WINPAR(rv) + else + RV_WINDOW(rv) = max (2, nint (rv_vel2shift(rv,RV_WINPAR(rv)))) + } + npts = 2 * RV_WINDOW(rv) + + # Now compute the window center + if (comp_win == YES) { + if (IS_INDEF(RV_WINCENPAR(rv))) { + RV_WINCENTER(rv) = rv_getshift (WRKPIXY(rv,1), RV_CCFNPTS(rv), + MAXIMUM) + istart = RV_WINCENTER(rv) + 1 - RV_WINDOW(rv) + } else { + if (RV_DCFLAG(rv) == -1) { + RV_WINCENTER(rv) = int (RV_CCFNPTS(rv)/2 + + RV_WINCENPAR(rv)) + 1 + } else { + RV_WINCENTER(rv) = int (RV_CCFNPTS(rv)/2 + + nint (rv_vel2shift(rv,RV_WINCENPAR(rv)))) + 1 + if (!IS_INDEF(TEMPVEL(rv,RV_TEMPNUM(rv)))) { + RV_WINCENTER(rv) = RV_WINCENTER(rv) - + rv_vel2shift(rv,TEMPVEL(rv,RV_TEMPNUM(rv))) + } + } + istart = RV_WINCENTER(rv) + 1 - RV_WINDOW(rv) + } + } else + istart = RV_WINCENTER(rv) + 1 - RV_WINDOW(rv) + + # Boundary checks + if (RV_WINDOW(rv) > RV_CCFNPTS(rv)/2) { + RV_WINDOW(rv) = 20 + call rv_err_comment (rv, + "Warning: Window too large - reset to 20 lags.", "") + } + if (RV_WINCENTER(rv) > RV_CCFNPTS(rv)) { + RV_WINCENTER(rv) = rv_getshift (WRKPIXY(rv,1), RV_CCFNPTS(rv), + MAXIMUM) + call rv_err_comment (rv, + "Warning: Wincenter too large - reset to max peak.", "") + istart = RV_WINCENTER(rv) + 1 - RV_WINDOW(rv) + } + if ((RV_WINCENTER(rv)-RV_WINDOW(rv)) < 1) { + RV_WINL(rv) = WRKPIXX(rv,1) + RV_WINR(rv) = RV_WINL(rv) + RV_WINDOW(rv) + istart = 1 + } else if ((RV_WINCENTER(rv)+RV_WINDOW(rv)) > RV_CCFNPTS(rv)) { + RV_WINL(rv) = WRKPIXX(rv,RV_CCFNPTS(rv) - RV_WINDOW(rv)) + RV_WINR(rv) = WRKPIXX(rv,RV_CCFNPTS(rv)) + istart = RV_CCFNPTS(rv) - RV_WINDOW(rv) + } else { + RV_WINL(rv) = WRKPIXX(rv,RV_WINCENTER(rv) - RV_WINDOW(rv)) + RV_WINR(rv) = WRKPIXX(rv,RV_WINCENTER(rv) + RV_WINDOW(rv)) + } + npts = RV_WINR(rv) - RV_WINL(rv) + 1 + + if (DBG_DEBUG(rv) == YES) { + call d_printf(DBG_FD(rv), "rv_gwindow:\n") + call d_printf (DBG_FD(rv), "\twcent,window=%f,%f wl,wr=%f,%f\n") + call pargi(RV_WINCENTER(rv)); call pargi(RV_WINDOW(rv)) + call pargi(RV_WINL(rv)); call pargi(RV_WINR(rv)) + } +end diff --git a/noao/rv/rvcolon.x b/noao/rv/rvcolon.x new file mode 100644 index 00000000..c827524d --- /dev/null +++ b/noao/rv/rvcolon.x @@ -0,0 +1,304 @@ +include <gset.h> +include <gio.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" + +# RV_COLON -- Process the task colon commands. + +int procedure rv_colon (rv, cmdstr, written, infile, ref_infile, res_infile) + +pointer rv #I pointer to the RV structure +char cmdstr[SZ_LINE] #I Command string +bool written #I Results written yet? +pointer infile #U Input file list pointer +pointer ref_infile #U Template file list pointer +pointer res_infile #U Results file list pointer + +pointer sp, cmd +int strdic() +int rv_xcor_colon() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Get the command. + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call sfree (sp) + return (OK) + } + + # Process the command. + if (strdic(Memc[cmd], Memc[cmd], SZ_LINE, CONT_KEYWORDS) != 0) { + # Process the CONTPARS pset commands + call cont_colon (rv, cmdstr) + + } else if (strdic(Memc[cmd], Memc[cmd], SZ_LINE, KEY_KEYWORDS) != 0) { + # Process the RVKEYWORDS pset commands + call keyw_colon (rv, cmdstr) + + } else if (strdic(Memc[cmd], Memc[cmd], SZ_LINE, FILT_KEYWORDS) != 0) { + # Process the FILTERPARS pset commands + call filt_colon (rv, cmdstr) + + } else if (strdic(Memc[cmd], Memc[cmd], SZ_LINE, DEBUG_KEYWORDS) != 0) { + # Process the DEBUG commands + call rv_debug (rv, cmdstr) + + } else { + # Now punt and send it off to the task + if (rv_xcor_colon(rv,cmdstr,written,infile,ref_infile) == QUIT) + return (QUIT) + } + + call sfree (sp) + return (OK) +end + + +# RV_XCOR_COLON - Procedure to process the colon commands defined below. Most +# commands are for interactive editing of parameters to the task. + +int procedure rv_xcor_colon (rv, cmdstr, written, infile, rinfile) + +pointer rv #I RV struct pointer +char cmdstr[SZ_LINE] #I Command +bool written #I Results written yet? +int infile #U Input list file pointer +int rinfile #U Input list file pointer + +pointer sp, cmd, buf +int strdic() +int cmd_regions(), cmd_objects(), cmd_tnum() +int cmd_next(), cmd_previous(), cmd_refspec() + +define error_ 99 + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, RVX_KEYWORDS)) { + case RVX_APERTURES: + # Set/Show the aperture processing list + call cmd_aplist (rv, written) + + case RVX_APNUM: + # Set/Show the current aperture number to process + call cmd_apnum (rv, written) + + case RVX_APODIZE: + # Set/Show the apodize percentage + call cmd_apodize (rv) + + case RVX_AUTODRAW: + # Set/Show the autowrite parameter toggle + call cmd_autodraw (rv) + + case RVX_AUTOWRITE: + # Set/Show the autowrite parameter toggle + call cmd_autowrite (rv) + + case RVX_BACKGROUND: + # Set/Show the background parameter + call cmd_background (rv) + + case RVX_CCFTYPE: + # Set/Show the ccf output type + call cmd_out_type (rv) + + case RVX_COMMENT: + # Add a comment to the output logs + call cmd_add_comment (rv) + + case RVX_CONTINUUM: + # Set/Show the continuum flag + call cmd_continuum (rv) + + case RVX_CORRECTION: + # Convert a pixel shift to a velocity + call cmd_correction (rv) + + case RVX_DELTAV: + # Print the velocity dispersion + call cmd_deltav (rv) + + case RVX_DISP: + # Print the rebinned dispersion info. + call cmd_prtdisp (rv) + + case RVX_FILTER: + # Set/Show the filter flag + call cmd_filter (rv) + + case RVX_FUNCTION: + # Set/Show the fitting function + call cmd_fitfunc (rv) + + case RVX_HEIGHT: + # Set/Show the fit height + call cmd_height (rv) + + case RVX_IMUPDATE: + # Set/Show the image update flag + call cmd_imupdate (rv) + + case RVX_LINECOLOR: + # Set/Show the overlay vector line color + call cmd_linecolor (rv) + + case RVX_MINWIDTH: + # Set/Show the minwidth parameter + call cmd_minwidth (rv) + + case RVX_MAXWIDTH: + # Set/Show the maxwidth parameter + call cmd_maxwidth (rv) + + case RVX_NBANG: + # Move on to next spectrum in list ignoring the data write + written = true + if (cmd_next(rv,infile,rinfile,written,cmdstr) == ERR_READ) + goto error_ + + case RVX_NEXT: + # Move on to next spectrum in list + if (cmd_next(rv,infile,rinfile,written,cmdstr) == ERR_READ) + goto error_ + + case RVX_OBJECTS: + # Set/Show the object image list + if (cmd_objects(rv,infile,written) == ERR_READ) + goto error_ + + case RVX_OUTPUT: + # Set/Show the output root filename + call cmd_output (rv) + + case RVX_OSAMPLE: + # Set/Show the object sample region for correlation + if (cmd_regions(rv, RV_OSAMPLE(rv)) == ERR_CORREL) + goto error_ + + case RVX_PBANG: + # Move to previous image, ignoring the data write + written = true + if (cmd_previous(rv,infile,rinfile,written,cmdstr) == ERR_READ) + goto error_ + + case RVX_PEAK: + # Set/Show the peak parameter + call cmd_peak (rv) + + case RVX_PIXCORR: + # Set/Show the pixcorr parameter + call cmd_pixcorr (rv) + + case RVX_PREVIOUS: + # Move to previous image + if (cmd_previous(rv,infile,rinfile,written,cmdstr) == ERR_READ) + goto error_ + + case RVX_PRINTZ: + # Toggle output of Z valuesj + call cmd_printz (rv) + + case RVX_REBIN: + # Set/Show the rebin param + call cmd_rebin (rv) + + case RVX_RESULTS: + # Page a logfile of results + call cmd_result (rv) + + case RVX_RSAMPLE: + # Set/Show the template sample region for correlation + if (cmd_regions(rv, RV_RSAMPLE(rv)) == ERR_CORREL) + goto error_ + + case RVX_SHOW: + # List the current values of all parameters + call rv_show (rv, STDOUT) + + case RVX_TEMPLATES: + # Reset the template list pointer + if (cmd_refspec(rv, rinfile, written) == ERR_READ) + goto error_ + + case RVX_TEMPVEL: + # Set/Show the template velocity + call cmd_tempvel (rv, RV_TEMPNUM(rv)) + + case RVX_TEXTCOLOR: + # Set/Show the graphics text color. + call cmd_textcolor (rv) + + case RVX_TNUM: + # Move on to next spectrum in list + if (cmd_tnum(rv, rinfile, written, cmdstr) == ERR_READ) + goto error_ + + case RVX_UNLEARN: + # Unlearn the task parameters + call rv_unlearn (rv) + + case RVX_UPDATE: + # Update the task with current interactive parameters + call rv_update (rv) + + case RVX_VERBOSE: + # Set/Show the verbose flag + call cmd_verbose (rv) + + case RVX_VERSION: + # Show the task version (Hidden Command) + call cmd_version () + + case RVX_WCCF: + # Write the CCF as an image or text file + call write_ccf (rv) + + case RVX_WEIGHTS: + # Set/Show the weights flag + call cmd_weights (rv) + + case RVX_WIDTH: + # Set/Show the width parameter + call cmd_width (rv) + + case RVX_WINCENTER: + # Set/Show the window center + call cmd_wincenter (rv) + + case RVX_WINDOW: + # Set/Show the ccf window width + call cmd_window (rv) + + case RVX_YMIN: + # Set/Show the ccf window bottom + call cmd_ymin (rv) + + case RVX_YMAX: + # Set/Show the ccf window top + call cmd_ymax (rv) + + default: + # Default action + call rv_errmsg ("fxcor: Type '?' for a list of commands.") + } + + call sfree (sp) + return (OK) + +error_ call sfree (sp) + return (ERR_READ) +end diff --git a/noao/rv/rvcomdef.h b/noao/rv/rvcomdef.h new file mode 100644 index 00000000..06b64834 --- /dev/null +++ b/noao/rv/rvcomdef.h @@ -0,0 +1,140 @@ +# RVCOMDEF.H - Include file for colon command definitions for each task. + +# RVXCOR Colon Commands +define RVX_KEYWORDS "|apertures|apnum|apodize|autowrite|autodraw|background\ + |ccftype|comment|continuum|correction|deltav|disp\ + |filter|function|height|imupdate|line_color\ + |maxwidth|minwidth|n!|next!|objects|output|osample\ + |p!|peak|pixcorr|previous!|printz|rebin|results\ + |rsample|show|templates|tempvel|text_color|tnum\ + |unlearn|update|version|verbose|wccf|weights|width\ + |wincenter|window|ymin|ymax|" + +define RVX_APERTURES 1 # List of apertures to process +define RVX_APNUM 2 # Specific aperture to process +define RVX_APODIZE 3 # Fraction of endpoints to apodize +define RVX_AUTOWRITE 4 # Autowrite results? +define RVX_AUTODRAW 5 # Autodraw results? +define RVX_BACKGROUND 6 # Background fitting level +define RVX_CCFTYPE 7 # Type of CCF output +define RVX_COMMENT 8 # Add a comment to the output logs +define RVX_CONTINUUM 9 # Which spectra to normalize +define RVX_CORRECTION 10 # Convert a pixel shift to a velocity +define RVX_DELTAV 11 # Print out the velocity dispersion +define RVX_DISP 12 # Print rebinned dispersion info +define RVX_FILTER 13 # Which spectra to filter +define RVX_FUNCTION 14 # CCF peak fitting function +define RVX_HEIGHT 15 # CCF peak fit height +define RVX_IMUPDATE 16 # Update image with results? +define RVX_LINECOLOR 17 # Set/Show overlay vector color +define RVX_MAXWIDTH 18 # Min fitting width +define RVX_MINWIDTH 19 # Max fitting width +define RVX_NBANG 20 # Explicit next command +define RVX_NEXT 21 # Explicit next command +define RVX_OBJECTS 22 # Reset object list +define RVX_OUTPUT 23 # Rename output logfile +define RVX_OSAMPLE 24 # Regions to correlate +define RVX_PBANG 25 # Explicit previous command +define RVX_PEAK 26 # Peak height flag +define RVX_PIXCORR 27 # Pixel-correlation only flag +define RVX_PREVIOUS 28 # Explicit previous command +define RVX_PRINTZ 29 # Toggle output of Z values +define RVX_REBIN 30 # Set/Show rebin param +define RVX_RESULTS 31 # Page a logfile of results +define RVX_RSAMPLE 32 # Regions to correlate +define RVX_SHOW 33 # Show current parameter settings +define RVX_TEMPLATES 34 # Reset template list +define RVX_TEMPVEL 35 # Reset template list +define RVX_TEXTCOLOR 36 # Set/Show greaphics text color +define RVX_TNUM 37 # Skip to specifi template number +define RVX_UNLEARN 38 # Unlearn task parameters +define RVX_UPDATE 39 # Update task parameters +define RVX_VERSION 40 # Update task parameters +define RVX_VERBOSE 41 # Verbose output flag +define RVX_WCCF 42 # Write CCF to text|image +define RVX_WEIGHTS 43 # Fitting weights +define RVX_WIDTH 44 # Fitting width about peak +define RVX_WINCENTER 45 # Peak window center +define RVX_WINDOW 46 # Size of window +define RVX_YMIN 47 # Bottom of ccf plot +define RVX_YMAX 48 # Top of ccf plot + + +################################################################################ +## ## +## The following define statements are for common colon commands. The ## +## psets shall all be available from each task that uses them, thus ensuring ## +## that filter parameters, keyword translation, and continuum parameters ## +## can all be changed interactively if needed. ## +## ## +################################################################################ + +# Continuum Subtraction Parameter Commands +define CONT_KEYWORDS "|c_interactive|c_sample|naverage|c_function|cn_order\ + |replace|low_reject|high_reject|niterate|grow|" + +# Continuum normalization parameters +define CNT_INTERACTIVE 1 # Do it interactively? +define CNT_SAMPLE 2 # Sample string to use +define CNT_NAVERAGE 3 # Npts to average in sample +define CNT_FUNCTION 4 # Fitting function +define CNT_CN_ORDER 5 # Order of function +define CNT_REPLACE 6 # Replace spectrum with fit ? +define CNT_LOW_REJECT 7 # Low rejection in sigma of fit +define CNT_HIGH_REJECT 8 # High rejection in sigma of fit +define CNT_NITERATE 9 # Number of rejection iterations +define CNT_GROW 10 # Rejection growing radius + +# Keywords translation parameters +define KEY_KEYWORDS "|ra|dec|ut|utmiddle|exptime|epoch|date_obs\ + |hjd|mjd_obs|vobs|vrel|vhelio|vlsr|vsun|" + +define KEY_RA 1 # Right ascension keyword +define KEY_DEC 2 # Declination keyword +define KEY_UT 3 # Universal time of observation keyword +define KEY_UTMID 4 # Universal time of observation keyword +define KEY_EXPTIME 5 # Frame exposure time keyword +define KEY_EPOCH 6 # Epoch of observation keyword +define KEY_DATE_OBS 7 # Date of observation keyword +define KEY_HJD 8 # Heliocentric Julian Date Keyword +define KEY_MJD_OBS 9 # Modified Julian Data Keyword +define KEY_VOBS 10 # Observed RV keyword +define KEY_VREL 11 # Relative RV keyword +define KEY_VHELIO 12 # Heliocentric RV keyword +define KEY_VLSR 13 # LSR RV keyword +define KEY_VSUN 14 # Solar motion keyword + +# Filter parameters +define FILT_KEYWORDS "|f_type|cuton|cutoff|fullon|fulloff|" + +define FILT_FILT_TYPE 1 # Function type of filter +define FILT_CUTON 2 # Cuton frequency component +define FILT_CUTOFF 3 # Cutoff frequency component +define FILT_FULLON 4 # Fullon frequency component +define FILT_FULLOFF 5 # Fulloff frequency component + +# FFT Plotting Parameters +define PLOT_KEYWORDS "|filter|plot|overlay|split_plot|one_image|when\ + |wpc|log_scale|zoom|" + +define PLT_FILTER 1 # Set/Show the filter flag +define PLT_PLOT 2 # What type of plot to draw +define PLT_OVERLAY 3 # Overlay filter function? +define PLT_SPLIT_PLOT 4 # Make a split-plot? +define PLT_ONE_IMAGE 5 # What to put in single screen +define PLT_WHEN 6 # Plot before or after filtering? +define PLT_WPC 7 # Print rebinned WPC +define PLT_LOG_SCALE 8 # Plot on a Log scale? +define PLT_FFT_ZOOM 9 # FFT zoom parameter + +# Debugging commands +define DEBUG_KEYWORDS "|debug|d_on|d_off|dbg_file|dbg_level|dbg_quick\ + |dbg_other|" + +define DEBUG_DEBUG 1 # Debug toggle flag +define DEBUG_D_ON 2 # Debug toggle +define DEBUG_D_OFF 3 # Debug toggle +define DEBUG_FILE 4 # File name for output +define DEBUG_LEVEL 5 # Level of debugging information +define DEBUG_QUICK 6 # Quickdraw flag toggle +define DEBUG_OTHER 7 # Compare algorithms? diff --git a/noao/rv/rvcont.h b/noao/rv/rvcont.h new file mode 100644 index 00000000..ae50605b --- /dev/null +++ b/noao/rv/rvcont.h @@ -0,0 +1,27 @@ +# Include file for the CONTINPARS structure. A pointer is allocated in +# the main RV structure into this one. This sub-structure contains the +# parameters used for continuum removal. + +define SZ_CONT_STRUCT 16 + +define CON_INTERACTIVE Memi[RV_CONT($1)] # Process interactively? +define CON_CNFUNC Memi[RV_CONT($1)+1] # Interpolation func +define CON_ORDER Memi[RV_CONT($1)+2] # Order of func +define CON_LOWREJECT Memr[P2R(RV_CONT($1)+3)] # Low rejection +define CON_HIGHREJECT Memr[P2R(RV_CONT($1)+4)] # High rejection +define CON_REPLACE Memi[RV_CONT($1)+5] # Function type (ptr) +define CON_NITERATE Memi[RV_CONT($1)+6] # No. of iterations +define CON_GROW Memr[P2R(RV_CONT($1)+7)] # Growth radius +define CON_SAMPLE Memi[RV_CONT($1)+8] # Sample string (ptr) +define CON_NAVERAGE Memi[RV_CONT($1)+9] # Npts to average +define CON_FUNC Memi[RV_CONT($1)+10] # Function type (ptr) +define CON_MARKREJ Memi[RV_CONT($1)+11] # Mark rejected points + +###################### END OF STRUCTURE DEFINITIONS ###################### + +# Continuum fitting functions +define CN_INTERP_MODE "|spline3|legendre|chebyshev|spline1|" +define CN_SPLINE3 1 +define CN_LEGENDRE 2 +define CN_CHEBYSHEV 3 +define CN_SPLINE1 4 diff --git a/noao/rv/rvcorrect.com b/noao/rv/rvcorrect.com new file mode 100644 index 00000000..4ab7873e --- /dev/null +++ b/noao/rv/rvcorrect.com @@ -0,0 +1,5 @@ +double latitude, longitude, altitude # Location of observation +double vs # Solar velocity +double ras, decs, eps # Coordinate of solar velocity + +common /rvc_com/ latitude, longitude, altitude, vs, ras, decs, eps diff --git a/noao/rv/rvcorrel.x b/noao/rv/rvcorrel.x new file mode 100644 index 00000000..5ec38df2 --- /dev/null +++ b/noao/rv/rvcorrel.x @@ -0,0 +1,156 @@ +include <math.h> +include "rvpackage.h" +include "rvflags.h" +include "rvfilter.h" + +# RV_CORREL - Computes the correlation of two real data sets DATA1 and DATA2, +# each of length N including any user supplied zero padding. N must be an +# integer power of two. The answer is returned as the first N points in ANS +# stored in wraparound order, i.e. correlations at increasingly negative lags +# are in ANS(N) down to ANS(N/2+1), while correlations at increasingly pos- +# itive lags are in ANS(1) (zero lag) on up to ANS(N/2). Note that ANS must +# be supplied in the calling program with length at least 2*N since it is also +# used as a working space. Sign convention of this routine, if DATA1 lags +# DATA2, i.e. is shifted to the right of it, then ANS will show a peak at +# positive lags. +# Referece: Numerical Recipes in C, ch 12, Press, et al. + +procedure rv_correl (rv, data1, data2, npts, ans) + +pointer rv #I RV struct pointer +real data1[ARB] #I Object intensity array +real data2[ARB] #I Template intensity array +int npts #I Size of the array +real ans[ARB] #O Output correlation array + +pointer sp, fft +real dum +int i, no2 + +begin + call smark (sp) + call salloc (fft, 2*npts, TY_REAL) + + # Transform both data vectors at once + call twofft (data1, data2, Memr[fft], ans, npts) + + # Filter the data if asked for + if (RV_FILTER(rv) == OBJ_ONLY || RV_FILTER(rv) == BOTH) + call rv_filter (rv, Memr[fft], npts/2) # Object + if (RV_FILTER(rv) == TEMP_ONLY || RV_FILTER(rv) == BOTH) + call rv_filter (rv, ans, npts/2) # Template + + no2 = npts / 2 + for(i=2; i<=npts+2; i = i + 2) { + dum = ans[i-1] # Multiply to find FFT of correlation + ans[i-1] = (Memr[fft+i-2] * dum + Memr[fft+i-1] * ans[i]) / no2 + ans[i] = (Memr[fft+i-1] * dum - Memr[fft+i-2] * ans[i]) / no2 + } + + ans[2] = ans[npts+1] # Pack first/last into one element + + call realft (ans, no2, -1) # Inverse transform gives corr. + + # Normalize by the number of points + call adivkr (ans, real(npts), ans, npts) + + call sfree (sp) +end + + +# RV_ANTISYM -- Compute antisymmetric part of correlation function. + +procedure rv_antisym (rv, x, h, width, cor, cnpts, anti, sigmaa, err, r) + +pointer rv #I RV struct pointer +real x #I Peak position +real h #I Peak height +real width #I Peak width +real cor[cnpts] #I Correlation function +int cnpts #I Number of correlation points +real anti[cnpts] #O Array of antisymmetric function +real sigmaa #O Sigma of antisymmetric function +double err #O Velocity error estimate +real r #O Tonry&Davis R value + +int i, j, ix +real eps +real sqrt(), assqr() + +begin + if (DBG_OTHER(rv) == 0) { + ix = x + (cnpts/2. + 1) + 0.5 + do i = 1, cnpts { + j = 1 + mod ((2*(cnpts+ix)-i-1), cnpts) + if (j <= cnpts && j >= 1) + anti[i] = cor[i] - cor[j] + else + anti[i] = 0.0 + } + + # This is the sigma(a) in the Tonry&Davis paper (Eqn. 20) + sigmaa = sqrt (assqr(anti,cnpts) / (2*cnpts)) + + } else if (DBG_OTHER(rv) > 0) { + ix = x + 0.5 + do i = 1, cnpts { + j = 1 + mod ((2*(cnpts+ix)-i-1), cnpts) + if (j <= cnpts && j >= 1) + anti[i] = (cor[i] - cor[j]) + else + anti[i] = 0.0 + } + + # This is the sigma(a) in the Tonry&Davis paper (Eqn. 20) + sigmaa = sqrt (assqr(anti,cnpts) / (2*cnpts)) + + } else if (DBG_OTHER(rv) == -1) { + ix = x + 0.5 + do i = 1, cnpts { + j = 1 + mod ((2*(cnpts+ix)-i), cnpts) + if (j <= cnpts && j >= 1) + anti[i] = (cor[i] - cor[j]) + else + anti[i] = 0.0 + } + + # This is the sigma(a) in the Tonry&Davis paper (Eqn. 20) + sigmaa = sqrt (assqr(anti,cnpts) / (2*cnpts)) + + } + + # This is the ratio of true peak height to height of average peak in CCF + r = h / (SQRTOF2 * sigmaa) # Eqn. 23 + + eps = (TWOPI * width) / 8.0 / (1. + r) # Eqn. 24 + if (RV_DCFLAG(rv) != -1) + err = eps * RV_DELTAV(rv) # Error est. + else + err = eps + + if (DBG_DEBUG(rv) == YES) { + call d_printf (DBG_FD(rv), "rv_antisym:\n\t") + call d_printf (DBG_FD(rv), + "ix=%d x=%g sig=%g w=%g h=%g R=%g eps=%g => %g k/s\n") + call pargi (ix) ; call pargr(x) ; call pargr(sigmaa) + call pargr(width) ; call pargr(h) ; call pargr(r) + call pargr(eps) ; call pargr(RV_DELTAV(rv)) + } +end + + +# RV_NORMALIZE -- Normalize data for correlation by dividing by the rms +# of the data. + +procedure rv_normalize (data, npts) + +real data[ARB] #U Data +int npts #I Number of points + +real rms, assqr() + +begin + rms = sqrt (assqr(data, npts) / real(npts) ) + if (rms != 0.0) + call adivkr (data, rms, data, npts) +end diff --git a/noao/rv/rvcursor.x b/noao/rv/rvcursor.x new file mode 100644 index 00000000..844c72e1 --- /dev/null +++ b/noao/rv/rvcursor.x @@ -0,0 +1,620 @@ +include <gset.h> +include <pkg/gtools.h> +include <fset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" +include "rvplots.h" +include "rvfilter.h" + +# RV_CURSOR - Get the next command from the user in the input cursor loop +# and perform the requested function. + +procedure rv_cursor (rv, infile, rinfile) + +pointer rv #I RV struct pointer +pointer infile #I Object input list pointer +pointer rinfile #I Template input list pointer + +pointer sp, cmd, buf, fname +pointer gp, gt +int wcs, key, nans, i +int stat, npts, tmp_int +real x, y, x1, x2, dx, max +char ans[2*SZ_LINE,4] + +pointer open(), gopen() +int rv_colon(), rv_data_check(), scan() +int clgcur(), fstati(), fft_cursor(), spc_cursor() +int next_spec(), next_temp(), next_ap() +int prev_spec(), prev_temp(), prev_ap() +real rv_maxpix() +bool written, streq() +errchk open, gt_init + +define LOG_PROMPT "Log of Current Results: " +define exit_ 99 +define unknown_ 98 +define redo_xcor_ 97 +define replot_ 96 +define refit_ 95 + +begin + call smark (sp) # Allocate some space + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Nab some pointers + gp = RV_GP(rv) + gt = RV_GT(rv) + + call op_debug (rv) # Open debugger + if (DBG_KEYSTROKE(rv) != 'x') + key = DBG_KEYSTROKE(rv) + else + key = 'x' + RV_NEWGRAPH(rv) = NO + written = false + RV_NEWXCOR(rv) = YES + + repeat { + + RV_CMD(rv) = key + switch (key) { # Switch on the keystroke + case '?': + # List options + call gpagefile (gp, XC_HELP, "FXCOR Task Options: ") + + case ':': + # Colon command + if (rv_colon(rv,Memc[cmd],written,infile,rinfile,NULL) == QUIT) + break + if (RV_NEWXCOR(rv) == YES) + goto redo_xcor_ + if (RV_NEWGRAPH(rv) == YES) + goto replot_ + if (RV_FITDONE(rv) == NO) { + RV_ERRCODE(rv) = OK + call rv_batch_xcor (rv, RV_TEMPNUM(rv), RV_APNUM(rv), NO, + NO, YES) + } + + case '.': + # Accelerator for doing continuum normalizations. + call cmd_cont (rv) + if (RV_NEWXCOR(rv) == YES) { + key = 'x' + goto redo_xcor_ + } else + goto replot_ + + case '-': + # Subtract a blend from the CCF. + if (RV_FITDONE(rv) == YES) { + x1 = WRKPIXX(rv,1) + x2 = WRKPIXX(rv,RV_CCFNPTS(rv)) + dx = 1. + call gctran (gp, x, y, x, y, wcs, 2) + call subblend (rv, gp, WRKPIXY(rv,1), x1, x2, dx, x, y) + goto replot_ + } else { + call rv_errmsg ( + "No deblended fit done yet. Use 'd' to fit.") + } + + case '+': + # Toggle status line output for ccf mode. + RV_STATLINE(rv) = RV_STATLINE(rv) + 1 + call rv_writeln (rv, STDOUT) + + case ',': + # Generic Test Command (hidden from users). + + case 'a': + # Do a summary plot of the antisymmetric noise of the CCF. + if (IS_DBLSTAR(rv) == YES) { + call rv_errmsg ( + "Antisymmetric plot invalid for a deblended fit.") + } else if (RV_FITFUNC(rv) == CENTER1D) { + call rv_errmsg ( + "Antisymmetric plot unavailable for center1d fit.") + } else if (RV_FITFUNC(rv) == SINC && + IS_INDEF(RV_BACKGROUND(rv))) { + call rv_errmsg ( + "Must set background for sinc fit antisym. computation.") + } else { + call rv_anplot (rv, RV_GP(rv)) + call rv_pause ("Hit any key to return to the correlation.") + goto replot_ + } + + case 'b': + # Set "background" for FWHM calculation. + i = RV_WINCENTER(rv) - RV_WINDOW(rv) + max = rv_maxpix (WRKPIXY(rv,i), 2*RV_WINDOW(rv)) + call gctran (gp, x, y, x, y, wcs, 2) + if (y >= max) { + call rv_errmsg ("Cannot set background above CCF peak.") + } else { + if (RV_FITFUNC(rv) == GAUSSIAN || + RV_FITFUNC(rv) == LORENTZIAN || + RV_FITFUNC(rv) == SINC) { + call reset_errcom (rv) + call rv_erase_fit (rv, false) + RV_BACKGROUND(rv) = y + RV_ERRCODE(rv) = OK + IS_DBLSTAR(rv) = NO + call rv_batch_xcor (rv, RV_TEMPNUM(rv), + RV_APNUM(rv), NO, NO, NO) + #RV_APNUM(rv), NO, NO, YES) + } else { + call rv_errmsg ("Cannot set background for a %s fit.") + if (IS_DBLSTAR(rv) == YES) + call pargstr ("deblended") + else if (RV_FITFUNC(rv) == PARABOLA) + call pargstr ("parabolic") + else + call pargstr ("center1d") + } + } + + case 'c': + # Read cursor poistion + call rv_rdcursor (rv, gp, x, y, wcs) + + case 'd': + # Fit the peak with up to four Gaussians. + call reset_errcom (rv) + x1 = WRKPIXX(rv,1) + x2 = WRKPIXX(rv,RV_CCFNPTS(rv)) + dx = 1. + call gctran (gp, x, y, x, y, wcs, 2) + call deblend (rv, gp, x1, x2, dx, x, y, WRKPIXY(rv,1), ans, + nans) + + case 'e': + # Show the summary plot after the fit. + call rv_eplot (rv, gp) + call rv_pause ("Hit any key to return to the correlation.") + goto replot_ + + case 'f': + # Enter the Fourier Mode command stream. + stat = fft_cursor(rv) + if (RV_NEWXCOR(rv) == YES) { + key = 'x' + goto redo_xcor_ + } else + goto replot_ + + case 'g': + # Fit the correlation plot based on the X cursor values + call reset_errcom (rv) + call gctran (gp, x, y, x, y, wcs, 2) + call rv_xfit (rv, x, YES) + + case 'I': + # Fatal interrupt. + call fatal (0, "Interrupt") + + case 'j': + # Residual plot of fit. + call rv_plot (rv, RESIDUAL_PLOT) + + case 'l': + # Page the logfile. Pointer is closed to be VMS compatable. + if (RV_TXFD(rv) != NULL) { + if (fstati(RV_TXFD(rv),F_FILESIZE) == 0) + call rv_errmsg ("Nothing yet written to logfile.") + else { + call sprintf (Memc[buf], SZ_FNAME, "%s.txt") + call pargstr (SPOOL(rv)) + call flush (RV_TXFD(rv)) + call close (RV_TXFD(rv)) + call gpagefile (gp, Memc[buf], LOG_PROMPT) + RV_TXFD(rv) = open (Memc[buf], APPEND, TEXT_FILE) + } + } else + call rv_errmsg ("No output file specified.") + + case 'm': + # Plot polymarkers of the actual CCF points. + call gseti (gp, G_WCS, 2) + i = RV_WINCENTER(rv) - RV_WINDOW(rv) + npts = 2 * RV_WINDOW(rv) + call gpmark (gp,WRKPIXX(rv,i), WRKPIXY(rv,i), npts, 4, 2.0, 2.0) + call gflush (gp) + + case 'n': + # Go to the next (template --> aperture --> object) after + # saving results. + if (RV_TEMPNUM(rv) < RV_NTEMPS(rv) || + CURAPNUM(rv) < NUMAPS(rv) || + RV_IMNUM(rv) < RV_NOBJS(rv)) + call rv_do_save (rv, written) + + # Now do the "next" operation as specified. The logic sequence + # is complicated but handles all cases. + if (RV_TEMPNUM(rv) < RV_NTEMPS(rv)) { + if (next_temp(rv, rinfile, written) == ERR_READ) + call rv_errmsg ("Error reading next template.") + else + goto redo_xcor_ + } else { + # Get the next aperture + if (CURAPNUM(rv) < NUMAPS(rv)) { + if (RV_NTEMPS(rv) > 1) { # Reset templates + RV_TEMPNUM(rv) = 0 + if (next_temp(rv, rinfile, written) == ERR_READ) + call rv_errmsg ("Error reading next template.") + } + if (next_ap(rv, written) == ERR_READ) + call rv_errmsg ("Errror reading next aperture.") + else + goto redo_xcor_ + } else { + # get the next object + if (RV_IMNUM(rv) < RV_NOBJS(rv)) { + if (NUMAPS(rv) > 1) { + CURAPNUM(rv) = 0 # Reset apertures + if (next_ap(rv, written) == ERR_READ) { + call rv_errmsg ( + "Errror reading next aperture.") + } + } + if (RV_NTEMPS(rv) > 1) { + RV_TEMPNUM(rv) = 0 # Reset templates + if (next_temp(rv, rinfile, written) ==ERR_READ){ + call rv_errmsg ( + "Error reading next template.") + } + } + if (next_spec(rv, infile, written) == ERR_READ) + call rv_errmsg ("Error reading next object.") + else + goto redo_xcor_ + } else { + call rv_errmsg ("No more spectra to process.") + } + } + } + + case 'o': + # Fit or refit the object spectrum continuum for subtraction. + tmp_int = CON_INTERACTIVE(rv) + CON_INTERACTIVE(rv) = YES + call do_continuum (rv, OBJECT_SPECTRUM) + CON_INTERACTIVE(rv) = tmp_int + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + goto redo_xcor_ + + case 'p': + # Go to the previous (template --> aperture --> object) after + # saving results. + if (RV_TEMPNUM(rv) > 1 || CURAPNUM(rv) > 1 || RV_IMNUM(rv) > 1) + call rv_do_save (rv, written) + + # Now do the "previous" operation as specified. The logic + # sequence is complicated but handles all cases. + if (RV_TEMPNUM(rv) > 1 && RV_NTEMPS(rv) > 1) { + if (prev_temp(rv, rinfile, written) == ERR_READ) + call rv_errmsg ("Error reading previous template.") + else + goto redo_xcor_ + } else { + # Do previous aperture + if (CURAPNUM(rv) > 1 && NUMAPS(rv) > 1) { + if (RV_NTEMPS(rv) > 1 && RV_TEMPNUM(rv) > 1) { + RV_TEMPNUM(rv) = RV_NTEMPS(rv) + 1 # Reset templates + if (prev_temp(rv, rinfile, written) == ERR_READ) { + call rv_errmsg ( + "Error reading previous template.") + } + } + if (prev_ap(rv, written) == ERR_READ) + call rv_errmsg ("Errror reading previous aperture.") + else + goto redo_xcor_ + } else { + # Do previous object image + if (RV_NOBJS(rv) > 1 && RV_IMNUM(rv) > 1) { + if (NUMAPS(rv) > 1) { + CURAPNUM(rv) = NUMAPS(rv) + 1 + if (prev_ap(rv, written) == ERR_READ) { + call rv_errmsg ( + "Errror reading previous aperture.") + } + } + if (RV_NTEMPS(rv) > 1) { + RV_TEMPNUM(rv) = RV_NTEMPS(rv) + 1 + if (prev_temp(rv, rinfile, written) ==ERR_READ){ + call rv_errmsg ( + "Error reading previous template.") + } + } + if (prev_spec(rv, infile, written) == ERR_READ) + call rv_errmsg("Error reading previous object.") + else + goto redo_xcor_ + } else { + call rv_errmsg ("At the start of the input list.") + } + } + } + + case 'q': + # Quit, possibly saving results before hand. + if (!written || RV_UPDATE(rv) == YES) { + if (RV_AUTOWRITE(rv) == YES && !streq(SPOOL(rv),"")) + call cmd_write (rv, written) + else + call rv_query_save (rv, written, QUIT) + } + break + + case 'r': + # Replot the data. +replot_ call rv_plot (rv, CORRELATION_PLOT) + if (IS_DBLSTAR(rv) == NO) + call rv_writeln (rv, STDOUT) + + case 's': + # Examine object and template spectra. + stat = spc_cursor (rv) + if (RV_NEWXCOR(rv) == YES) { + key = 'x' + goto redo_xcor_ + } else + goto replot_ + + case 't': + # Fit or refit the template spectrum continuum for subtraction. + tmp_int = CON_INTERACTIVE(rv) + CON_INTERACTIVE(rv) = YES + call do_continuum (rv, REFER_SPECTRUM) + CON_INTERACTIVE(rv) = tmp_int + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + goto redo_xcor_ + + case 'v': + # Suspend graphics and show verbose fit/xcor output. + call rv_verbose_fit (rv, STDOUT) + + case 'w': + # Write current correlation results to log file. + if (!written || RV_UPDATE(rv) == YES) { + if (RV_TXFD(rv) == NULL) { + call strcpy ("\0", Memc[fname], SZ_FNAME) + while (Memc[fname] == '\0') { + call printf ("Root output filename: ") + call flush (STDOUT) + stat = scan() + call gargstr (Memc[fname], SZ_FNAME) + } + call init_files (rv, DEVICE(rv), Memc[fname], true) + RV_MGP(rv) = gopen ("stdvdm", APPEND, RV_GRFD(rv)) + written = false + } + call cmd_write (rv, written) + written = true + } else + call rv_query_save (rv, written, NULL) + + case 'x': + # Re-do the correlation and check params. + RV_NEWXCOR(rv) = YES +redo_xcor_ RV_ERRCODE(rv) = OK + if (rv_data_check(rv) == OK && RV_NEWXCOR(rv) == YES) { + call rv_batch_xcor (rv, RV_TEMPNUM(rv), RV_APNUM(rv), YES, + YES, YES) + } else + goto replot_ + + case 'y': + # Same as 'g' but get endpoints from Y value. + i = RV_WINCENTER(rv) - RV_WINDOW(rv) + max = rv_maxpix (WRKPIXY(rv,i), 2*RV_WINDOW(rv)) + call gctran (gp, x, y, x, y, wcs, 2) + if (y >= max) { + call rv_errmsg ("Cannot set cursor above CCF peak.") + } else { + call reset_errcom (rv) + RV_FITHGHT(rv) = y + call rv_yfit (rv, y, YES) + } + + case 'z': + # Zoom in on a new peak in the entire CCF. + RV_ERRCODE(rv) = OK + call rv_zplot (rv, gp, x, y, wcs) + + case '\n', '\r', ' ': + # No-op. + + default: + # Unknown command +unknown_ call rv_errmsg ("Type '?' for a list of commands.") + } + + RV_NEWXCOR(rv) = NO + RV_NEWGRAPH(rv) = NO + + } until (clgcur("cursor",x,y,wcs,key,Memc[cmd],SZ_LINE) == EOF) + +exit_ call sfree (sp) +end + + +# RV_DO_SAVE - Check that a write is called for, and prompt for a filename +# if necessary. + +procedure rv_do_save (rv, written) + +pointer rv #I RV struct pointer +bool written #U Data write flag + +begin + if (RV_AUTOWRITE(rv) == YES && (!written || RV_UPDATE(rv) == YES)) + call cmd_write (rv, written) + else if (!written || RV_UPDATE(rv) == YES) + call rv_query_save (rv, written, MOVE) +end + + +# RV_MODE_PROMPT - For a given sub-mode, prompt the user appropriately, giving +# also the parent mode. + +procedure rv_mode_prompt (rv) + +pointer rv #I RV struct pointer + +begin + # Switch on the legal modes (i.e. make it simple) + switch (RV_MODES(rv)) { + case 1: + # No-op + case 12: + call printf ("ccf.fft mode: ") # CCF -> FFT + case 13: + call printf ("ccf.spec mode: ") # CCF -> SPEC + case 123: + call printf ("ccf.fft.spec mode: ") # CCF -> FFT -> SPEC + case 132: + call printf ("ccf.spec.fft mode: ") # CCF -> SPEC -> FFT + default: + } + call flush (STDOUT) +end + + +# RV_PARENT - Utility to return the parent mode of the current mode. + +int procedure rv_parent (rv) + +pointer rv #I RV struct pointer + +begin + # Switch on the legal modes (i.e. make it simple) + switch (RV_MODES(rv)) { + case 123: + return (FFT_MODE) + case 132: + return (SPEC_MODE) + default: + return (INDEFI) + } +end + + +# RV_QUERY_SAVE - Query the user to save the results, and possibly a file +# name. + +procedure rv_query_save (rv, written, type) + +pointer rv #I RV struct pointer +bool written #I Results written flag +int type #I Type of prompt + +pointer sp, resp, gopen() +int stat, scan() +bool answer, streq() + +data answer /true/ + +begin + call smark (sp) + call salloc (resp, SZ_LINE, TY_CHAR) + + # Prompt the user. + if (type == QUIT) { + call printf ("Save results before quitting? (%b) ") + call pargb (answer) + } else if (type == MOVE) { + call printf ("Save results before moving? (%b) ") + call pargb (answer) + } else { + call printf ("Results already written. Write again? (%b) ") + call pargb (answer) + } + call flush (STDOUT) + + stat = scan() + call gargstr (Memc[resp], SZ_FNAME) + if (Memc[resp] == 'n' || Memc[resp] == 'N') + answer = false + else if (Memc[resp] == 'y' || Memc[resp] == 'Y') + answer = true + + if (answer) { + if (RV_TXFD(rv) == NULL) { + call strcpy ("\0", Memc[resp], SZ_FNAME) + while (Memc[resp] == '\0' && !streq(Memc[resp],"\"\"")) { + call printf ("Root output filename: ") + call flush (STDOUT) + stat = scan() + call gargstr (Memc[resp], SZ_FNAME) + } + if (!streq(Memc[resp],"\"\"")) { + call init_files (rv, DEVICE(rv), Memc[resp], true) + RV_MGP(rv) = gopen ("stdvdm", APPEND, RV_GRFD(rv)) + } + } + if (!streq(Memc[resp],"\"\"")) { + written = false + call cmd_write (rv, written) + answer = true + } else { + call printf ("Results not saved.\n") + call sfree (sp) + return + } + + } else { + answer = false + call sfree (sp) + return + } + + call sfree (sp) +end + + +# RV_RDCURSOR - Read and print out the current cursor position. This routine +# figures out where the user is pointing and print out in the correct WCS. + +procedure rv_rdcursor (rv, gp, x, y, wcs) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +real x #I X cursor position +real y #I Y cursor position +int wcs #I WCS of cursor position + +real x1, y1, vel +double rv_shift2vel() + +begin + # Check for boundary coordinates + call gctran (gp, x, y, x1, y1, wcs, 0) + if (y1 < 0.725) # in bottom ccf plot + call gctran (gp, x, y, x1, y1, wcs, 2) + else + call gctran (gp, x, y, x1, y1, wcs, 3) + + if (RV_DCFLAG(rv) == -1) { + call printf ("Cursor: lag = %.3f y = %.3f\n") + call pargr (x1) + call pargr (y1) + } else { + vel = real (rv_shift2vel(rv,x1)) + call printf ("Cursor: lag = %.3f velocity = %.3f y = %.3f\n") + call pargr (x1) + call pargr (vel) + call pargr (y1) + } +end diff --git a/noao/rv/rvdatacheck.x b/noao/rv/rvdatacheck.x new file mode 100644 index 00000000..e0c0d444 --- /dev/null +++ b/noao/rv/rvdatacheck.x @@ -0,0 +1,127 @@ +include "rvpackage.h" +include "rvflags.h" +include "rvsample.h" + +# RV_DATA_CHECK - Examine the data quickly to make sure that a proper +# correlation can be done. + +int procedure rv_data_check (rv) + +pointer rv # RV struct pointer + +real w1, w2 +int srange, erange +double dex() +int rv_chk_filter(), force_rebin() + +begin + # Check that both spectra have dispersion info + if ((RV_OW0(rv) == 1. && RV_OWPC(rv) == 1.) && RV_DCFLAG(rv) != -1) { + RV_DCFLAG(rv) = -1 + RV_RW0(rv) = 1. + RV_RWPC(rv) = 1. + } + if ((RV_RW0(rv) == 1. && RV_RWPC(rv) == 1.) && RV_DCFLAG(rv) != -1) { + RV_DCFLAG(rv) = -1 + RV_OW0(rv) = 1. + RV_OWPC(rv) = 1. + } + + # Check/reset dispersion info. + if (force_rebin (rv) != OK) { + if (RV_INTERACTIVE(rv) == YES) { + call rv_errmsg ( + "Data cannot be put on same WPC dispersion.") + } + call rv_err_comment (rv, + "Data cannot be put on same WPC dispersion.", "") + return (ERR_CORREL) + } + + # Check the filter specifications + switch (RV_FILTER(rv)) { + case BOTH: + if (rv_chk_filter(rv,OBJECT_SPECTRUM) != OK || + rv_chk_filter(rv,REFER_SPECTRUM) != OK) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Invalid or ambiguous filter specified.") + return (ERR_CORREL) + } + case OBJ_ONLY: + if (rv_chk_filter(rv,OBJECT_SPECTRUM) != OK) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Invalid or ambiguous filter specified.") + return (ERR_CORREL) + } + case TEMP_ONLY: + if (rv_chk_filter(rv,REFER_SPECTRUM) != OK) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Invalid or ambiguous filter specified.") + return (ERR_CORREL) + } + } + + # Re-calculate the velocity dispersion and sundry + if (RV_DCFLAG(rv) != -1) + RV_DELTAV(rv) = RV_OWPC(rv) * CLN10 + RV_GLOB_W1(rv) = min (RV_OW0(rv), RV_RW0(rv)) + RV_GLOB_W2(rv) = max (RV_OW2(rv), RV_RW2(rv)) + + # Check that ranges are in bounds, fix them if not + if (ORCOUNT(rv) != ALL_SPECTRUM) { + if (ORUNITS(rv) == PIXELS || RV_DCFLAG(rv) == -1) { + srange = int (OSRANGE(rv,1)) + erange = int (OERANGE(rv,ORCOUNT(rv))) + OSRANGE(rv,1) = max (srange, 1) + OSRANGE(rv,1) = min (srange, RV_NPTS(rv)) + OERANGE(rv,ORCOUNT(rv)) = min (erange, RV_NPTS(rv)) + OERANGE(rv,ORCOUNT(rv)) = max (erange, 1) + } else { + w1 = real (dex (RV_GLOB_W1(rv))) + w2 = real (dex (RV_GLOB_W2(rv))) + OSRANGE(rv,1) = max (OSRANGE(rv,1), w1) + OSRANGE(rv,1) = min (OSRANGE(rv,1), w2) + OERANGE(rv,ORCOUNT(rv)) = min (OERANGE(rv,ORCOUNT(rv)), w2) + OERANGE(rv,ORCOUNT(rv)) = max (OERANGE(rv,ORCOUNT(rv)), w1) + } + if (OSRANGE(rv,1) == OERANGE(rv,ORCOUNT(rv))) { + if (RV_INTERACTIVE(rv) == YES) { + call rv_errmsg ( + "Object sample range is out of bounds, using entire spectrum.") + } + call rv_err_comment (rv, + "Object `sample' range is out of bounds, using entire spectrum.", + "") + ORCOUNT(rv) = ALL_SPECTRUM + } + } + + if (RRCOUNT(rv) != ALL_SPECTRUM) { + if (RRUNITS(rv) == PIXELS || RV_DCFLAG(rv) == -1) { + srange = int (RSRANGE(rv,1)) + erange = int (RERANGE(rv,RRCOUNT(rv))) + RSRANGE(rv,1) = max (srange, 1) + RSRANGE(rv,1) = min (srange, RV_NPTS(rv)) + RERANGE(rv,RRCOUNT(rv)) = min (erange, RV_NPTS(rv)) + RERANGE(rv,RRCOUNT(rv)) = max (erange, 1) + } else { + w1 = real (dex (RV_GLOB_W1(rv))) + w2 = real (dex (RV_GLOB_W2(rv))) + RSRANGE(rv,1) = max (RSRANGE(rv,1), w1) + RSRANGE(rv,1) = min (RSRANGE(rv,1), w2) + RERANGE(rv,RRCOUNT(rv)) = min (RERANGE(rv,RRCOUNT(rv)), w2) + RERANGE(rv,RRCOUNT(rv)) = max (RERANGE(rv,RRCOUNT(rv)), w1) + } + if (RSRANGE(rv,1) == RERANGE(rv,RRCOUNT(rv))) { + if (RV_INTERACTIVE(rv) == YES) { + call rv_errmsg ( + "Temp sample range is out of bounds, using entire spectrum.") + } + call rv_err_comment (rv, + "Temp `sample' range is out of bounds, using entire spectrum.", + "") + RRCOUNT(rv) = ALL_SPECTRUM + } + } + return (OK) +end diff --git a/noao/rv/rvdebug.par b/noao/rv/rvdebug.par new file mode 100644 index 00000000..e6fe0df1 --- /dev/null +++ b/noao/rv/rvdebug.par @@ -0,0 +1,9 @@ +# RV_DEBUG - Hidden task to control debugging information + +debug,b,h,no,,,"Enable debugging information" +file,s,h,"",,,"Filename of debugging info" +level,i,h,4,,,"Level of debugging information" +other,i,h,0,,,"Compare algorithms?" +keystroke,s,h,'x',,,"Intial keystroke?" +quickdraw,b,h,no,,,"Supress some graphics for speed?" +mode,s,h,"ql" diff --git a/noao/rv/rvdrawfit.x b/noao/rv/rvdrawfit.x new file mode 100644 index 00000000..cd1dcbba --- /dev/null +++ b/noao/rv/rvdrawfit.x @@ -0,0 +1,358 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" + +# RV_DRAW_FIT - Draw the fitted function to the screen. Called in +# rv_erase_fit() to erase old fit, and from the fitting rouines and +# plot rouines so they all draw the same function. + +procedure rv_draw_fit (rv, gp, is_velocity) + +pointer rv #I RV struct pointer +pointer gp #I Graphics descriptor +int is_velocity #I Plot function on velocity scale? + +extern cgauss1d, lorentz +pointer sp, pltx, plty +real step, xl +int i, pltnpts, nfitpts, nvars, gstati() +double rv_shift2vel() + +include "rvsinc.com" + +begin + # Check for exit conditions + #if (RV_INTERACTIVE(rv) == NO || gp == NULL) + if (gp == NULL || RV_FITDONE(rv) == NO || RV_ERRCODE(rv) == ERR_FIT) + return + + nfitpts = RV_IEND(rv) - RV_ISTART(rv) + 1 + if (RV_FITFUNC(rv) == SINC) + pltnpts = (snfit-1) * 10 + else + pltnpts = 10 * nfitpts + nvars = 1 + + # Plot the deblended fit if that is what was done + if (IS_DBLSTAR(rv) == YES) { + call rv_plt_deblend (rv, gp, is_velocity) + return + } + + call smark (sp) # Allocate space for the plt + call salloc (pltx, pltnpts, TY_REAL) + call salloc (plty, pltnpts, TY_REAL) + + # Draw the computed CCF + call gseti (gp, G_WCS, 2) + if (RV_FITFUNC(rv) == CENTER1D) { + if (is_velocity == YES && RV_DCFLAG(rv) != -1) { + call gline (gp, RV_VREL(rv), WRKPIXY(rv,RV_ISHIFT(rv)), + RV_VREL(rv), WRKPIXY(rv,RV_ISHIFT(rv))+0.1) + } else { + call gline (gp, RV_SHIFT(rv), WRKPIXY(rv,RV_ISHIFT(rv)), + RV_SHIFT(rv), WRKPIXY(rv,RV_ISHIFT(rv))+0.1) + } + call gflush (gp) + call sfree (sp) + return + + } else if (RV_FITFUNC(rv) == SINC) { + if (is_velocity == YES && RV_DCFLAG(rv) != -1) { + do i = 1, pltnpts + Memr[pltx+i-1] = real(rv_shift2vel(rv, Memr[splx+i-1])) + } else + call amovr (Memr[splx], Memr[pltx], pltnpts) + call amovr (Memr[sply], Memr[plty], pltnpts) + } else { + call rv_gpltsteps (rv, pltnpts, xl, step) + + do i = 1, pltnpts { + Memr[pltx+i-1] = xl + (i-1) * step + switch (RV_FITFUNC(rv)) { + case GAUSSIAN: + call cgauss1d (Memr[pltx+i-1], nvars, COEFF(rv,1), 4, + Memr[plty+i-1]) + case LORENTZIAN: + call lorentz (Memr[pltx+i-1], nvars, COEFF(rv,1), 4, + Memr[plty+i-1]) + case PARABOLA: + call polyfit (Memr[pltx+i-1], nvars, COEFF(rv,1), 3, + Memr[plty+i-1]) + } + } + if (is_velocity == YES && RV_DCFLAG(rv) != -1) { + do i = 1, pltnpts + Memr[pltx+i-1] = real(rv_shift2vel(rv, Memr[pltx+i-1])) + } + } + + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_DASHED) + call gseti (gp, G_PLCOLOR, RV_LINECOLOR(rv)) + } + call gpline (gp, Memr[pltx], Memr[plty], pltnpts) + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } + + call gflush (gp) + call sfree (sp) +end + + +# RV_DRAW_BACKGROUND - Draw the background marker with the correct line type +# and at the same level. + +procedure rv_draw_background (rv, gp) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer + +real left, right +int gstati() + +begin + # Check error conditions. + if (gp == NULL || RV_FITFUNC(rv) == PARABOLA) + return + if (RV_FITFUNC(rv) == CENTER1D || IS_DBLSTAR(rv) == YES) + return + if (IS_INDEF(RV_BACKGROUND(rv)) && RV_FITFUNC(rv) == SINC) + return + + # Get the background window sizes. + if (RV_DTYPE(rv) == SUMMARY_PLOT) { + if (RV_DCFLAG(rv) != -1) { + left = (RV_WINL(rv) - RV_WINDOW(rv)) * RV_DELTAV(rv) + right = (RV_WINR(rv) + RV_WINDOW(rv)) * RV_DELTAV(rv) + } else { + left = RV_WINL(rv) - RV_WINDOW(rv) + right = RV_WINR(rv) + RV_WINDOW(rv) + } + } else { + left = real (RV_WINL(rv)) + right = real (RV_WINR(rv)) + } + + # Draw the background. + if (RV_FITDONE(rv) == YES) { + # Mark the background level + if (IS_INDEF(RV_BACKGROUND(rv))) { + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_DASHED) + call gseti (gp, G_PLCOLOR, C_GREEN) + } + call gline (gp, left, COEFF(rv,4), right, COEFF(rv,4)) + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } + } else { + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_DASHED) + call gseti (gp, G_PLCOLOR, C_GREEN) + } + call gline (gp, left, RV_BACKGROUND(rv), right, + RV_BACKGROUND(rv)) + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } + } + + } else if (!IS_INDEF(RV_BACKGROUND(rv))) { + #call gseti (gp, G_PLCOLOR, C_GREEN) + call gline (gp, left, RV_BACKGROUND(rv), left, RV_BACKGROUND(rv)) + #call gseti (gp, G_PLCOLOR, C_FOREGROUND) + + } else { + #call gseti (gp, G_PLCOLOR, C_GREEN) + call gline (gp, left, 0.0, right, 0.0) + #call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } +end + + +# RV_ERASE_FIT - Erase the previous fit prior to computing new one. Points, +# function, FWHM line and background level are erased, and the underlying +# ccf in the region redrawn, + +procedure rv_erase_fit (rv, redraw) + +pointer rv #I RV struct pointer +bool redraw #I Redraw background? + +pointer gp +real statr, rv_width() +int ledge, redge, npts + +begin + # Check for exit conditions + if (RV_INTERACTIVE(rv) == NO || RV_GP(rv) == NULL) + return + if (RV_FITDONE(rv) == NO || RV_AUTODRAW(rv) == NO) + return + + gp = RV_GP(rv) + redge = RV_IEND(rv) # initializations + ledge = RV_ISTART(rv) + npts = redge - ledge + 1 + + # First set the line and polymarker types to be black. + call gseti (gp, G_WCS, 2) + call gseti (gp, G_PLCOLOR, C_BACKGROUND) + call gseti (gp, G_PLTYPE, GL_CLEAR) + call gseti (gp, G_PMLTYPE, GL_CLEAR) + + # Erase the computed CCF. + call rv_draw_fit (rv, gp, NO) + + # Erase the points being used in the fit. + call gpmark (gp, WRKPIXX(rv,ledge), WRKPIXY(rv,ledge), npts, 4, 2., 2.) + call gflush (gp) + + # Erase the background level. + if ((RV_FITFUNC(rv) == GAUSSIAN || RV_FITFUNC(rv) == LORENTZIAN) && + IS_DBLSTAR(rv) == NO) { + call rv_draw_background (rv, gp) + call gflush (gp) + } + + # Erase the FWHM level. + if (!IS_INDEF(RV_FWHM_Y(rv)) && IS_DBLSTAR(rv) == NO) { + statr = rv_width (rv) + call gflush (gp) + } + + # Erase the computed CCF. + #call rv_draw_fit (rv, gp, NO) + + # Just in case, let's also erase the residuals. + if (RV_RESDONE(rv) == YES) { + call rv_resid_plot (rv) + RV_RESDONE(rv) = NO + } + + # Now redraw the ccf, with a little on each end to cover up the slop. + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gpline (gp, WRKPIXX(rv,max(1,ledge-4)), WRKPIXY(rv,max(1,ledge-4)), + min(npts+8,RV_CCFNPTS(rv))) + call gflush (gp) + + # Redraw the background level. + if (redraw && IS_DBLSTAR(rv) == NO) + call rv_draw_background (rv, gp) + call gflush (gp) +end + + +# RV_GPLTSTEPS - Get the function starting and increment parameters + +procedure rv_gpltsteps (rv, npts, xl, step) + +pointer rv #I RV struct pointer +int npts #I Npts being plotted +real xl #O Start position +real step #O Plot increment + +real dv, c2, c3, istart, iend + +begin + dv = RV_DELTAV(rv) # Initialize + c2 = COEFF(rv,2) + c3 = COEFF(rv,3) + istart = WRKPIXX(rv,RV_ISTART(rv)) + iend = WRKPIXX(rv,RV_IEND(rv)) + + switch (RV_FITFUNC(rv)) { + case PARABOLA: + xl = istart + step = abs (iend - istart) / real (npts-1) + case GAUSSIAN: + xl = c2 - (3. * sqrt(c3)) + step = (c2 + (3. * sqrt(c3)) - xl) / real (npts-1) + case LORENTZIAN: + xl = c2 - (2. * c3) + step = ((c2 + (2. * c3)) - xl) / real(npts-1) + } +end + + +# RV_PLT_DEBLEND -- Plot the fitted model function. + +procedure rv_plt_deblend (rv, gp, is_velocity) + +pointer rv #I RV struct pointer +pointer gp #I Graphics descriptor +int is_velocity #I Plot on velocity axis? + +real w, xval, yval +real x1, x2, y1, y2 +int i, j, npts, pnpts +int i1, nsub, offset + +double rv_shift2vel() +real model() +int gstati() + +begin + if (gp == NULL) + return + + nsub = 10 + pnpts = nsub * (npts-1) + + # Compute model spectrum with continuum and plot. + i1 = DBL_I1(rv) + x1 = WRKPIXX(rv,1) + npts = DBL_NFITP(rv) + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_DASHED) + call gseti (gp, G_PLCOLOR, RV_LINECOLOR(rv)) + } + do i = 1, npts-1 { + do j = 1, nsub { + offset = ((i-1)*nsub+j)-1 + w = x1 + (i1+i-2) + (j-1) * 0.1 + if (is_velocity == YES && RV_DCFLAG(rv) != -1) + #xval = w * RV_DELTAV(rv) + xval = real (rv_shift2vel(rv,w)) + else + xval = w + yval = model (w, DBL_COEFFS(rv,1), 3*DBL_NSHIFTS(rv)+2) + yval = DBL_SCALE(rv) * yval + + (DBL_Y1(rv)+DBL_SLOPE(rv)*(w-DBL_X1(rv))) + + if (i == 1 && j == 1) + call gamove (gp, xval, yval) + else + call gadraw (gp, xval, yval) + } + call gflush (gp) + } + if (gstati(gp, G_PLTYPE) != GL_CLEAR) + call gseti (gp, G_PLTYPE, GL_SOLID) + + # Draw the background to the screen. + y1 = DBL_Y1(rv) + y2 = DBL_Y2(rv) + if (is_velocity == YES && RV_DCFLAG(rv) != -1) { + #x1 = DBL_X1(rv) * RV_DELTAV(rv) + #x2 = DBL_X2(rv) * RV_DELTAV(rv) + x1 = real (rv_shift2vel(rv,DBL_X1(rv))) + x2 = real (rv_shift2vel(rv,DBL_X2(rv))) + } else { + x1 = DBL_X1(rv) + x2 = DBL_X2(rv) + } + call gline (gp, x1, y1, x2, y2) + if (gstati(gp, G_PLTYPE) != GL_CLEAR) { + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } + call gflush (gp) +end diff --git a/noao/rv/rverrmsg.x b/noao/rv/rverrmsg.x new file mode 100644 index 00000000..69cbbc73 --- /dev/null +++ b/noao/rv/rverrmsg.x @@ -0,0 +1,105 @@ +include "rvpackage.h" +include "rvflags.h" + +# RV_ERRMSG - Print an error message to STDERR and flush the buffer + +procedure rv_errmsg (errstr) + +char errstr[SZ_LINE] #I Error message to be printed + +int ip, stridxs() + +begin + if (stridxs("%", errstr) > 0) { + # The errstr contains a format specifier and an argument is + # expected in a 'parg' call following return. The caller will + # handle the stream flush. + call eprintf (errstr) + + } else { + # At this point the error message is simply a text string we want + # to output. No format has been detected and no arguments are + # expected. + + ip = stridxs("\n", errstr) # replace any misc. newlines + if (ip > 0) + errstr[ip] = EOS + + call eprintf ("%s\n") + call pargstr (errstr) + call flush (STDERR) + call tsleep (1) # delay so it can be read + } +end + + +# RV_ERR_COMMENT - Record a message for the comment section of the logs + +procedure rv_err_comment (rv, errstr, arg) + +pointer rv #I RV struct pointer +char errstr[SZ_LINE] #I Error message to be printed +char arg[SZ_LINE] #I Error argument to be printed + +pointer sp, tmp +int ip, newlen +int stridxs(), strlen() +errchk realloc + +define MAX_ERRBUF 4192 + +begin + if (RV_VERBOSE(rv) == OF_SHORT || RV_VERBOSE(rv) == OF_NOLOG || + RV_VERBOSE(rv) == OF_TXTONLY || RV_VERBOSE(rv) == OF_STXTONLY) + return + + call smark (sp) + call salloc (tmp, SZ_LINE, TY_CHAR) + + # Re-allocate the error string. + if (RV_ERRCOMMENTS(rv) == NULL) { + newlen = strlen (errstr) + 6 + SZ_FNAME + call realloc (RV_ERRCOMMENTS(rv), newlen, TY_CHAR) + call strcpy ("\t\0", ERRCOMMENTS(rv), 4) + } else { + newlen = strlen (ERRCOMMENTS(rv)) + strlen (errstr) + 6 + SZ_FNAME + call realloc (RV_ERRCOMMENTS(rv), newlen, TY_CHAR) + } + + if (stridxs("%", errstr) > 0) { + # The errstr contains a format specifier and an argument is + # expected in a 'parg' call. + + call sprintf (Memc[tmp], SZ_LINE, errstr) + call pargstr (arg) + call strcat (Memc[tmp], ERRCOMMENTS(rv), MAX_ERRBUF) + call strcat ("\n\t", ERRCOMMENTS(rv), MAX_ERRBUF) + + } else { + # At this point the error message is simply a text string we want + # to output. No format has been detected and no arguments are + # expected. + + ip = stridxs("\n", errstr) # replace any misc. newlines + if (ip > 0) + errstr[ip] = EOS + + call sprintf (Memc[tmp], SZ_LINE, "%s\n\t") + call pargstr (errstr) + call strcat (Memc[tmp], ERRCOMMENTS(rv), MAX_ERRBUF) + } + + call sfree (sp) +end + + +# RESET_ERRCOM -- Clear the error comments structure. + +procedure reset_errcom (rv) + +pointer rv #I RV struct pointer + +begin + call mfree (RV_ERRCOMMENTS(rv), TY_CHAR) + RV_ERRCOMMENTS(rv) = NULL +end diff --git a/noao/rv/rvfftcorr.x b/noao/rv/rvfftcorr.x new file mode 100644 index 00000000..a53a737d --- /dev/null +++ b/noao/rv/rvfftcorr.x @@ -0,0 +1,120 @@ +include <math.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" + +# RV_FFTCORR - Parent routine for the FFT correlation. This procedure prepares +# the data and processes the FFT. + +procedure rv_fftcorr (rv, plot_only) + +pointer rv #I RV struct pointer +int plot_only #I Plot prepared spectra only? + +pointer sp +pointer otempy, rtempy +pointer wkobj, wkref, ans +int npts, fnpts +int i, ishift +int fft_pow2() +errchk realloc + +begin + RV_UPDATE(rv) = YES # set the update flag + + npts = int ((RV_GLOB_W2(rv) - RV_GLOB_W1(rv)) / RV_OWPC(rv) + 1) + npts = max (npts, max (RV_NPTS(rv),RV_RNPTS(rv))) + fnpts = fft_pow2 (npts) + RV_CCFNPTS(rv) = fnpts + RV_FFTNPTS(rv) = fnpts + + # (Re)allocate the answer vectors. + call realloc (RV_WKPIXX(rv), 2*fnpts, TY_REAL) + call realloc (RV_WKPIXY(rv), 2*fnpts, TY_REAL) + + call smark (sp) # allocate some pointers + call salloc (wkobj, 2*fnpts, TY_REAL) + call salloc (wkref, 2*fnpts, TY_REAL) + call salloc (otempy, 2*fnpts, TY_REAL) + call salloc (rtempy, 2*fnpts, TY_REAL) + call salloc (ans, 2*fnpts, TY_REAL) + + # Clear the work arrays. + call aclrr (Memr[wkobj], 2*fnpts) + call aclrr (Memr[wkref], 2*fnpts) + call aclrr (Memr[otempy], 2*fnpts) + call aclrr (Memr[rtempy], 2*fnpts) + + # Prepare the data in the temp arrays before processing. First we'll + # do the object spectrum + if (OBJCONT(rv) == NO) + call amovr (OBJPIXY(rv,1), Memr[otempy], RV_NPTS(rv)) + else + call amovr (OCONT_DATA(rv,1), Memr[otempy], RV_NPTS(rv)) + + if (RV_OW0(rv) == RV_GLOB_W1(rv) || RV_DCFLAG(rv) == -1) + ishift = 0 + else + ishift = nint ((RV_OW0(rv) - RV_GLOB_W1(rv)) / RV_OWPC(rv)) + + call prep_spec (rv, RV_OSAMPLE(rv), npts, fnpts, RV_NPTS(rv), + otempy, wkobj, ishift, YES) + + + # Now do the template spectrum. + if (REFCONT(rv) == NO) + call amovr (REFPIXY(rv,1), Memr[rtempy], RV_RNPTS(rv)) + else + call amovr (RCONT_DATA(rv,1), Memr[rtempy], RV_RNPTS(rv)) + + if (RV_RW0(rv) == RV_GLOB_W1(rv) || RV_DCFLAG(rv) == -1) + ishift = 0 + else + ishift = nint ((RV_RW0(rv) - RV_GLOB_W1(rv)) / RV_RWPC(rv)) + + call prep_spec (rv, RV_RSAMPLE(rv), npts, fnpts, RV_RNPTS(rv), + rtempy, wkref, ishift, YES) + + + # Normalize the correlation. + call rv_normalize (Memr[wkobj], fnpts) + call rv_normalize (Memr[wkref], fnpts) + + # Now do a plot of the prepared spectra if that what's requested. + if (plot_only == YES) { + call gclear (RV_GP(rv)) # clear the screen + + if (RV_FILTER(rv) == OBJ_ONLY || RV_FILTER(rv) == BOTH) { + call realft (Memr[wkobj], fnpts, 1) # forward FFT + call rv_filter (rv, Memr[wkobj], fnpts) # Object + call realft (Memr[wkobj], fnpts, -1) # inverse FFT + } + if (RV_FILTER(rv) == TEMP_ONLY || RV_FILTER(rv) == BOTH) { + call realft (Memr[wkref], fnpts, 1) # forward FFT + call rv_filter (rv, Memr[wkref], fnpts) # Template + call realft (Memr[wkref], fnpts, -1) # inverse FFT + } + + call split_plot (rv, RV_GP(rv), TOP, Memr[wkobj], fnpts, + OBJ_ONLY, PREPARED_PLOT) + call split_plot (rv, RV_GP(rv), BOTTOM, Memr[wkref], fnpts, + TEMP_ONLY, PREPARED_PLOT) + + call sfree (sp) + return + } + + # Call correlation routine to get answer vector. + call rv_correl (rv, Memr[wkobj], Memr[wkref], fnpts, Memr[ans]) + + # Load work arrays and fix wrap-around ordering of ans vector. + do i = 1, fnpts { + WRKPIXY(rv,i) = Memr[ans+i-1] + WRKPIXX(rv,i) = real ((i-fnpts/2-1)) + } + call fft_fixwrap (WRKPIXY(rv,1), fnpts) + + RV_Y1(rv) = INDEF # Reset some plot flags + RV_Y2(rv) = INDEF + call sfree (sp) +end diff --git a/noao/rv/rvfgauss.x b/noao/rv/rvfgauss.x new file mode 100644 index 00000000..f4d3852c --- /dev/null +++ b/noao/rv/rvfgauss.x @@ -0,0 +1,411 @@ +include <math.h> +include <gset.h> +include <math/nlfit.h> +include "rvpackage.h" +include "rvflags.h" + +define USE_DOUBLE TRUE + + +# RV_FGAUSS - Fit a Gaussian to the specified function. Compute and return +# an array of the fitted gaussian at the specified resolution in ccf[]. +# 'c' contains the coefficients of the fit. 'ishift' is used as an initial +# guess at the center parameter, c[2]. + +procedure rv_fgauss (rv, xcf, ycf, ledge, redge, npts, ishift, c, sigma) + +pointer rv #I RV struct pointer +real xcf[ARB], ycf[ARB] #I CCF array +int ledge, redge #I Index of left edge +int npts #I Number of points +int ishift #I Initial shift guess +real c[ARB] #O Array of coefficients +real sigma #O Error of center position + +pointer sp, gp, nl, w, list, fit +real distance, width, sigmac[NPARS], oldc2, diff +int ft_func, ft_dfunc +int i, j, stat, npar, nvars +long lseed +bool reset_c1 + +double cd[NPARS], sigmacd[NPARS] # Variable for double-precision fit +double dtol, ccfvard, chisqrd, oldc2d +pointer wd, xcfd, ycfd, fitd +int ft_funcd, ft_dfuncd +extern d_cgauss1d(), d_cdgauss1d() + + +extern cgauss1d(), cdgauss1d() +extern lorentz(), dlorentz() +real fit_weight(), rv_maxpix() +int locpr(), rv_check_converge(), rv_fitconv() + +include "fitcom.com" +define NPARS 4 + +begin + call smark (sp) + call salloc (w, npts, TY_REAL) + call salloc (fit, npts, TY_REAL) + call salloc (list, NPARS, TY_INT) + call aclrr(Memr[w], npts) + call aclrr(Memr[fit], npts) + call aclri(Memi[list], NPARS) + call aclrr(sigmac, NPARS) + call aclrr(c, NPARS) + + call salloc (wd, npts, TY_DOUBLE) ; call aclrd(Memd[wd], npts) + call salloc (xcfd, npts, TY_DOUBLE) ; call aclrd(Memd[xcfd], npts) + call salloc (ycfd, npts, TY_DOUBLE) ; call aclrd(Memd[ycfd], npts) + call salloc (fitd, npts, TY_DOUBLE) ; call aclrd(Memd[fitd], npts) + + + # Mark the points being used in the fit. + gp = RV_GP(rv) + if (gp != NULL && RV_INTERACTIVE(rv) == YES) { + call gseti (gp, G_WCS, 2) + call gpmark (gp, xcf[ledge], ycf[ledge], npts, 4, 2., 2.) + call gflush (gp) + } + + # Initialize the parameters. + if (DBG_DEBUG(rv) == YES) { + call d_printf (DBG_FD(rv), "rv_fgauss:\tFunction = %d\n") + call pargi(RV_FITFUNC(rv)) + } + call init_gcoeffs (rv, xcf, ycf, ledge, redge, npts, ishift, c) + + # Set up some of the NLFIT stuff. + width = npts + Memi[list] = 1 # amplitude + Memi[list+1] = 2 # center + Memi[list+2] = 3 # sigma/fwhm + if (IS_INDEF(RV_BACKGROUND(rv))) { + Memi[list+3] = 4 # background + nfitpars = NPARS + } else + nfitpars = NPARS - 1 + + # Get the function addresses. + if (RV_FITFUNC(rv) == GAUSSIAN) { + if (USE_DOUBLE) { + ft_funcd = locpr (d_cgauss1d) + ft_dfuncd = locpr (d_cdgauss1d) + } else { + ft_func = locpr (cgauss1d) + ft_dfunc = locpr (cdgauss1d) + } + } else if (RV_FITFUNC(rv) == LORENTZIAN) { + ft_func = locpr (lorentz) + ft_dfunc = locpr (dlorentz) + } + + # Now iterate the fit. + j = 1 + oldc2 = c[2] + nvars = 1 + lseed = 1 + ccfvar = 0.0 + chisqr = 0.0 + + oldc2d = c[2] + ccfvard = 0.0d0 + chisqrd = 0.0d0 + dtol = double (RV_TOLERANCE(rv)) + + while (j < RV_MAXITERS(rv)) { + + if (j > 1) { + # Move data window if necessary; only one pixel per iteration. + diff = oldc2 - c[2] + reset_c1 = false + if (diff > 1 && ledge > 1) { + ledge = ledge - 1 + reset_c1 = true + } else if (diff < -1 && (ledge+npts) < RV_CCFNPTS(rv)) { + ledge = ledge + 1 + reset_c1 = true + } + if (reset_c1) { + if (!IS_INDEF(RV_BACKGROUND(rv))) + c[1] = rv_maxpix (ycf[ledge], npts) - RV_BACKGROUND(rv) + else + c[1] = rv_maxpix (ycf[ledge], npts) + } + + # Now check to see if we're converging sensibly, and recover + # by rejecting points or adjusting parameters. + stat = rv_check_converge (rv, xcf, ycf, ledge, redge, width, + npts, ishift, oldc2, lseed, c) + } + + # Compute the point weighting. + do i = 1, npts { + distance = abs (c[2] - xcf[ledge+i-1]) + Memr[w+i-1] = fit_weight (distance, width, RV_WEIGHTS(rv)) + } + + + if (USE_DOUBLE) { + # Convert the types for the double calculation. + call achtrd (c, cd, NPARS) + call achtrd (sigmac, sigmacd, NPARS) + call achtrd (Memr[w], Memd[wd], npts) + call achtrd (xcf[ledge], Memd[xcfd], npts) + call achtrd (ycf[ledge], Memd[ycfd], npts) + + + # Initialize the NLFIT routines and do the fitting. + call nlinitd (nl, ft_funcd, ft_dfuncd, cd, sigmacd, NPARS, + Memi[list], nfitpars, d_tol, RV_MAXITERS(rv)) + call nlfitd (nl, Memd[xcfd], Memd[ycfd], Memd[wd], npts, nvars, + WTS_USER, stat) + call nlvectord (nl, Memd[xcfd], Memd[fitd], npts, 1) + call nlpgetd (nl, cd, npar) + call nlerrorsd (nl, Memd[ycfd], Memd[fitd], Memd[wd], npts, + ccfvard, chisqrd, sigmacd) + call nlfreed (nl) + + + # Move the results back. + do i = 1, NPARS { + c[i] = cd[i] + sigmac[i] = sigmacd[i] + } + ccfvar = ccfvard + chisqr = chisqrd + + } else { + # Initialize the NLFIT routines and do the fitting. + call nlinitr (nl, ft_func, ft_dfunc, c, sigmac, NPARS, + Memi[list], nfitpars, RV_TOLERANCE(rv), RV_MAXITERS(rv)) + call nlfitr (nl, xcf[ledge], ycf[ledge], Memr[w], npts, nvars, + WTS_USER, stat) + call nlvectorr (nl, xcf[ledge], Memr[fit], npts, 1) + call nlpgetr (nl, c, npar) + call nlerrorsr (nl, ycf[ledge], Memr[fit], Memr[w], npts, + ccfvar, chisqr, sigmac) + call nlfreer (nl) + } + + if (DBG_DEBUG(rv) == YES && DBG_FD(rv) != NULL) { + call d_printf (DBG_FD(rv), + "\titer %d = %.6g %.6g %.6g %.6g chi2=%g o2=%g\n") + call pargi (j); call pargr (c[1]) ; call pargr (c[2]) + call pargr (c[3]) ; call pargr (c[4]); call pargr (chisqr) + call pargr (oldc2) + call flush (DBG_FD(rv)) + } + + # Now check for convergence. + if (USE_DOUBLE) { + if (j == 1) # initialize + oldc2d = cd[2] + else if (abs(cd[2] - oldc2d) < 0.0001) # converged + break + else + oldc2d = cd[2] + + } else { + if (j == 1) # initialize + oldc2 = c[2] + else if (abs(c[2] - oldc2) < 0.0001) # converged + break + else + oldc2 = c[2] + } + + j = j + 1 # next iteration + } + + # See if we couldn't converge + if (rv_fitconv (rv, j, c) == ERR_FIT) { + RV_ERRCODE(rv) = ERR_FIT + call aclrr (c, NPARS) + call aclrr (sigmac, NPARS) + call sfree (sp) + return + } + niter = j + nfit = width + sigma = abs (sigmac[2]) + call amovr (sigmac, ECOEFF(rv,1), nfitpars) + if (!IS_INDEF(RV_BACKGROUND(rv))) + ECOEFF(rv,4) = 0.0 + + # Debug output. + if (DBG_DEBUG(rv) == YES && DBG_LEVEL(rv) >= 2 && DBG_FD(rv) != NULL) { + call d_printf(DBG_FD(rv),"\tfitted c[1-4] = %.6g %.6g %.6g %.6g\n") + call pargr (c[1]) ; call pargr (c[2]) + call pargr (c[3]) ; call pargr (c[4]) + call flush (DBG_FD(rv)) + } + + if (nl != NULL) + call nlfreer (nl) + call sfree (sp) +end + + +# FIT_WEIGHT - Compute the point weighting, with error checking to avoid +# problems with exponentiation of negative numbers and weights. + +real procedure fit_weight (dist, width, wt_exp) + +real dist #I Distance from center +real width #I Width of data window +real wt_exp #I Weighting exponent + +real base, weight + +begin + if (wt_exp == 0.0) + return (1.0) + + base = max (0.0, (1. - (dist / (width / 2.)))) + if (base > 0.0) + weight = base ** wt_exp + else + weight = 0.0 + + return (weight) +end + + +# INIT_GCOEFFS - Initialize the Gaussian/Lorentzian coefficients based on +# the data. + +procedure init_gcoeffs (rv, xcf, ycf, ledge, redge, npts, ishift, c) + +pointer rv #I RV struct pointer +real xcf[ARB], ycf[ARB] #I CCF array +int ledge, redge #I Index of left edge +int npts #I Number of points +int ishift #I Initial shift guess +real c[4] #O Array of initial coefficients + +real y +int left, right +real rv_maxpix(), rv_minpix() + +begin + # Initialize the parameters. + if (!IS_INDEF(RV_BACKGROUND(rv))) { + c[1] = rv_maxpix (ycf[ledge], npts) #- RV_BACKGROUND(rv) + c[4] = RV_BACKGROUND(rv) # background + } else { + c[1] = rv_maxpix (ycf[ledge], npts) + c[4] = rv_minpix (ycf[ledge], npts) + } + y = (c[1] - c[4]) / 2. + c[4] + c[2] = xcf[ishift] - 0.1 # center + left = ledge + right = redge + while (ycf[left+1] < y && left < ishift) + left = left + 1 + while (ycf[right-1] < y && right > ishift) + right = right - 1 + if (RV_FITFUNC(rv) == LORENTZIAN) { + # Lorentz FWHM + #c[3] = max (2.,(xcf[right] - xcf[left] + 1)) + c[3] = min (-2.,-(xcf[right] - xcf[left] + 1)/2.0) + c[3] = max (2.,(xcf[right] - xcf[left] + 1)/2.0) + } else { + # Sigma ** 2 + #c[3] = sqrt (xcf[right] - xcf[left] + 1) / 2.35482 + c[3] = max (2.,(((xcf[right]-xcf[left]+1) / 2.35482) ** 2.)) + } + + if (DBG_DEBUG(rv) == YES) { + call d_printf (DBG_FD(rv), "\tinit c[1-4] = %.6g %.6g %.6g %.6g\n") + call pargr (c[1]) ; call pargr (c[2]) + call pargr (c[3]) ; call pargr (c[4]) + call d_printf (DBG_FD(rv), "\tr/l=%d/%d xr/l=%f/%f y=%f\n") + call pargi(right) ; call pargi(left) ; call pargr(xcf[right]) + call pargr(xcf[left]) ; call pargr(y) + call flush (DBG_FD(rv)) + } +end + + +# CHECK_CONVERGENCE - Check to see if we're converging correctly, otherwise +# reject points. + +int procedure rv_check_converge (rv, xcf, ycf, ledge, redge, width, npts, + ishift, oldc, lseed, c) + +pointer rv #I RV struct pointer +real xcf[ARB], ycf[ARB] #I CCF array +int ledge, redge #I Index of left edge +real width #I Width of fit region +int npts #I Number of points +int ishift #I Initial shift guess +real oldc #I Old center +long lseed #I Seed +real c[ARB] #O Array of coefficients + +int i +real urand(), frac + +begin + # Generate a random percentage to nudge the params in case they + # get lost in parameter space. + frac = urand (lseed) / 10.0 + + # Check for negative sigma ** 2 + if (c[3] <= 0.0 && RV_FITFUNC(rv) == GAUSSIAN) { + if (!IS_INDEF(RV_BACKGROUND(rv))) { + #if (RV_INTERACTIVE(rv) == YES) { + # call rv_errmsg ( + # "Fit not converging: rejecting points below background\n") + #} + while (ycf[ledge+1] < RV_BACKGROUND(rv) && ledge < ishift) + ledge = ledge + 1 + while (ycf[redge-1] < RV_BACKGROUND(rv) && redge > ishift) + redge = redge - 1 + npts = redge - ledge + 1 + if (npts < RV_MINWIDTH(rv)) + return (ERR_FIT) + width = real (npts) + } + call init_gcoeffs (rv, xcf, ycf, ledge, redge, npts, ishift, c) + do i = 2, 3 + c[i] = c[i] - (c[i] * frac) # add some scatter + } + + # Now check for a negative amplitude or unusual shift and reset. + if (abs(c[2]-oldc) >= 5 || c[1] <= 0.0) { + call init_gcoeffs (rv, xcf, ycf, ledge, redge, npts, ishift, c) + do i = 2, 3 + c[i] = c[i] + (c[i] * frac) # add some scatter + } + + if (DBG_DEBUG(rv) == YES) { + call d_printf (DBG_FD(rv), "\tchk = %.6g %.6g %.6g %.6g\n") + call pargr (c[1]) ; call pargr (c[2]) + call pargr (c[3]) ; call pargr (c[4]) + call flush (DBG_FD(rv)) + } + return (OK) +end + + +# RV_FITCONV - Check to see if the fit converged. + +int procedure rv_fitconv (rv, niter, coeff) + +pointer rv #I RV struct pointer +int niter #I Number of iterations +real coeff[4] #I Coefficient array + +begin + if (niter >= RV_MAXITERS(rv)) + return (ERR_FIT) + if (coeff[1] < 0.0) + return (ERR_FIT) + if ((coeff[3] < 0.0 || coeff[3] > 1.0e4) && RV_FITFUNC(rv) == GAUSSIAN) + return (ERR_FIT) + + return (OK) +end diff --git a/noao/rv/rvfilter.h b/noao/rv/rvfilter.h new file mode 100644 index 00000000..126974b8 --- /dev/null +++ b/noao/rv/rvfilter.h @@ -0,0 +1,23 @@ +# Include file for the Filter structure. A pointer is allocated in +# the main RV structure into this one. This sub-structure contains the +# parameters used for data filter while in Fourier space as well as +# the option flags for filter function types + +define SZ_FILTSTRUCT 10 + +define RVF_FILTTYPE Memi[RV_FILTP($1)] # Filter type code +define RVF_CUTOFF Memi[RV_FILTP($1)+1] # Cuton wavenumber +define RVF_CUTON Memi[RV_FILTP($1)+2] # Cuton wavenumber +define RVF_FULLOFF Memi[RV_FILTP($1)+3] # Fulloff wavenumber +define RVF_FULLON Memi[RV_FILTP($1)+4] # Fullon wavenumber + +define RVF_LASTKEY Memi[RV_FILTP($1)+5] # Last fftmode comm. + +###################### END OF STRUCTURE DEFINITIONS ###################### + +# Filter function flags +define RV_FTYPES "|square|ramp|welch|hanning|" +define SQUARE 1 # Step function +define RAMP 2 # Ramp function +define WELCH 3 # Welch function +define HANNING 4 # Hanning function diff --git a/noao/rv/rvfilter.x b/noao/rv/rvfilter.x new file mode 100644 index 00000000..d462546f --- /dev/null +++ b/noao/rv/rvfilter.x @@ -0,0 +1,221 @@ +include <math.h> +include "rvpackage.h" +include "rvflags.h" +include "rvfilter.h" + +# RV_FILTER - Filter the FFT data before doing cross correlation. +# the value of N represents the number of complex fourier components +# so we must filter 2*N points for the real and complex elements of +# each component. + +procedure rv_filter (rv, fft, N) + +pointer rv #I RV struct pointer +real fft[ARB] #U FFT data array +int N #I no. elements in fft[] + +int i, j, npts +int cuton, cutoff, fullon, fulloff +real fraction, rv_hanning(), rv_welch() + +begin + cuton = RVF_CUTON(rv) + cutoff = RVF_CUTOFF(rv) + fullon = RVF_FULLON(rv) + fulloff = RVF_FULLOFF(rv) + + switch (RVF_FILTTYPE(rv)) { + case SQUARE: # Step function + j = 1 + do i = 1, cuton { + fft[j] = 0.0 # real + fft[j+1] = 0.0 # complex + j = j + 2 + } + j = cutoff * 2 + 1 + do i = cutoff, N { + fft[j] = 0.0 # real + fft[j+1] = 0.0 # complex + j = j + 2 + } + + case RAMP: # Ramp filter + j = 1 + do i = 1, N { + if (i < cuton || i > fulloff) { + fft[j] = 0.0 # real + fft[j+1] = 0.0 # complex + } + if (i >= cuton && i <= fullon) { + fraction = real(i-cuton) /real(fullon-cuton) + fft[j] = fft[j] * fraction + fft[j+1] = fft[j+1] * fraction + } + if (i >= cutoff && i <= fulloff) { + fraction = 1.0 - real(i-cutoff)/real(fulloff-cutoff) + fft[j] = fft[j] * fraction + fft[j+1] = fft[j+1] * fraction + } + j = j + 2 + } + + case WELCH: + npts = cutoff - cuton + 1 + j = 1 + do i = 1, N { + if (i < cuton || i > cutoff) { + fft[j] = 0.0 + fft[j+1] = 0.0 + } else { + #fraction = rv_welch (i-cuton+1, npts) + fraction = rv_welch (i-cuton, npts) + fft[j] = fft[j] * fraction + fft[j+1] = fft[j+1] * fraction + } + j = j + 2 + } + + case HANNING: + npts = cutoff - cuton + 1 + j = 1 + do i = 1, N { + if (i < cuton || i > cutoff) { + fft[j] = 0.0 + fft[j+1] = 0.0 + } else { + #fraction = rv_hanning (i-cuton+1, npts) + fraction = rv_hanning (i-cuton, npts) + fft[j] = fft[j] * fraction + fft[j+1] = fft[j+1] * fraction + } + j = j + 2 + } + } # End switch +end + + +# RV_CHK_FILTER - Check the filter specification for a sensible filter + +int procedure rv_chk_filter (rv, which) + +pointer rv #I RV struct pointer +int which #I Which spectrum to filter + +int con, coff, fon, foff + +begin + con = RVF_CUTON(rv) + coff = RVF_CUTOFF(rv) + fon = RVF_FULLON(rv) + foff = RVF_FULLOFF(rv) + + # Here we get the filter checks. + if (RV_FILTER(rv) == BOTH || + (which == OBJECT_SPECTRUM && RV_FILTER(rv) == OBJ_ONLY) || + (which == REFER_SPECTRUM && RV_FILTER(rv) == TEMP_ONLY)) { + + # Check for defaults. + if (con == 0 && coff == 0 && fon == 0 && foff == 0) + return (ERR) + + # Check for backward filters. + if (RVF_FILTTYPE(rv) == RAMP) { + if (coff < con || fon < con || foff < coff || foff < fon || + con > coff || fon > coff || coff > foff || fon > foff) + return (ERR) + } else { + if (coff < con) + return (ERR) + } + } else + return (ERR) + + return (OK) +end + + +# RV_DO_FILTER - Given an arbitrary input spectrum, do the filtering and return +# the filtered spectrum after plotting the filtered data. + +procedure rv_do_filter (rv, ssp, vec, npts, filt, fnpts, do_plot) + +pointer rv #I RV struct pointer +pointer ssp #I Sample struct pointer +real vec[ARB] #I Prepared input spectrum +int npts #I Npts in array +real filt[ARB] #O Output Filtered spectrum +int fnpts #I Npts in array +int do_plot #I Draw a plot? + +pointer sp, data, prep +int i, iremain +real dc +real rv_avgpix() + +define REVERSE 1 + +begin + # Allocate some space + call smark (sp) + call salloc (data, 2*fnpts, TY_REAL) + call salloc (prep, 2*fnpts, TY_REAL) + + # Now prepare the vector + call amovr (vec, Memr[data], npts) + dc = rv_avgpix (Memr[data], npts) + call prep_spec (rv, ssp, npts, fnpts, npts, data, prep, 0, NO) + + # Do the filtering + call afftrx (Memr[prep], Memr[prep], fnpts) # Do forward tform + call rv_filter (rv, Memr[prep], fnpts/2) # Do the filtering + call aiftrx (Memr[prep], Memr[prep], fnpts) # Inverse transform gives + # filtered spectrum + + # Remove the centering effects, inverse apodize, and rebias + if (fnpts != npts) { + iremain = (fnpts - npts) / 2 + do i = 1, npts + filt[i] = Memr[prep+i+iremain-1] + dc + } else + call aaddkr (Memr[prep], dc, filt, npts) + + # Now do the plot to the screen of the filtered data + if (do_plot == YES) + call fft_fltplot (rv, RV_GP(rv), filt, npts) + + call sfree (sp) +end + + +# RV_HANNING - Compute a Hanning window. + +real procedure rv_hanning (j, N) + +int j #I Point in array +int N #I Npts over which window extends + +real hval + +begin + hval = 0.5 * (1.0 - cos (double(TWOPI*j) / double (N-1)) ) + if (hval < 0.0) + hval = 0.0 + return (hval) +end + + +# RV_WELCH - Compute a Welch window. + +real procedure rv_welch (j, N) + +int j #I Point in array +int N #I Npts over which window extends + +real wval + +begin + wval = 1.0 - ( (j - (0.5*(N-1))) / (0.5*(N+1)) )**2 + if (wval < 0.0) + wval = 0.0 + return (wval) +end diff --git a/noao/rv/rvfitfunc.x b/noao/rv/rvfitfunc.x new file mode 100644 index 00000000..30248393 --- /dev/null +++ b/noao/rv/rvfitfunc.x @@ -0,0 +1,477 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" + +# RV_FIT - Fit the CCF in the specified region. Return the exact pixel +# shift and sigma of the fit. + +procedure rv_fit (rv, xcf, ycf, ledge, redge, npts, ishift, shift, sigma) + +pointer rv #I RV struct pointer +real xcf[ARB], ycf[ARB] #I Array of correlation peaks +int ledge #I Left edge to fit +int redge #I Right edge to fit +int npts #I Npts between edges +int ishift #I Initial index of shift +real shift #O Computed shift +real sigma #O Sigma of fit + +pointer gp +real hght, init, peak, c[4] +real a, b, thresh, fwhm +int i, tnum + +real rv_width(), center1d() +int rv_getshift() + +include "fitcom.com" +include "rvsinc.com" +define NPARS 4 + +begin + # Erase the old fit first. + call rv_erase_fit (rv, false) + RV_FITDONE(rv) = NO + RV_ERRCODE(rv) = OK + IS_DBLSTAR(rv) = NO + + # Do some window bounds checking. + if (ledge < (RV_WINCENTER(rv)-RV_WINDOW(rv)) || + redge > (RV_WINCENTER(rv)+RV_WINDOW(rv))) { + call rv_err_comment (rv, + "WARNING: Some points in fit are outside window bounds.", "") + if (RV_INTERACTIVE(rv) == YES) { + call rv_errmsg ( + "Warning: Some points in fit are outside window bounds.") + call tsleep (1) + } + } + + # Save some info + RV_ISHIFT(rv) = ishift + RV_ISTART(rv) = ledge + RV_IEND(rv) = redge + gp = RV_GP(rv) + + # Initialize some variables + tnum = RV_TEMPNUM(rv) + + # Do the fitting + switch (RV_FITFUNC(rv)) { + case GAUSSIAN: # call gaussian fitting + call rv_fgauss (rv, xcf, ycf, ledge, redge, npts, ishift, c, sigma) + if (RV_ERRCODE(rv) == ERR_FIT) { + if (c[3] <= 0.0) { + return + } else { + call rv_draw_fit (rv, gp, NO) + return + } + } + shift = c[2] + if (IS_INDEF(RV_BACKGROUND(rv))) + hght = c[1] + c[4] + else + hght = c[1] + RV_BACKGROUND(rv) + + case LORENTZIAN: # call lorentzian fitting + call rv_fgauss (rv, xcf, ycf, ledge, redge, npts, ishift, c, sigma) + #c[3] = abs (c[3]) + if (RV_ERRCODE(rv) == ERR_FIT) { + call rv_draw_fit (rv, gp, NO) + return + } + shift = c[2] + call lorentz (shift, 3, c, 4, hght) + hght = 2.0 * c[1] / c[3] + if (!IS_INDEF(RV_BACKGROUND(rv))) + hght = hght + RV_BACKGROUND(rv) + + case PARABOLA: # call parabola fitting routine + call rv_fparab (rv, xcf, ycf, ledge, redge, npts, ishift, c, sigma) + shift = -c[2] / (2. * c[3]) + hght = c[1] + (c[2] * shift) + (c[3] * shift * shift) + peak = c[1] - c[2]**2 / (4. * c[3]) + RV_FWHM(rv) = sqrt ( abs(-peak / (2. * c[3]))) + + case CENTER1D: + init = real (rv_getshift (ycf[ledge], npts, MAXIMUM)) + call alimr (ycf[ledge], npts, a, b) + #thresh = (b - a) - 0.01 + thresh = 0.0 + peak = center1d (init, ycf[ledge], npts, npts/5., 1, 2., thresh) + RV_HEIGHT(rv) = INDEF + RV_FWHM(rv) = INDEF + RV_ERROR(rv) = INDEFD + RV_R(rv) = INDEF + RV_DISP(rv) = INDEF + if (RV_GP(rv) != NULL && RV_INTERACTIVE(rv) == YES) { + call gpmark (gp, xcf[ledge], ycf[ledge], npts, 4, 2., 2.) + call gflush (gp) + } + + if (IS_INDEF(peak)) { # check for an error + RV_ERRCODE(rv) = ERR_FIT + return + } else { + shift = peak + (xcf[ledge] - 1.0) + + if (RV_GP(rv) != NULL && RV_INTERACTIVE(rv) == YES) { + call gline (gp, shift, ycf[ishift], shift, ycf[ishift]+0.1) + call gflush (gp) + } + } + RV_FITDONE(rv) = YES + return + + case SINC: + call rv_sinc (rv, shift, fwhm, hght) + RV_FWHM(rv) = fwhm + RV_SHIFT(rv) = shift + RV_ERROR(rv) = INDEFD + RV_R(rv) = INDEF + RV_DISP(rv) = INDEF + if (RV_GP(rv) != NULL && RV_INTERACTIVE(rv) == YES) + call gpmark (gp, xcf[ledge], ycf[ledge], npts, 4, 2., 2.) + RV_FITDONE(rv) = YES + if (IS_INDEF(fwhm)) { # no fwhm computed, so leave here + call rv_draw_fit (rv, gp, NO) + return + } + } + call amovr (c, COEFF(rv,1), NPARS) + RV_FWHM(rv) = rv_width (rv) + RV_HEIGHT(rv) = hght + + # Redraw the new points fit if they were changed. Also save new fit + # window parameters + if (ledge != RV_ISTART(rv) && RV_FITFUNC(rv) != SINC) { + if (gp != NULL && RV_INTERACTIVE(rv) == YES) { + call gseti (gp, G_PMLTYPE, GL_CLEAR) + call gpmark (gp, xcf[RV_ISTART(rv)], ycf[RV_ISTART(rv)], + (RV_IEND(rv)-RV_ISTART(rv)+1), 4, 2., 2.) + call gseti (gp, G_PMLTYPE, GL_SOLID) + call gpmark (gp, xcf[ledge], ycf[ledge], npts, 4, 2., 2.) + call gpline (gp, xcf[RV_ISTART(rv)], ycf[RV_ISTART(rv)], + (RV_IEND(rv)-RV_ISTART(rv)+1)) + call gflush (gp) + } + RV_ISTART(rv) = ledge + RV_IEND(rv) = ledge + npts + } + nfit = npts + + # Compute the antisymmetric part of correlation and velocity error + call realloc (RV_ANTISYM(rv), RV_CCFNPTS(rv), TY_REAL) + if (!IS_INDEF(RV_FWHM(rv))) { + call rv_antisym (rv, shift, hght, RV_FWHM(rv), ycf, RV_CCFNPTS(rv), + ANTISYM(rv,1), ccfvar, RV_ERROR(rv), RV_R(rv)) + } else { + RV_R(rv) = INDEF + if (RV_DCFLAG(rv) != -1) + RV_ERROR(rv) = sigma * RV_DELTAV(rv) + else + RV_ERROR(rv) = sigma + } + + # Now get the dispersion of the peak + if (RV_DCFLAG(rv) != -1 && !IS_INDEF(RV_FWHM(rv))) + RV_DISP(rv) = RV_FWHM(rv) * RV_DELTAV(rv) + else + RV_DISP(rv) = INDEF + + # Debugging info + if (DBG_DEBUG(rv) == YES && DBG_LEVEL(rv)>=2) { + call d_printf(DBG_FD(rv), "rvfitfunc:\n") + call d_printf(DBG_FD(rv), "\tledge=%d redge=%d npts=%d ishift=%d\n") + call pargi(ledge); call pargi(redge) + call pargi(npts); call pargi(ishift) + call d_printf(DBG_FD(rv), + "\tshift=%.4g sigma=%.4g fwhm=%.4g disp=%.4g hght=%.4g peak=%.4g\n") + call pargr(shift); call pargr(sigma); call pargr(RV_FWHM(rv)) + call pargr(RV_DISP(rv));call pargr(hght); call pargr(peak) + do i = 1, NPARS { + call d_printf (DBG_FD(rv), "\t c[%d]=%g +/- %g\n") + call pargi(i); call pargr(c[i]); call pargr (ECOEFF(rv,i)) + } + call flush (DBG_FD(rv)) + } + + # Put stuff in the common for the log + binshift = xcf[ishift] + + if (RV_ERRCODE(rv) == OK) { + RV_FITDONE(rv) = YES + RV_UPDATE(rv) = YES + } + + # Plot the computed fit. + call rv_draw_fit (rv, gp, NO) + + # Mark the background level. + if (RV_FITFUNC(rv) == GAUSSIAN || RV_FITFUNC(rv) == LORENTZIAN) { + if (RV_INTERACTIVE(rv) == YES) + call rv_draw_background (rv, gp) + } +end + + +# RV_WIDTH - Procedure to compute the width of the CCF. + +real procedure rv_width (rv) + +pointer rv #I RV struct pointer + +real fwhm, h, l, r, peak, shift +int gstati() + +include "fitcom.com" + +begin + # Now correct it for a fixed baseline + switch (RV_FITFUNC(rv)) { + case GAUSSIAN: + fwhm = sqrt (COEFF(rv,3)) * 2.35482 + l = COEFF(rv,2) - fwhm / 2. + r = COEFF(rv,2) + fwhm / 2. + call cgauss1d (l, 1, COEFF(rv,1), nfitpars, h) + case LORENTZIAN: + fwhm = 2. * abs (COEFF(rv,3)) + fwhm = abs (COEFF(rv,3)) # for new lorentzian + l = COEFF(rv,2) - fwhm / 2. + r = COEFF(rv,2) + fwhm / 2. + call lorentz (l, 1, COEFF(rv,1), nfitpars, h) + case PARABOLA: + peak = COEFF(rv,1) - COEFF(rv,2)**2 / (4. * COEFF(rv,3)) + fwhm = sqrt ( abs(- peak / (2. * COEFF(rv,3)))) + #return (fwhm) + shift = -COEFF(rv,2) / (2.*COEFF(rv,3)) + l = shift - fwhm / 2. + r = shift + fwhm / 2. + h = COEFF(rv,1) + COEFF(rv,2) * l + COEFF(rv,3) * l**2 + case CENTER1D: + return (INDEF) + case SINC: + # The structure parameters were computed before, we just need + # this to draw the marker. + l = RV_SHIFT(rv) - RV_FWHM(rv) / 2. + r = RV_SHIFT(rv) + RV_FWHM(rv) / 2. + h = RV_FWHM_Y(rv) + fwhm = RV_FWHM(rv) + } + RV_FWHM_Y(rv) = h + + # Now draw the line showing the width + if (RV_GP(rv) != NULL && RV_INTERACTIVE(rv) == YES) { + if (gstati(RV_GP(rv),G_PLCOLOR) != C_BACKGROUND) { + call gseti (RV_GP(rv), G_PLTYPE, GL_DASHED) + call gseti (RV_GP(rv), G_PLCOLOR, RV_LINECOLOR(rv)) + } + call gline (RV_GP(rv), l, h, r, h) + if (gstati(RV_GP(rv),G_PLCOLOR) != C_BACKGROUND) { + call gseti (RV_GP(rv), G_PLTYPE, GL_SOLID) + call gseti (RV_GP(rv), G_PLCOLOR, C_FOREGROUND) + } + call gflush (RV_GP(rv)) + } + + return (fwhm) +end + + +# RV_XFIT - Set the fitting endpoints as described for the 'g' keystroke +# command. + +procedure rv_xfit (rv, x, do_correction) + +pointer rv #I RV struct pointer +real x #I Current cursor x position +int do_correction #I Do heliocentric correction? + +real sregion, eregion, y +real shift, sigma +int istart, iend, ishift, npts, stat + +int rv_getshift(), rv_rvcorrect() + +include "fitcom.com" + +begin + sregion = x # get endpoints + call rv_getpts (rv, eregion, y, 2) + + npts = RV_CCFNPTS(rv) # Fit the region + call rv_fixx (sregion, eregion, WRKPIXX(rv,1), WRKPIXX(rv,npts)) + istart = int (npts/2 + 1 + sregion) + iend = int (npts/2 + 1 + eregion) + npts = int (iend - istart + 1) + nfit = npts + ishift = rv_getshift (WRKPIXY(rv,istart), npts, MAXIMUM) + + # now jump into the fitting routines + call rv_fit (rv, WRKPIXX(rv,1), WRKPIXY(rv,1), istart, iend, npts, + ishift+istart-1, shift, sigma) + if (RV_ERRCODE(rv) == ERR_FIT) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Fit did not converge") + else + call rv_err_comment (rv, "Fit did not converge", "") + return + } + RV_SHIFT(rv) = shift + RV_SIGMA(rv) = sigma + + if (do_correction == YES) { + stat = rv_rvcorrect (rv, shift, sigma, RV_VOBS(rv), RV_VCOR(rv), + RV_ERROR(rv)) + if (stat != OK) { + call rv_err_comment (rv, + "WARNING: Heliocentric correction not done properly.", "") + } + if (RV_INTERACTIVE(rv) == YES) + call rv_writeln (rv, STDOUT) + } +end + + +# RV_YFIT - Fit the CCF based on the Y value of the cursor, as described +# for the 'y' keystroke command or the HEIGHT parameter. + +procedure rv_yfit (rv, y, do_correction) + +pointer rv #I RV struct pointer +real y #I Current Y cursor value +int do_correction #I Do heliocentric correction? + +real sregion, eregion +real shift, sigma, center +int istart, iend, ishift, npts, stat, i + +int rv_getshift(), rv_rvcorrect() + +include "fitcom.com" + +begin + # Search the array for the closest points in y + npts = RV_WINR(rv) - RV_WINL(rv) + 1 + center = RV_CCFNPTS(rv)/2 + 1 + WRKPIXX(rv,RV_WINCENTER(rv)) + i = int (center - RV_WINDOW(rv)) + ishift = rv_getshift (WRKPIXY(rv,i), npts, MAXIMUM) + i - 1 + i = 0 + while (WRKPIXY(rv,ishift-i) > y && i <= npts) { + sregion = WRKPIXX(rv, ishift-i) + i = i + 1 + } + i = 0 + while (WRKPIXY(rv, ishift+i) > y && i <= npts) { + eregion = WRKPIXX(rv, ishift+i) + i = i + 1 + } + + # Pick up at fitting routines + npts = RV_CCFNPTS(rv) + istart = int (npts/2 + 1 + sregion) + iend = int (npts/2 + 1 + eregion) + npts = (iend - istart + 1) + + # Do the minwidth/maxwidth/window constraints + call rv_fix_window (rv, 1., real(RV_CCFNPTS(rv)), y, WRKPIXX(rv,1), + WRKPIXY(rv,1), istart, iend, ishift, npts) + + # Go ahead and fit this puppy + call rv_fit (rv, WRKPIXX(rv,1), WRKPIXY(rv,1), istart, iend, + npts, ishift, shift, sigma) + if (RV_ERRCODE(rv) == ERR_FIT) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Fit did not converge") + else + call rv_err_comment (rv, "Fit did not converge", "") + return + } + RV_SHIFT(rv) = shift + RV_SIGMA(rv) = sigma + + if (do_correction == YES) { + stat = rv_rvcorrect (rv, shift, sigma, RV_VOBS(rv), RV_VCOR(rv), + RV_ERROR(rv)) + if (RV_INTERACTIVE(rv) == YES) + call rv_writeln (rv, STDOUT) + } +end + + +# RV_FIX_WINDOW - Resize the fit window according to the minwidth/maxwidth +# constraint parameters. This routine also recenters the window on the +# initial guess at the shift so points are evenly spaced about the peak. +# Does a bounds check to avoid segmentation violations. + +procedure rv_fix_window (rv, x1, x2, y, xcf, ycf, istart, iend, ishift, npts) + +pointer rv #I RV struct pointer +real x1, x2 #I Bounds check +real y #I Threshold level +real xcf[ARB], ycf[ARB] #I CCF array +int istart #U Start pixel of fit +int iend #U End pixel of fit +int ishift #U Peak pixel of fit +int npts #U Npts in between + +int i, np1, np2 + +begin + if (npts < RV_MINWIDTH(rv)) { + np1 = RV_MINWIDTH(rv) - npts # Pad some points + istart = istart - (np1 / 2) + iend = iend + (np1 / 2) + if (mod(np1,2) == 1) + iend = iend + 1 + } else if (npts > RV_MAXWIDTH(rv)) { + np1 = npts - RV_MAXWIDTH(rv) # Delete some points + istart = istart + (np1 / 2) + iend = iend - (np1 / 2) + if (mod(np1,2) == 1) + iend = iend - 1 + } + npts = int (iend - istart + 1) + + # Next, we have to make sure we honor the original constraint that + # all points are above a certain level + if (npts > RV_MINWIDTH(rv)) { + i = istart + while (ycf[i] < y && i <= ishift) # Fix left side + i = i + 1 + if (i != istart) + istart = i #+ 1 + i = iend + while (ycf[i] < y && i >= ishift) # Fix right side + i = i - 1 + if (i != iend) + iend = i #- 1 + } + npts = int (iend - istart + 1) + + # Now recenter the window on the peak + np1 = ishift - istart + np2 = iend - ishift + if ((np1 - np2) < -1) { # Peak is left of center + istart = istart - abs(np1 - np2) / 2 + iend = iend - abs(np1 - np2) / 2 + } else if ((np1 - np2) > 1) { # Peak is right of center + istart = istart + abs(np1 - np2) / 2 + iend = iend + abs(np1 - np2) / 2 + } + npts = int (iend - istart + 1) + + # Lastly, make sure we aren't out of bounds after all this work + if (istart < x1) { + np1 = (x1 - istart) + istart = int (x1) + iend = iend + np1 + } + if (iend > x2) { + np1 = (iend - x2) + iend = int (x2) + istart = istart - np1 + } + npts = int (iend - istart + 1) # Update npts and return +end diff --git a/noao/rv/rvflags.h b/noao/rv/rvflags.h new file mode 100644 index 00000000..35dc2555 --- /dev/null +++ b/noao/rv/rvflags.h @@ -0,0 +1,151 @@ +# Flag definition file for the Radial Velocity Package + +# Velocity Constants (for Heliocentric corrections, relative to LSR) +define VSD 20.0d0 # Solar velocity (Km/sec) +define RASD 18.0d0 # Solar RA (Hours) +define DECSD 30.0d0 # Solar DEC (Degrees) +define EPSD 1900.0d0 # Epoch of above (years) + +# Generic debug flag +define DEBUG (DBG_DEBUG($1)==YES||RV_APODIZE($1)==0.116) + +# Misc. constants +define SPEED_OF_LIGHT 299792.5d0 # in Km/sec +define CLN10 690297.74149142d0 # in Km/sec +define C SPEED_OF_LIGHT # short-hand form + +# Fitting function flags +define PARABOLA 1 # Fit a parabola +define GAUSSIAN 2 # Fit a gaussian (w/ background) +define LORENTZIAN 3 # Fit a Lorentzian profile +define CENTER1D 4 # Fit with center1d() +define DEBLEND 5 # Fit with deblending code +define SINC 6 # Fit with a sin(x)/x code +define RV_CFTYPES "|parabola|gaussian|lorentzian|center1d|deblend|sinc|" + +# Which spectra to process +define OBJ_ONLY 1 # Do only object +define TEMP_ONLY 2 # Do only template +define BOTH 3 # Do both spectra +define NONE 4 # Do neither +define RV_SPTODO "|object|template|both|none|" + +# Data rebinning flags +define RB_OBJ 1 # Rebin to object dispersion +define RB_TEMP 2 # Rebin to template dispersion +define RB_SMALL 3 # Rebin to smaller dispersion +define RB_BIG 4 # Rebin to larger dispersion +define RB_WHICH "|object|template|smallest|largest|" + +# Output CCF types +define OUTPUT_IMAGE 1 # Write CCF as an image +define OUTPUT_TEXT 2 # Write CCF as text file +define LAG 3 # Lag x-axis +define VELOCITY 4 # Velocity x-axis +define CCF_TYPES "|image|text|lag|velocity|" + +# Output file flags +define OF_SHORT 1 # Write a short .txt file +define OF_LONG 2 # Write a long .txt file +define OF_NOLOG 3 # Don't write a .log file +define OF_NOGKI 4 # Don't write a .gki file +define OF_TXTONLY 5 # Write only a .txt file +define OF_STXTONLY 6 # Write a short .txt file +define RV_OFTYPES "|short|long|nolog|nogki|txtonly|stxtonly|" + +# Data rebinning functions. +define IN_NEAREST 1 # Nearest neighbour +define IN_LINEAR 2 # Linear +define IN_POLY3 3 # 3rd order polynomial +define IN_POLY5 4 # 5th order polynomial +define IN_SPLINE3 5 # Cubic spline +define IN_SINC 6 # Sinc +define IN_FUNCTIONS "|nearest|linear|poly3|poly5|spline3|sinc|" + +# Define color constants +define C_BACKGROUND 0 +define C_FOREGROUND 1 +define C_RED 2 +define C_GREEN 3 +define C_BLUE 4 +define C_CYAN 5 +define C_YELLOW 6 +define C_MAGENTA 7 +define C_PUPLE 8 +define C_DARKSLATEGREY 9 +define C_COLOR_NAMES "|background|foreground|red|green|blue|cyan|yellow \ + |magenta|purple|slategrey|" + +# Miscellaneous flags +define ALL_SPECTRUM 0 # No samples selected +define MAXIMUM 1 # Find max point +define MINIMUM 2 # Find min point +define LEFT 3 # Find left side +define RIGHT 4 # Find right side +define OBJECT_SPECTRUM 5 # Which type of data +define REFER_SPECTRUM 6 # Which type of data +define QUIT 7 # Task flag +define MOVE 8 # Move flag + +# Data unit flags +define PIXELS 10 # No dispersion info +define LAMBDA 11 # Lambda dispersion +define LOGLAMBDA 12 # Log-Lambda dispersion +define NONLINEAR 13 # Non-linear dispersion + +# Data format flags +define ONEDSPEC 15 # Onedspec format image +define TWODSPEC 16 # Twodspec (logslit?) images +define ECHELLE 17 # Echelle format image +define MULTISPEC 18 # Multispec format image +define LONGSLIT 19 # Longslit format image + +# Plot flags +define SPECTRUM_PLOT 20 # Overplot both spectra +define CONVOLUTION_PLOT 21 # Plot convolved spectra +define CORRELATION_PLOT 22 # Plot the CCF +define VCORRELATION_PLOT 23 # Plot the CCF w/ velocity axes +define ACORRELATION_PLOT 24 # Plot the CCF w/ angstrom axes +define ANTISYM_PLOT 25 # Plot Antisymmetric noise +define SPLIT_PLOT 26 # Plot a split screen plot +define SINGLE_PLOT 27 # Plot a single screen splot +define FOURIER_PLOT 28 # Plot a Fourier transform +define PS_PLOT 29 # Plot a power spectrum +define NORM_PLOT 30 # Plot a spectrum normalization +define FILTER_PLOT 31 # Plot of filtered spectrum +define RESIDUAL_PLOT 32 # Plot residuals of the fit +define SUMMARY_PLOT 33 # Plot the summary +define OBJ_PLOT 34 # Plot object spectrum +define TEMP_PLOT 35 # Plot template spectrum +define PREPARED_PLOT 36 # Plot FFT prepared spectrum +define BINARY_PLOT 37 # Binary star summary plot +define ZOOM 38 # Plot flag +define FILTER 39 # Plot the actual filter +define TOP 40 # Split screen plot flag +define MIDDLE 41 # Split screen plot flag +define BOTTOM 42 # Split screen plot flag + +# Command mode flags +define CCF_MODE 1 # Correlation mode +define FFT_MODE 2 # FFT mode +define SPEC_MODE 3 # Spectrum mode +define CONT_MODE 4 # Continuum mode + +# Error Codes +define ERR_SIDE -1 # Trouble finding a side to line +define ERR_NOPEAK -2 # Couldn't find a peak in CCF +define ERR_OBPEAK -3 # Peak found out of bounds +define ERR_DOUBLE -4 # Possible double star +define ERR_RVCOR -5 # Error in RV correction +define ERR_FIT -6 # Error in fitting function +define ERR_CORREL -7 # Error in correlation +define ERR_READ -8 # Error in reading data +define ERR_KEYW -9 # Error getting image header keyword +define ERR_GENERIC -10 # Generic error - need a code? +define ERR_PARAM -11 # generic parameter error +define ERR_REAL -INDEFR # Generic real valued error code + +# Help files +define XC_HELP "noao$lib/scr/fxcor.key" # Help key - FXCOR +define FM_HELP "noao$lib/scr/fftmode.key" # Help key - FFT Mode +define SM_HELP "noao$lib/scr/specmode.key" # Help key - Spectrum Mode diff --git a/noao/rv/rvfparab.x b/noao/rv/rvfparab.x new file mode 100644 index 00000000..01b7aa9e --- /dev/null +++ b/noao/rv/rvfparab.x @@ -0,0 +1,159 @@ +include <math.h> +include <gset.h> +include <math/nlfit.h> +include "rvpackage.h" +include "rvflags.h" + +# RV_FPARAB - Fit a parabola to the specified function. Compute and return +# an array of the fitted parabola at the specified resolution in ccf[]. +# 'c' contains the coefficients of the fit. + +procedure rv_fparab (rv, xcf, ycf, ledge, redge, npts, ishift, c, sigma) + +pointer rv #I RV struct pointer +real xcf[npts], ycf[npts] #I CCF array +int ledge, redge #I Index of left edge +int npts #I Number of points +int ishift #I initial shift index +real c[NPARS] #O Array of coefficients +real sigma #O Error of position (pixels) + +pointer sp, gp, nl, list, w, ipx, ipy, fit +int i, j, stat, npar, il, ir, rnpts +int ft_func, ft_dfunc +real center, oldcenter, width, distance +real ce[3], diff + +extern polyfit(), dpolyfit() +real fit_weight() +int locpr() + +include "fitcom.com" +define NPARS 3 + +begin + call smark (sp) + call salloc (list, NPARS, TY_INT) + call salloc (ipx, NPARS, TY_REAL) + call salloc (ipy, NPARS, TY_REAL) + call salloc (w, npts, TY_REAL) + call salloc (fit, npts, TY_REAL) + + gp = RV_GP(rv) + if (gp != NULL && RV_INTERACTIVE(rv) == YES) { + call gseti (gp, G_WCS, 2) + call gpmark (gp, xcf[ledge], ycf[ledge], npts, 4, 2., 2.) + call gflush (gp) + } + + # Initialize the parameters. + il = ishift - 1 + ir = ishift + 1 + call amovr (xcf[il], Memr[ipx], NPARS) + call amovr (ycf[il], Memr[ipy], NPARS) + call parab (Memr[ipx], Memr[ipy], c) + call aclrr (ce, NPARS) + + # Initialize the list of params to fit. + Memi[list] = 1 + Memi[list+1] = 2 + Memi[list+2] = 3 + + if (DBG_DEBUG(rv) == YES && DBG_FD(rv) != NULL) { + call d_printf (DBG_FD(rv), "\nrv_fparab:\n\t") + call d_printf (DBG_FD(rv), "init c[1-3] = %.6g %.6g %.6g\n") + call pargr (c[1]) ; call pargr (c[2]) ; call pargr (c[3]) + call d_flush (DBG_FD(rv)) + } + + # Now iterate the fit. + j = 1 + oldcenter = 0.0 + center = xcf[ishift] + width = npts + rnpts = npts * 1000 + ft_func = locpr (polyfit) + ft_dfunc = locpr (dpolyfit) + while (j < RV_MAXITERS(rv)) { + + # Move data window if necessary; only one pixel per iteration. + if (j > 1 && c[3] != 0.0) { + center = abs (-c[2] / (2. * c[3])) + diff = (oldcenter - center) + if (diff > 1 && ledge > 1) + ledge = ledge - 1 + else if (diff < -1 && (ledge+npts) < RV_CCFNPTS(rv)) + ledge = ledge + 1 + } + + # Compute the point weighting. + do i = 0, npts-1 { + distance = abs (center - xcf[ledge+i]) + Memr[w+i] = fit_weight (distance, width, RV_WEIGHTS(rv)) + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv),"\tx=%g y=%g dist=%g weight=%g\n") + call pargr(xcf[ledge+i-1]) ; call pargr(ycf[ledge+i-1]) + call pargr (distance) ; call pargr(Memr[w+i-1]) + } + } + + # Now do the NLFIT initializations and fit. + call nlinitr (nl, ft_func, ft_dfunc, c, ce, NPARS, Memi[list], + NPARS, RV_TOLERANCE(rv), RV_MAXITERS(rv)) + call nlfitr (nl, xcf[ledge], ycf[ledge], Memr[w], npts, 1, + WTS_USER, stat) + call nlvectorr (nl, xcf[ledge], Memr[fit], npts, 1) + call nlpgetr (nl, c, npar) + call nlerrorsr (nl, ycf[ledge], Memr[fit], Memr[w], npts, ccfvar, + chisqr, ce) + call nlfreer (nl) # free the NLFIT struct + + # Now check for convergence. + if (c[3] != 0.0) + center = abs (-c[2] / (2. * c[3])) + if (j == 1) # initialize + oldcenter = center + else if (abs(center - oldcenter) < 0.001) # converged + break + else + oldcenter = center + + j = j + 1 # next iteration + } + niter = j + nfit = nint (width) + nfitpars = NPARS + if (ce[3] != 0.0) + sigma = abs (-ce[2] / (2. * ce[3])) + call amovr (ce, ECOEFF(rv,1), NPARS) + + if (DBG_DEBUG(rv) == YES && DBG_LEVEL(rv) >= 2 && DBG_FD(rv) != NULL) { + call d_printf (DBG_FD(rv), "\tfitted c[1-3] = %.6g %.6g %.6g\n") + call pargr (c[1]) ; call pargr (c[2]) ; call pargr (c[3]) + call d_printf (DBG_FD(rv), "\tfitted ce[1-3] = %.6g %.6g %.6g\n") + call pargr (ce[1]) ; call pargr (ce[2]) ; call pargr (ce[3]) + call flush (DBG_FD(rv)) + } + + call sfree (sp) +end + + +# PARAB -- Fit a parabola to three points - used to get a first pass at the +# coefficients. + +procedure parab (x, y, c) + +real x[NPARS], y[NPARS] #I Input (x,y) data pairs +real c[NPARS] #O Parabola coefficients + +begin + c[3] = (y[1]-y[2]) * (x[2]-x[3]) / (x[1]-x[2]) - (y[2]-y[3]) + c[3] = c[3] / ((x[1]**2-x[2]**2) * (x[2]-x[3]) / (x[1]-x[2]) - + (x[2]**2-x[3]**2)) + + c[2] = (y[1] - y[2]) - c[3] * (x[1]**2 - x[2]**2) + c[2] = c[2] / (x[1] - x[2]) + + c[1] = y[1] - c[2] * x[1] - c[3] * x[1]**2 +end diff --git a/noao/rv/rvfuncs.x b/noao/rv/rvfuncs.x new file mode 100644 index 00000000..ee6d523e --- /dev/null +++ b/noao/rv/rvfuncs.x @@ -0,0 +1,282 @@ +include <math.h> +include <mach.h> + +# FUNCS - File to contain all of the functional models and derivatives. +# Models currently supported are: +# - Gaussian on a constant background +# - N-th order polynomial +# - Lorentzian on a constant background + +# CGAUSS1D - Procedure to compute the value of a 1-D Gaussian function +# sitting on top of a constant background. + +procedure cgauss1d (x, nvars, p, np, z) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude p[2]=center p[3]=sigma p[4]=background +int np # number of parameters np = 4 +real z # function return + +real r2 + +begin + r2 = (x - p[2]) ** 2 / (2. * p[3]) + if (abs (r2) > 25.0) + z = p[4] + else + z = p[1] * exp (-r2) + p[4] +end + + +# CDGAUSS1D -- Procedure to compute a 1-D Gaussian profile and its derivatives. +# The Gaussian is assumed to sitting on top of a constant background. + +procedure cdgauss1d (x, nvars, p, dp, np, z, der) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude, p[2]=center, p[3]=sky, p[4]=sigma +real dp[ARB] # parameter derivatives +int np # number of parameters np=4 +real z # function value +real der[ARB] # derivatives + +real dx, r2 + +begin + dx = x - p[2] + r2 = dx * dx / (2.0 * p[3]) + if (abs (r2) > 25.0) { + z = p[4] + der[1] = 0.0 + der[2] = 0.0 + der[3] = 0.0 + der[4] = 1.0 + } else { + der[1] = exp (-r2) + z = p[1] * der[1] + der[2] = z * dx / p[3] + der[3] = z * r2 / p[3] + der[4] = 1.0 + z = z + p[4] + } +end + + +# D_CGAUSS1D - Procedure to compute the value of a 1-D Gaussian function +# sitting on top of a constant background. + +procedure d_cgauss1d (x, nvars, p, np, z) + +double x # position coordinate +int nvars # number of variables +double p[ARB] # p[1]=amplitude p[2]=center p[3]=sigma p[4]=background +int np # number of parameters np = 4 +double z # function return + +double r2 + +begin + r2 = (x - p[2]) ** 2 / (2. * p[3]) + if (abs (r2) > 25.0) + z = p[4] + else + z = p[1] * exp (-r2) + p[4] +end + + +# D_CDGAUSS1D -- Procedure to compute a 1-D Gaussian profile and its deriv- +# atives. The Gaussian is assumed to sitting on top of a constant background. + +procedure d_cdgauss1d (x, nvars, p, dp, np, z, der) + +double x # position coordinate +int nvars # number of variables +double p[ARB] # p[1]=amplitude, p[2]=center, p[3]=sky, p[4]=sigma +double dp[ARB] # parameter derivatives +int np # number of parameters np=4 +double z # function value +double der[ARB] # derivatives + +double dx, r2 + +begin + dx = x - p[2] + r2 = dx * dx / (2.0 * p[3]) + if (abs (r2) > 25.0) { + z = p[4] + der[1] = 0.0 + der[2] = 0.0 + der[3] = 0.0 + der[4] = 1.0 + } else { + der[1] = exp (-r2) + z = p[1] * der[1] + der[2] = z * dx / p[3] + der[3] = z * r2 / p[3] + der[4] = 1.0 + z = z + p[4] + } +end + + +# POLYFIT -- Procedure to compute the fit of an N-order polynomial + +procedure polyfit (x, nvars, p, np, z) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # coefficients of polynomial +int np # number of parameters +real z # function return + +int i +real r + +begin + r = 0.0 + do i = 2, np + r = r + x**(i-1) * p[i] + z = p[1] + r +end + + +# DPOLYFIT -- Procedure to compute the function value and derivatives of +# a N-order polynomial. + +procedure dpolyfit (x, nvars, p, dp, np, z, der) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude, p[2]=center, p[3]=sigma +real dp[ARB] # parameter derivatives +int np # number of parameters +real z # function value +real der[ARB] # derivatives + +int i + +begin + der[1] = 1.0 + z = 0.0 + do i = 2, np { + der[i] = x ** (i-1) + z = z + x**(i-1) * p[i] + } + z = p[1] + z +end + + +# LORENTZ -- Procedure to compute a Lorentzian profile + +procedure lorentz (x, nvars, p, np, z) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude p[2]=center p[3]=fwhm p[4]=background +int np # number of parameters np = 4 +real z # function return + +real r2 + +begin + r2 = (x - p[2])**2 + (p[3] / 2.0)**2 + if (r2 != 0.0) + z = p[1] * ((p[3]/2.0) / r2) + p[4] + else + z = p[4] +end + + +# DLORENTZ -- Procedure to compute the function value and derivatives of +# a Lorentzian profile + +procedure dlorentz (x, nvars, p, dp, np, z, der) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude, p[2]=center, p[3]=fwhm, [4]=background +real dp[ARB] # parameter derivatives +int np # number of parameters +real z # function value +real der[ARB] # derivatives + +real dl, dr, d2 + +begin + dl = (x - p[2]) * (x - p[2]) + dr = (0.5 * p[3]) * (0.5 * p[3]) + d2 = dl + dr + if (d2 == 0.0) { + der[1] = 0.0 + der[2] = 0.0 + der[3] = 0.0 + der[4] = 1.0 + z = p[4] + } else { + der[1] = ((p[3]/2.0) / d2) + der[2] = (p[1]*p[3]/2.0) * (2.0 * (x - p[2])) / (d2 * d2) + der[3] = ((p[1] / (2.0 * d2)) - (((p[1]*p[3]*p[3])/2.0)/(d2*d2))) + der[4] = 1.0 + z = p[1] * ((p[3]/2.0) / d2) + p[4] + } +end + + +# LORENTZ -- Procedure to compute a Lorentzian profile + +procedure lorentz_old (x, nvars, p, np, z) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude p[2]=center p[3]=fwhm p[4]=background +int np # number of parameters np = 4 +real z # function return + +begin + if (p[3] != 0.0) + z = p[1] / (1. + ((x-p[2])/p[3])**2) + p[4] + else + z = p[4] +end + + +# DLORENTZ -- Procedure to compute the function value and derivatives of +# a Lorentzian profile + +procedure dlorentz_old (x, nvars, p, dp, np, z, der) + +real x # position coordinate +int nvars # number of variables +real p[ARB] # p[1]=amplitude, p[2]=center, p[3]=fwhm, [4]=background +real dp[ARB] # parameter derivatives +int np # number of parameters +real z # function value +real der[ARB] # derivatives + +real dx, D + +begin + #dx = (x - p[2]) / p[3] # Frank's derivs + dx = (x - p[2]) + D = 1. + (dx/p[3])**2 + if (p[3] == 0.0) { + der[1] = 0.0 + der[2] = 0.0 + der[3] = 0.0 + der[4] = 1.0 + z = p[4] + } else { + der[1] = 1. / D + der[2] = p[1] / D**2 * (2. * dx / p[3]**2) + der[3] = p[1] / D**2 * (2. * dx * dx / p[3]**3) + #der[2] = p[1] / D**2 * (2. * dx / p[3]) # Frank's derivs + #der[3] = -p[1] / D**2 * (2. * dx * dx / p[3]) + der[4] = 1.0 + if (p[3] != 0.0) + z = p[1] / (1. + ((x-p[2])/p[3])**2) + p[4] + else + z = p[4] + } +end diff --git a/noao/rv/rvgetim.x b/noao/rv/rvgetim.x new file mode 100644 index 00000000..cbfc0bb6 --- /dev/null +++ b/noao/rv/rvgetim.x @@ -0,0 +1,290 @@ +include <smw.h> +include <units.h> +include "rvpackage.h" +include "rvflags.h" +include "rvkeywords.h" +include "rvsample.h" + + +# RV_GETIM - Get an image from the input list given the image name, and +# then rebin it to the specified dispersion and starting wavelength. + +int procedure rv_getim (rv, name, type, crval_1, crval_n, nnpts) + +pointer rv #I RV struct pointer +char name[SZ_FNAME] #I Name of image to read +int type #I Type of image to get (object|reference) +real crval_1, crval_n #I Requested wavelength region +int nnpts #I New number of points + +pointer im # Image pointer +pointer smw # SMW pointer +pointer sh # SHDR pointer +real w0, wpc, tvel +int i, npts + +pointer immap(), smw_openim() +real imgetr() +int rv_read(), imaccf() +bool streq() +errchk immap, smw_openim, rv_read, imaccf, realloc + +begin + # Open the image and the WCS. + if (streq("",name) || streq(" ",name)) { + call rv_errmsg ("Null or blank image name specified.") + return (ERR_READ) + } + iferr (im = immap (name, READ_ONLY, 0)) { + call rv_errmsg ("Error opening image '%s'.\n") + call pargstr (name) + call flush (STDERR) + return (ERR_READ) + } + iferr (smw = smw_openim (im)) { + call imunmap (im) + call rv_errmsg ("Error opening image WCS '%s'.\n") + call pargstr (name) + call flush (STDERR) + return (ERR_READ) + } + + # Read the data and check for an error condition + sh = NULL + if (rv_read(rv, im, smw, sh, type, crval_1, crval_n, nnpts)==ERR_READ){ + call shdr_close (sh) + call smw_close (smw) + call imunmap (im) + return (ERR_READ) + } + + # We've had a successfull read so let's load the structure + # All errors will hopefully have been trapped and reported by now. + + npts = SN(sh) + if (RV_PIXCORR(rv) == YES) { + w0 = 1 + wpc = 1 + } else { + w0 = log10 (W0(sh)) + wpc = (log10 (W1(sh)) - w0) / (npts - 1) + } + + if (type == OBJECT_SPECTRUM) { + call realloc (RV_OPIXX(rv), npts, TY_REAL) + call realloc (RV_OPIXY(rv), npts, TY_REAL) + call amovr (Memr[SX(sh)], Memr[RV_OPIXX(rv)], npts) + call amovr (Memr[SY(sh)], Memr[RV_OPIXY(rv)], npts) + do i = 1, npts + OBJPIXX(rv,i) = w0 + (i-1) * wpc + RV_X1(rv) = W0(sh) + RV_X2(rv) = W1(sh) + RV_OAPNUM(rv) = AP(sh) + RV_DCFLAG(rv) = DC(sh) + RV_NPTS(rv) = npts + RV_OW0(rv) = w0 + RV_OWPC(rv) = wpc + RV_OW2(rv) = w0 + (npts - 1) * wpc + RV_OAPNUM(rv) = RV_APNUM(rv) + SR_W0(RV_OSAMPLE(rv)) = w0 + SR_WPC(RV_OSAMPLE(rv)) = wpc + if (RV_DCFLAG(rv) != DCNO) # Get velocity dispersion + RV_DELTAV(rv) = wpc * CLN10 + else + RV_DELTAV(rv) = INDEF + call strcpy (name, IMAGE(rv), SZ_FNAME) + call rv_fill_blanks (TITLE(sh), OBJNAME(rv), SZ_FNAME) + + if (DEBUG(rv)) { + call d_printf(DBG_FD(rv),"rv_getim(): OBJECT\n\t") + call d_printf(DBG_FD(rv),":%s: w0,wpc,npts,dcf=%g,%g,%d,%d\n") + call pargstr(name); call pargr(w0); call pargr(wpc) + call pargi(npts); call pargi(RV_DCFLAG(rv)) + call d_flush(DBG_FD(rv)) + } + + # Do the normalization + OBJCONT(rv) = NO + if (RV_CONTINUUM(rv) == BOTH || RV_CONTINUUM(rv) == OBJ_ONLY) + call do_continuum (rv, OBJECT_SPECTRUM) + + } else { + call realloc (RV_RPIXX(rv), npts, TY_REAL) + call realloc (RV_RPIXY(rv), npts, TY_REAL) + call amovr (Memr[SX(sh)], Memr[RV_RPIXX(rv)], npts) + call amovr (Memr[SY(sh)], Memr[RV_RPIXY(rv)], npts) + do i = 1, npts + REFPIXX(rv,i) = w0 + (i-1) * wpc + RV_X1(rv) = W0(sh) + RV_X2(rv) = W1(sh) + RV_RAPNUM(rv) = AP(sh) + #RV_OAPNUM(rv) = AP(sh) + RV_DCFLAG(rv) = DC(sh) + RV_RNPTS(rv) = npts + RV_RW0(rv) = w0 + RV_RWPC(rv) = wpc + RV_RW2(rv) = w0 + (npts - 1) * wpc + SR_W0(RV_OSAMPLE(rv)) = w0 + SR_WPC(RV_OSAMPLE(rv)) = wpc + call strcpy (name, RIMAGE(rv), SZ_FNAME) + call rv_fill_blanks (TITLE(sh), TEMPNAME(rv), SZ_FNAME) + + if (DEBUG(rv)) { + call d_printf(DBG_FD(rv),"rv_getim(): TEMPLATE\n\t") + call d_printf(DBG_FD(rv),":%s: w0,wpc,npts,dcf=%g,%g,%d,%d\n") + call pargstr(name); call pargr(w0); call pargr(wpc) + call pargi(npts); call pargi(RV_DCFLAG(rv)) + call d_flush(DBG_FD(rv)) + } + + # Get the velocity from the reference star image header. Save the + # warning for outputting results. + call realloc (RV_TEMPVEL(rv), RV_NTEMPS(rv), TY_REAL) + if (imaccf(im, KW_VHELIO(rv)) == YES) + tvel = imgetr(im, KW_VHELIO(rv)) + else + tvel = INDEF + TEMPVEL(rv,RV_TEMPNUM(rv)) = tvel + + # Do the normalization + REFCONT(rv) = NO + if (RV_CONTINUUM(rv) == BOTH || RV_CONTINUUM(rv) == TEMP_ONLY) + call do_continuum (rv, REFER_SPECTRUM) + } + RV_GLOB_W1(rv) = min (RV_OW0(rv), RV_RW0(rv)) + RV_GLOB_W2(rv) = max (RV_OW2(rv), RV_RW2(rv)) + + if (DEBUG(rv)) { + call d_printf(DBG_FD(rv),"\tapnum,oapnum,rapnum=%d,%d,%d\n") + call pargi(RV_APNUM(rv)); call pargi(RV_OAPNUM(rv)) + call pargi(RV_RAPNUM(rv)) + call d_printf(DBG_FD(rv),"\texiting - rv_getim\n") + } + + call shdr_close (sh) + call smw_close (smw) + call imunmap (im) + return (OK) +end + + +# RV_READ - Read the spectrum from "im" with aperture RV_APNUM. +# Convert to log dispersion (except for undispersion corrected data). + +int procedure rv_read (rv, im, smw, sh, type, crval_1, crval_n, nnpts) + +pointer rv #I RV struct pointer +pointer im #I Image pointer +pointer smw #I SMW pointer +pointer sh #O Spectrum +int type #I Type of spectrum to read +real crval_1, crval_n #I Requested wavelength region +int nnpts #I New number of points + +int np +real w0, w1 + +errchk shdr_open, shdr_linear + +define MAXPTS 8192 + +begin + # Get the header. + call shdr_open (im, smw, 1, 1, RV_APNUM(rv), SHHDR, sh) + if (DC(sh) != DCNO) + call shdr_units (sh, "Angstroms") + + # Check units are pixels or Angstroms. + if (DC(sh) != DCNO && UN_TYPE(UN(sh)) != UN_ANG) { + call rv_errmsg("Spectrum units not supported: %s") + call pargstr (UN_USER(UN(sh))) + call tsleep (1) + return (ERR_READ) + } + + # Get data. + call shdr_open (im, smw, 1, 1, RV_APNUM(rv), SHDATA, sh) + if (RV_PIXCORR(rv) == YES) + DC(sh) = DCNO + if (DC(sh) != DCNO) + call shdr_units (sh, "Angstroms") + + # Check for maximum size. + #if (SN(sh) > MAXPTS) { + # call rv_errmsg("Too many data points in image. (MAXPTS=%d)%80t") + # call pargi (MAXPTS) + # call tsleep (1) + # return (ERR_READ) + #} + + # Check aperture numbers. + if (AP(sh) != RV_APNUM(rv)) { + if (type == REFER_SPECTRUM && SMW_NSPEC(smw) == 1) { + call rv_err_comment (rv, + "WARNING: Template image is only 1-D.", "") + } else { + call rv_errmsg ( + "Requested aperture number is out of range; apnum = %d.") + call pargi (RV_APNUM(rv)) + return (ERR_READ) + } + } + + if (IS_INDEFI(nnpts)) + np = SN(sh) + else + np = nnpts + if (IS_INDEF(crval_1)) + w0 = W0(sh) + else + w0 = crval_1 + if (IS_INDEF(crval_n)) + w1 = W1(sh) + else + w1 = crval_n + + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv),"rv_read:\n\tap=%d line_num=%d - %d\n") + call pargi(AP(sh)) ; call pargi(LINDEX(sh,1)) ; call pargi(type) + call d_printf(DBG_FD(rv),"\tval_1,val_n=%g,%g/%d w0,w1=%g,%g/%d\n") + call pargr(crval_1) ; call pargr(crval_n) ; call pargi(nnpts) + call pargr(w0) ; call pargr(w1) ; call pargi(np) + } + + # Rebin if needed. + switch (DC(sh)) { + case DCNO: + if (DEBUG(rv)) + call d_printf (DBG_FD(rv), "\tPIXELS dispersion.\n") + case DCLINEAR: + if (DEBUG(rv)) + call d_printf (DBG_FD(rv), "\tLAMBDA dispersion.\n") + call shdr_linear (sh, w0, w1, np, DCLOG) + W0(sh) = w0 + W1(sh) = w1 + SN(sh) = np + case DCLOG: + if (DEBUG(rv)) + call d_printf (DBG_FD(rv), "\tLOGLAMBDA dispersion.\n") + if (!IS_INDEF(crval_n)) { + call shdr_linear (sh, w0, w1, np, DCLOG) + W0(sh) = w0 + W1(sh) = w1 + SN(sh) = np + } + case DCFUNC: + if (DEBUG(rv)) + call d_printf (DBG_FD(rv), "\tNONLINEAR dispersion.\n") + call shdr_linear (sh, w0, w1, np, DCLOG) + W0(sh) = w0 + W1(sh) = w1 + SN(sh) = np + } + + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv),"\tafter: w0,w1=%g,%g\n") + call pargr(w0) ; call pargr(w1) + call d_printf (DBG_FD(rv), "\texiting - rv_read\n") + } + return (OK) +end diff --git a/noao/rv/rvidlines.par b/noao/rv/rvidlines.par new file mode 100644 index 00000000..834aac1a --- /dev/null +++ b/noao/rv/rvidlines.par @@ -0,0 +1,22 @@ +# Parameters for rvidlines task. + +images,s,a,,,,Images containing features to be identified +section,s,h,"middle line",,,Section to apply to two dimensional images +database,f,h,database,,,Database in which to record feature data +coordlist,f,h,,,,User coordinate list +nsum,s,h,"10",,,Number of lines/columns/bands to sum in 2D images +match,r,h,10.,,,Coordinate list matching limit in user units +maxfeatures,i,h,50,,,Maximum number of features for automatic identification +zwidth,r,h,100.,,,Zoom graph width in user units + +ftype,s,h,"absorption","emission|absorption|gemission|gabsorption",,Feature type +fwidth,r,h,4.,,,Feature width in pixels +cradius,r,h,5.,,,Centering radius in pixels +threshold,r,h,0.,0.,,Feature threshold for centering +minsep,r,h,2.,0.,,Minimum pixel separation + +logfile,s,h,"logfile",,,Log file +autowrite,b,h,no,,,"Automatically write to logfile and database" +keywpars,pset,h,"",,,Header keyword translation pset +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input diff --git a/noao/rv/rvidlines/Revisions b/noao/rv/rvidlines/Revisions new file mode 100644 index 00000000..9f93511a --- /dev/null +++ b/noao/rv/rvidlines/Revisions @@ -0,0 +1,52 @@ +idinit.x +reidentify.x + Changed aclrr to aclri and updated the 'b' key in reidentify.x. + (12/1/93, Valdes) + +idlog.x + Added the spectrum title and heliocentric Julian date to the log output. + (11/17/93, Valdes) + +iddblend.x + + Needed copy of ONEDSPEC deblend with names changes to protect the + innocent and avoid conflict with the version in RV. (8/25/93, Valdes) + +t_identify.x +t_reidentify.x +idcenter.x +idcolon.x +iddb.x +iddofit.x +iddoshift.x +idgdata.x +idgraph.x +ididentify.x +idinit.x +idlinelist.x +idlog.x +idmark.x +idrms.x +idshift.x +idshow.x +idvelocity.x + +idvhelio.x +peaks.gx +reidentify.x +mkpkg +identify.h +identify.par +reidentify.par +rvidlines.par + +rvreidlines.par + +identify.key +rvidlines.key + +doc/rvidlines.hlp + +doc/rvreidlines.hlp + + 1. A new cursor key was added for marking and deblending features. + 2. Two new feature types (ftype) were added: + gabsorption Absorption features fit by gaussian + gemission Emission features fit by gaussian + 3. The 'u' key was modified to allow setting a feature weight + 4. Two new tasks were added RVIDLINES and RVREIDLINES. These + are implemented as special entry points and a task flag. + (8/23/93, Valdes) diff --git a/noao/rv/rvidlines/idcenter.x b/noao/rv/rvidlines/idcenter.x new file mode 100644 index 00000000..05c636cb --- /dev/null +++ b/noao/rv/rvidlines/idcenter.x @@ -0,0 +1,257 @@ +include <gset.h> +include <smw.h> +include "identify.h" + +# ID_CENTER -- Locate the center of a feature. + +double procedure id_center (id, x, n, width, type, interactive) + +pointer id # ID pointer +double x[n] # Initial guess +int n # Number of features +real width # Feature width +int type # Feature type +int interactive # Interactive? + +int np1 +real value + +real center1d() +double smw_c1trand() + +begin + switch (type) { + case EMISSION, ABSORPTION: + np1 = NP1(ID_SH(id)) - 1 + value = smw_c1trand (ID_PL(id), x[1]) - np1 + value = center1d (value, IMDATA(id,1), ID_NPTS(id), + width, type, ID_CRADIUS(id), ID_THRESHOLD(id)) + if (IS_INDEF(value)) + return (INDEFD) + else + return (smw_c1trand (ID_LP(id), double(value+np1))) + case GEMISSION, GABSORPTION: + iferr (call id_gcenter (id, x, n, INDEF, INDEF, INDEF, INDEF, + width, type, interactive)) + return (INDEFD) + return (x[1]) + } +end + + +# ID_GCENTER -- Locate the center of a feature. + +procedure id_gcenter (id, x, ng, xa, ya, xb, yb, width, type, interactive) + +pointer id # ID pointer +double x[ng] # Initial guess +int ng # Number of features +real xa, ya, xb, yb # Background points +real width # Feature width +int type # Feature type +int interactive # Draw gaussian fit? + +int i, np1, x1, x2 +real ag, bg, pix, w, y +pointer sp, xr, xg, yg, sg, gp + +bool fp_equalr() +real id_model() +double smw_c1trand(), id_fitpt() + +errchk gcenter1d + +begin + call smark (sp) + call salloc (xr, ng, TY_REAL) + call salloc (xg, ng, TY_REAL) + call salloc (yg, ng, TY_REAL) + call salloc (sg, ng, TY_REAL) + + np1 = NP1(ID_SH(id)) - 1 + + # Compute background in logical units. + if (IS_INDEF(xa) || IS_INDEF(ya) || IS_INDEF(xb) || IS_INDEF(yb)) { + ag = INDEF + bg = INDEF + } else { + ag = smw_c1trand (ID_PL(id), double(xa)) - np1 + bg = smw_c1trand (ID_PL(id), double(xb)) - np1 + if (!fp_equalr (ag, bg)) { + bg = (yb - ya) / (bg - ag) + ag = ya - bg * ag + } else { + ag = INDEF + bg = INDEF + } + } + + do i = 1, ng + Memr[xr+i-1] = smw_c1trand (ID_PL(id), x[i]) - np1 + call gcenter1d (Memr[xr], ng, IMDATA(id,1), ID_NPTS(id), + width, type, ID_CRADIUS(id), ID_THRESHOLD(id), + x1, x2, Memr[xg], Memr[yg], Memr[sg], ag, bg) + do i = 1, ng + x[i] = smw_c1trand (ID_LP(id), double(Memr[xg+i-1]+np1)) + + if (interactive == YES) { + gp = ID_GP(id) + call gseti (gp, G_PLTYPE, 2) + call gseti (gp, G_PLCOLOR, 2) + pix = x1 + w = id_fitpt (id, smw_c1trand (ID_LP(id), double (pix+np1))) + y = id_model (pix, Memr[xg], Memr[yg], Memr[sg], ng) + ag + + bg * pix + call gamove (gp, w, y) + for (pix = x1; pix <= x2; pix = pix + .1) { + w = id_fitpt (id, smw_c1trand (ID_LP(id), double (pix+np1))) + y = id_model (pix, Memr[xg], Memr[yg], Memr[sg], ng) + + ag + bg * pix + call gadraw (gp, w, y) + } + call gseti (gp, G_PLTYPE, 3) + call gseti (gp, G_PLCOLOR, 3) + pix = x1 + w = id_fitpt (id, smw_c1trand (ID_LP(id), double (pix+np1))) + y = ag + bg * pix + call gamove (gp, w, y) + pix = x2 + w = id_fitpt (id, smw_c1trand (ID_LP(id), double (pix+np1))) + y = ag + bg * pix + call gadraw (gp, w, y) + call gseti (gp, G_PLTYPE, 1) + call gseti (gp, G_PLCOLOR, 1) + call gflush (gp) + } + + call sfree (sp) +end + + +define MIN_WIDTH 3. # Minimum centering width + + +# GCENTER1D -- Locate the center of a one dimensional feature by guassian fit. +# A value of INDEF is returned in the centering fails for any reason. +# This procedure just sets up the data and adjusts for emission or +# absorption features. The actual centering is done by GFIT. +# If width <= 1 return the nearest minima or maxima. + +procedure gcenter1d (x, ng, data, npts, width, type, radius, threshold, + x1, x2, xg, yg, sg, ag, bg) + +real x[ng] # Initial guess +int ng # Number of gaussians +real data[npts] # Data points +int npts # Number of data points +real width # Feature width +int type # Feature type +real radius # Centering radius +real threshold # Minimum range in feature +int x1, x2 # Fitting region +real xg[ng], yg[ng], sg[ng], ag, bg # Gaussian parameters + +int i, nx, xa, xb +real a, b, c, d, rad, wid, ya, yb, chisq +pointer xfit + +errchk id_mr_dofit + +begin + # Check starting values. + do i = 1, ng + if (IS_INDEF(x[i]) || (x[i] < 1) || (x[i] > npts)) + call error (1, "Invalid starting values") + + # Set minimum width and error radius. The minimum in the error radius + # is for defining the data window. The user error radius is used to + # check for an error in the derived center at the end of the centering. + + wid = max (width, MIN_WIDTH) + rad = max (2., radius) + + # Determine the pixel value range around the initial center, including + # the width and error radius buffer. Check for a minimum range. + + call alimr (x, ng, c, d) + x1 = max (1., c - wid / 2 - rad - wid) + x2 = min (real (npts), d + wid / 2 + rad + wid + 1) + nx = x2 - x1 + 1 + call alimr (data[x1], nx, a, b) + if (b - a < threshold) + call error (1, "Data range below threshold") + + # Allocate memory for the continuum subtracted data vector. The X + # range is just large enough to include the error radius and the + # half width. + + x1 = max (1., c - wid / 2 - rad) + x2 = min (real (npts), d + wid / 2 + rad + 1) + nx = x2 - x1 + 1 + + # Make the centering data positive, subtract the continuum, and + # apply a threshold to eliminate noise spikes. + + xa = nint(c) + ya = data[xa] + xb = nint(d) + yb = data[xb] + switch (type) { + case GEMISSION: + for (i = xa; i >= x1; i=i-1) + if (data[i] < ya) { + xa = i + ya = data[i] + } + for (i = xb; i <= x2; i=i+1) + if (data[i] < yb) { + xb = i + yb = data[i] + } + case GABSORPTION: + for (i = xa; i >= x1; i=i-1) + if (data[i] > ya) { + xa = i + ya = data[i] + } + for (i = xb; i <= x2; i=i+1) + if (data[i] > yb) { + xb = i + yb = data[i] + } + default: + call error (0, "Unknown feature type") + } + + # Set initial gaussian parameters. + if (IS_INDEF(ag) || IS_INDEF(bg)) { + if (xa == xb) + call error (1, "Can't determine background") + bg = (yb-ya) / (xb-xa) + ag = ya - bg * xa + } + do i = 1, ng { + xg[i] = x[i] + yg[i] = data[nint(x[i])] - ag - bg * x[i] + sg[i] = width / 6. + } + + # Determine the center. + call malloc (xfit, nx, TY_REAL) + do i = x1, x2 + Memr[xfit+i-x1] = i + + call id_mr_dofit (0, 3, 3, Memr[xfit], data[x1], nx, + ag, bg, xg, yg, sg, ng, chisq) + + # Check user centering error radius. + do i = 1, ng { + if (!IS_INDEF(xg[i])) { + if (abs (x[i] - xg[i]) > radius) + call error (2, "Error radius exceeded") + } + } + + # Free memory and return the center position. + call mfree (xfit, TY_REAL) +end diff --git a/noao/rv/rvidlines/idcolon.x b/noao/rv/rvidlines/idcolon.x new file mode 100644 index 00000000..c976c66b --- /dev/null +++ b/noao/rv/rvidlines/idcolon.x @@ -0,0 +1,288 @@ +include <gset.h> +include <error.h> +include <smw.h> +include "identify.h" + +# List of colon commands. +define CMDS "|show|features|image|nsum|database|read|write|add|coordlist|match\ + |maxfeatures|minsep|zwidth|labels|fwidth|ftype|cradius|threshold|" + +define SHOW 1 # Show parameters +define FEATURES 2 # Show list of features +define IMAGE 3 # Set new image +define NSUM 4 # Set the number of lines or columns to sum +define DATABASE 5 # Set new database +define READ 6 # Read database entry +define WRITE 7 # Write database entry +define ADD 8 # Add features from database +define COORDLIST 9 # Set new coordinate list +define MATCH 10 # Set coordinate list matching distance +define MAXFEATURES 11 # Set maximum number of features for auto find +define MINSEP 12 # Set minimum separation distance +define ZWIDTH 13 # Set zoom window width +define LABEL 14 # Set label type +define WIDTH 15 # Set centering width +define TYPE 16 # Set centering type +define RADIUS 17 # Set centering radius +define THRESHOLD 18 # Set the centering threshold + +# ID_COLON -- Respond to colon command. + +procedure id_colon (id, cmdstr, newimage, prfeature) + +pointer id # ID pointer +char cmdstr[ARB] # Colon command +char newimage[ARB] # New image name +int prfeature # Print current feature on status line + +char cmd[SZ_LINE] +int i, ncmd, ival[2] +real rval[2] +pointer im + +int nscan(), strdic() +pointer immap() +errchk immap, id_dbread, id_dbwrite, id_log + +begin + # Scan the command string and get the first word. + call sscan (cmdstr) + call gargwrd (cmd, SZ_LINE) + ncmd = strdic (cmd, cmd, SZ_LINE, CMDS) + + switch (ncmd) { + case SHOW: # :show - show values of parameters + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + call gdeactivate (ID_GP(id), AW_CLEAR) + call id_show (id, "STDOUT") + call greactivate (ID_GP(id), AW_PAUSE) + } else { + iferr (call id_show (id, cmd)) { + call erract (EA_WARN) + prfeature = NO + } + } + case FEATURES: # :features - list features + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + call gdeactivate (ID_GP(id), AW_CLEAR) + call id_log (id, "STDOUT", NULL) + call greactivate (ID_GP(id), AW_PAUSE) + } else { + iferr (call id_log (id, cmd, NULL)) { + call erract (EA_WARN) + prfeature = NO + } + } + case IMAGE: # :image - set image to identify + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + call printf ("image %s\n") + call pargstr (Memc[ID_IMAGE(id)]) + prfeature = NO + } else { + call strcpy (cmd, newimage, SZ_FNAME) + iferr { + im = immap (newimage, READ_ONLY, 0) + call imunmap (im) + } then { + newimage[1] = EOS + call erract (EA_WARN) + prfeature = NO + } + } + case NSUM: # :nsum - set number of lines or columns to sum in image + call gargi (ival[1]) + if (nscan() == 1) { + call printf ("nsum %d %d\n") + call pargi (ID_NSUM(id,1)) + call pargi (ID_NSUM(id,2)) + prfeature = NO + } else { + ID_NSUM(id,1) = ival[1] + call gargi (ival[2]) + if (nscan() == 3) + ID_NSUM(id,2) = ival[2] + call smw_daxis (NULL, NULL, SMW_PAXIS(MW(ID_SH(id)),1), + ID_NSUM(id,1), ID_NSUM(id,2)) + } + case DATABASE: # :database - set database + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + call printf ("database %s\n") + call pargstr (Memc[ID_DATABASE(id)]) + prfeature = NO + } else { + call strcpy (cmd, Memc[ID_DATABASE(id)], SZ_FNAME) + ID_NEWDBENTRY(id) = YES + } + case READ: # :read - read database entry + prfeature = NO + iferr { + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + NO, YES) + else { + call gargi (ival[1]) + if (nscan() < 3) + ival[1] = ID_AP(id,1) + call gargi (ival[2]) + if (nscan() < 4) + ival[2] = ID_AP(id,2) + call id_dbread (id, cmd, ival, NO, YES) + } + } then + call erract (EA_WARN) + case WRITE: # :write - write database entry + prfeature = NO + iferr { + ival[1] = ID_AP(id,1) + ival[2] = ID_AP(id,2) + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) + call id_dbwrite (id, Memc[ID_IMAGE(id)], ival, YES) + else { + call gargi (ival[1]) + if (nscan() < 3) + ival[1] = ID_AP(id,1) + call gargi (ival[2]) + if (nscan() < 4) + ival[2] = ID_AP(id,2) + call id_dbwrite (id, cmd, ival, YES) + } + } then + call erract (EA_WARN) + case ADD: # :add - add features from database entry + prfeature = NO + iferr { + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + YES, YES) + else { + call gargi (ival[1]) + if (nscan() < 3) + ival[1] = ID_AP(id,1) + call gargi (ival[2]) + if (nscan() < 4) + ival[2] = ID_AP(id,2) + call id_dbread (id, cmd, ival, YES, YES) + } + } then + call erract (EA_WARN) + case COORDLIST: # :coordlist - set coordinate list + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + call printf ("coordlist %s\n") + call pargstr (Memc[ID_COORDLIST(id)]) + prfeature = NO + } else { + call strcpy (cmd, Memc[ID_COORDLIST(id)], SZ_FNAME) + call id_unmapll (id) + call id_mapll (id) + } + case MATCH: # :match - set matching distance for coordinate list + call gargr (rval[1]) + if (nscan() == 1) { + call printf ("match %g\n") + call pargr (ID_MATCH(id)) + prfeature = NO + } else + ID_MATCH(id) = rval[1] + case MAXFEATURES: # :maxfeatures - set max num features for auto find + call gargi (ival[1]) + if (nscan() == 1) { + call printf ("maxfeatures %d\n") + call pargi (ID_MAXFEATURES(id)) + prfeature = NO + } else + ID_MAXFEATURES(id) = ival[1] + case MINSEP: # :minsep - set minimum feature separation allowed + call gargr (rval[1]) + if (nscan() == 1) { + call printf ("minsep %g\n") + call pargr (ID_MINSEP(id)) + prfeature = NO + } else + ID_MINSEP(id) = rval[1] + case ZWIDTH: # :zwidth - set zoom window width + call gargr (rval[1]) + if (nscan() == 1) { + call printf ("zwidth %g\n") + call pargr (ID_ZWIDTH(id)) + prfeature = NO + } else { + ID_ZWIDTH(id) = rval[1] + if (ID_GTYPE(id) == 2) + ID_NEWGRAPH(id) = YES + } + case LABEL: # :labels - set label type + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + switch (ID_LABELS(id)) { + case 2: + call printf ("labels index\n") + case 3: + call printf ("labels pixel\n") + case 4: + call printf ("labels coords\n") + case 5: + call printf ("labels user\n") + case 6: + call printf ("labels both\n") + default: + call printf ("labels none\n") + } + prfeature = NO + } else { + ID_LABELS(id) = strdic (cmd, cmd, SZ_LINE, LABELS) + do i = 1, ID_NFEATURES(id) + call id_mark (id, i) + } + case WIDTH: # :fwidth - set centering width + call gargr (rval[1]) + if (nscan() == 1) { + call printf ("fwidth %g\n") + call pargr (ID_FWIDTH(id)) + prfeature = NO + } else + ID_FWIDTH(id) = rval[1] + case TYPE: # :ftype - set centering type + call gargwrd (cmd, SZ_LINE) + if (nscan() == 1) { + switch (ID_FTYPE(id)) { + case EMISSION: + call printf ("ftype emission\n") + case ABSORPTION: + call printf ("ftype absorption\n") + case GEMISSION: + call printf ("ftype gemission\n") + case GABSORPTION: + call printf ("ftype gabsorption\n") + } + prfeature = NO + } else + ID_FTYPE(id) = strdic (cmd, cmd, SZ_LINE, FTYPES) + case RADIUS: # :cradius - set centering radius + call gargr (rval[1]) + if (nscan() == 1) { + call printf ("cradius %g\n") + call pargr (ID_CRADIUS(id)) + prfeature = NO + } else + ID_CRADIUS(id) = rval[1] + case THRESHOLD: # :threshold - set centering threshold + call gargr (rval[1]) + if (nscan() == 1) { + call printf ("threshold %g\n") + call pargr (ID_THRESHOLD(id)) + prfeature = NO + } else + ID_THRESHOLD(id) = rval[1] + default: + call printf ("Unrecognized or ambiguous command\007") + prfeature = NO + } +end diff --git a/noao/rv/rvidlines/iddb.x b/noao/rv/rvidlines/iddb.x new file mode 100644 index 00000000..90bafea9 --- /dev/null +++ b/noao/rv/rvidlines/iddb.x @@ -0,0 +1,436 @@ +include <imset.h> +include <math/curfit.h> +include <smw.h> +include "identify.h" + +# ID_DBREAD -- Read features data from the database. + +procedure id_dbread (id, name, ap, add, verbose) + +pointer id # ID pointer +char name[SZ_LINE] # Image name +int ap[2] # Aperture number +int add # Add features? +int verbose # Verbose flag + +double pix +int i, j, k, ncoeffs, rec +pointer dt, sp, coeffs, line, str, sh + +int dtgeti(), dcvstati(), dtlocate(), dtscan(), nscan() +real dtgetr() +double dcvstatd() + +errchk dtremap(), dtlocate(), dtgeti(), dtgad() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + + call strcpy ("id", Memc[line], SZ_LINE) + call imgcluster (name, Memc[line+2], SZ_LINE) + call dtremap (ID_DT(id), Memc[ID_DATABASE(id)], Memc[line], READ_ONLY) + + call id_dbsection (id, name, ap, Memc[ID_SECTION(id)], SZ_FNAME) + call sprintf (Memc[line], SZ_LINE, "identify %s%s") + call pargstr (name) + call pargstr (Memc[ID_SECTION(id)]) + + dt = ID_DT(id) + sh = ID_SH(id) + iferr (rec = dtlocate (dt, Memc[line])) { + call salloc (str, SZ_LINE, TY_CHAR) + call sprintf (Memc[str], SZ_LINE, "Entry not found: %s") + call pargstr (Memc[line]) + call error (0, Memc[str]) + } + + if (add == YES) { + j = dtgeti (dt, rec, "features") + k = j + ID_NFEATURES(id) + + call realloc (ID_PIX(id), k, TY_DOUBLE) + call realloc (ID_FIT(id), k, TY_DOUBLE) + call realloc (ID_USER(id), k, TY_DOUBLE) + call realloc (ID_WTS(id), k, TY_DOUBLE) + call realloc (ID_FWIDTHS(id), k, TY_REAL) + call realloc (ID_FTYPES(id), k, TY_INT) + call realloc (ID_LABEL(id), k, TY_POINTER) + + do i = 1, j { + k = dtscan (dt) + call gargd (pix) + + ID_NFEATURES(id) = ID_NFEATURES(id) + 1 + for (k=ID_NFEATURES(id); (k>1)&&(pix<PIX(id,k-1)); k=k-1) { + PIX(id,k) = PIX(id,k-1) + FIT(id,k) = FIT(id,k-1) + USER(id,k) = USER(id,k-1) + WTS(id,k) = WTS(id,k-1) + FWIDTH(id,k) = FWIDTH(id,k-1) + FTYPE(id,k) = FTYPE(id,k-1) + Memi[ID_LABEL(id)+k-1] = Memi[ID_LABEL(id)+k-2] + } + PIX(id,k) = pix + call gargd (FIT(id,k)) + call gargd (USER(id,k)) + call gargr (FWIDTH(id,k)) + call gargi (FTYPE(id,k)) + call gargd (WTS(id,k)) + call gargstr (Memc[line], SZ_LINE) + Memi[ID_LABEL(id)+k-1] = NULL + call id_label (Memc[line], Memi[ID_LABEL(id)+k-1]) + + # The following initialization is for backwards compatibility. + if (nscan() < 5) { + FWIDTH(id,k) = ID_FWIDTH(id) + FTYPE(id,k) = ID_FTYPE(id) + } else if (nscan() < 6) + WTS(id,k) = 1. + } + + } else { + if (SMW_FORMAT(MW(sh)) == SMW_ES || SMW_FORMAT(MW(sh)) == SMW_MS) { + iferr (APLOW(sh,1) = dtgetr (dt, rec, "aplow")) + APLOW(sh,1) = INDEF + iferr (APHIGH(sh,1) = dtgetr (dt, rec, "aphigh")) + APHIGH(sh,1) = INDEF + } + + do i = 1, ID_NFEATURES(id) + call mfree (Memi[ID_LABEL(id)+i-1], TY_CHAR) + + k = dtgeti (dt, rec, "features") + ID_NFEATURES(id) = k + ID_NALLOC(id) = k + call realloc (ID_PIX(id), k, TY_DOUBLE) + call realloc (ID_FIT(id), k, TY_DOUBLE) + call realloc (ID_USER(id), k, TY_DOUBLE) + call realloc (ID_WTS(id), k, TY_DOUBLE) + call realloc (ID_FWIDTHS(id), k, TY_REAL) + call realloc (ID_FTYPES(id), k, TY_INT) + call realloc (ID_LABEL(id), k, TY_POINTER) + + do i = 1, ID_NFEATURES(id) { + k = dtscan (dt) + call gargd (PIX(id,i)) + call gargd (FIT(id,i)) + call gargd (USER(id,i)) + call gargr (FWIDTH(id,i)) + call gargi (FTYPE(id,i)) + call gargd (WTS(id,i)) + call gargstr (Memc[line], SZ_LINE) + Memi[ID_LABEL(id)+i-1] = NULL + call id_label (Memc[line], Memi[ID_LABEL(id)+i-1]) + + # The following initialization is for backwards compatibility. + if (nscan() < 5) { + FWIDTH(id,i) = ID_FWIDTH(id) + FTYPE(id,i) = ID_FTYPE(id) + } else if (nscan() < 6) + WTS(id,i) = 1. + } + + iferr (ID_SHIFT(id) = dtgetr (dt, rec, "shift")) + ID_SHIFT(id) = 0. + iferr (ID_REDSHIFT(id) = dtgetr (dt, rec, "redshift")) + ID_REDSHIFT(id) = 0. + iferr (ID_RMSRED(id) = dtgetr (dt, rec, "redshift_rms")) + ID_RMSRED(id) = 0. + + iferr { + ncoeffs = dtgeti (dt, rec, "coefficients") + call salloc (coeffs, ncoeffs, TY_DOUBLE) + call dtgad (dt, rec, "coefficients", Memd[coeffs], ncoeffs, + ncoeffs) + + if (ID_CV(id) != NULL) + call dcvfree (ID_CV(id)) + call dcvrestore (ID_CV(id), Memd[coeffs]) + + call ic_putr (ID_IC(id), "xmin", real (dcvstatd(ID_CV(id), + CVXMIN))) + call ic_putr (ID_IC(id), "xmax", real (dcvstatd(ID_CV(id), + CVXMAX))) + ifnoerr (call dtgstr (dt,rec,"function",Memc[line],SZ_LINE)) { + call ic_pstr (ID_IC(id), "function", Memc[line]) + call ic_puti (ID_IC(id), "order", dtgeti (dt, rec, "order")) + call dtgstr (dt, rec, "sample", Memc[line], SZ_LINE) + call ic_pstr (ID_IC(id), "sample", Memc[line]) + call ic_puti (ID_IC(id), "naverage", + dtgeti (dt, rec, "naverage")) + call ic_puti (ID_IC(id), "niterate", + dtgeti (dt, rec, "niterate")) + call ic_putr (ID_IC(id), "low", + dtgetr (dt, rec, "low_reject")) + call ic_putr (ID_IC(id), "high", + dtgetr (dt, rec, "high_reject")) + call ic_putr (ID_IC(id), "grow", dtgetr (dt, rec, "grow")) + } else { + call ic_puti (ID_IC(id), "order", dcvstati (ID_CV(id), + CVORDER)) + switch (dcvstati (ID_CV(id), CVTYPE)) { + case LEGENDRE: + call ic_pstr (ID_IC(id), "function", "legendre") + case CHEBYSHEV: + call ic_pstr (ID_IC(id), "function", "chebyshev") + case SPLINE1: + call ic_pstr (ID_IC(id), "function", "spline1") + case SPLINE3: + call ic_pstr (ID_IC(id), "function", "spline3") + } + } + + ID_NEWCV(id) = YES + ID_CURRENT(id) = min (1, ID_NFEATURES(id)) + } then + ; + } + + call sfree (sp) + + if (ID_NFEATURES(id) > 0) { + ID_NEWGRAPH(id) = YES + ID_NEWFEATURES(id) = YES + ID_CURRENT(id) = 1 + } else + ID_CURRENT(id) = 0 + + if (verbose == YES) { + call printf ("identify %s%s\n") + call pargstr (name) + call pargstr (Memc[ID_SECTION(id)]) + } +end + + +# ID_DBWRITE -- Write features data to the database. + +procedure id_dbwrite (id, name, ap, verbose) + +pointer id # ID pointer +char name[ARB] # Image name +int ap[2] # Aperture number +int verbose # Verbose flag + +int i, ncoeffs +pointer dt, sp, coeffs, root, sh, im + +int dcvstati(), ic_geti() +real ic_getr() + +errchk dtremap + +begin + call smark (sp) + call salloc (root, SZ_FNAME, TY_CHAR) + + call strcpy ("id", Memc[root], SZ_FNAME) + call imgcluster (name, Memc[root+2], SZ_FNAME) + call dtremap (ID_DT(id), Memc[ID_DATABASE(id)], Memc[root], APPEND) + + call id_dbsection (id, name, ap, Memc[ID_SECTION(id)], SZ_FNAME) + + sh = ID_SH(id) + dt = ID_DT(id) + call dtptime (dt) + call dtput (dt, "begin\tidentify %s%s\n") + call pargstr (name) + call pargstr (Memc[ID_SECTION(id)]) + call dtput (dt, "\tid\t%s\n") + call pargstr (name) + call dtput (dt, "\ttask\tidentify\n") + call dtput (dt, "\timage\t%s%s\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + if (SMW_FORMAT(MW(sh)) == SMW_ES || SMW_FORMAT(MW(sh)) == SMW_MS) { + call dtput (dt, "\taperture\t%d\n") + call pargi (ID_AP(id,1)) + call dtput (dt, "\taplow\t%g\n") + call pargr (APLOW(sh,1)) + call dtput (dt, "\taphigh\t%g\n") + call pargr (APHIGH(sh,1)) + } + + call dtput (dt, "\tfeatures\t%d\n") + call pargi (ID_NFEATURES(id)) + do i = 1, ID_NFEATURES(id) { + call dtput (dt, "\t %10.2f %10.8g %10.8g %5.1f %d %d %s\n") + call pargd (PIX(id,i)) + call pargd (FIT(id,i)) + call pargd (USER(id,i)) + call pargr (FWIDTH(id,i)) + call pargi (FTYPE(id,i)) + call pargd (WTS(id,i)) + if (Memi[ID_LABEL(id)+i-1] != NULL) + call pargstr (Memc[Memi[ID_LABEL(id)+i-1]]) + else + call pargstr ("") + } + + if (ID_SHIFT(id) != 0.) { + call dtput (dt, "\tshift\t%g\n") + call pargd (ID_SHIFT(id)) + } + if (ID_REDSHIFT(id) != 0.) { + call dtput (dt, "\tredshift\t%g\n") + call pargd (ID_REDSHIFT(id)) + call dtput (dt, "\tredshift_rms\t%g\n") + call pargd (ID_RMSRED(id)) + } + + if (ID_CV(id) != NULL) { + call dtput (dt, "\tfunction %s\n") + call ic_gstr (ID_IC(id), "function", Memc[root], SZ_FNAME) + call pargstr (Memc[root]) + call dtput (dt, "\torder %d\n") + call pargi (ic_geti (ID_IC(id), "order")) + call dtput (dt, "\tsample %s\n") + call ic_gstr (ID_IC(id), "sample", Memc[root], SZ_FNAME) + call pargstr (Memc[root]) + call dtput (dt, "\tnaverage %d\n") + call pargi (ic_geti (ID_IC(id), "naverage")) + call dtput (dt, "\tniterate %d\n") + call pargi (ic_geti (ID_IC(id), "niterate")) + call dtput (dt, "\tlow_reject %g\n") + call pargr (ic_getr (ID_IC(id), "low")) + call dtput (dt, "\thigh_reject %g\n") + call pargr (ic_getr (ID_IC(id), "high")) + call dtput (dt, "\tgrow %g\n") + call pargr (ic_getr (ID_IC(id), "grow")) + + ncoeffs = dcvstati (ID_CV(id), CVNSAVE) + call salloc (coeffs, ncoeffs, TY_DOUBLE) + call dcvsave (ID_CV(id), Memd[coeffs]) + call dtput (dt, "\tcoefficients\t%d\n") + call pargi (ncoeffs) + do i = 1, ncoeffs { + call dtput (dt, "\t\t%g\n") + call pargd (Memd[coeffs+i-1]) + } + } + + call dtput (dt, "\n") + + ID_NEWFEATURES(id) = NO + ID_NEWCV(id) = NO + ID_NEWDBENTRY(id) = NO + + if (ID_TASK(id) == IDENTIFY) { + if (verbose == YES) { + call printf ("identify %s%s\n") + call pargstr (name) + call pargstr (Memc[ID_SECTION(id)]) + } + + # Enter reference spectrum name in image header. + im = IM(sh) + call imseti (im, IM_WHEADER, YES) + call imastr (im, "REFSPEC1", Memc[ID_IMAGE(id)]) + iferr (call imdelf (im, "REFSPEC2")) + ; + } + + call sfree (sp) +end + + +# ID_DBCHECK -- Check if there is an entry in the database. +# This does not actually read the database entry. It also assumes that +# if a database is already open it is for the same image (the image +# names are not checked) and the database has been scanned. + +int procedure id_dbcheck (id, name, ap) + +pointer id # ID pointer +char name[SZ_LINE] # Image name +int ap[2] # Aperture number + +int rec, stat +pointer sp, line, sec + +int dtlocate() + +errchk dtremap(), dtlocate() + +begin + call smark (sp) + call salloc (line, SZ_LINE, TY_CHAR) + call salloc (sec, SZ_LINE, TY_CHAR) + + if (ID_DT(id) == NULL) { + call strcpy ("id", Memc[line], SZ_LINE) + call imgcluster (name, Memc[line+2], SZ_LINE) + iferr (call dtremap (ID_DT(id), Memc[ID_DATABASE(id)], Memc[line], + READ_ONLY)) { + call sfree (sp) + return (NO) + } + } + + call id_dbsection (id, name, ap, Memc[sec], SZ_LINE) + call sprintf (Memc[line], SZ_LINE, "identify %s%s") + call pargstr (name) + call pargstr (Memc[sec]) + + iferr (rec = dtlocate (ID_DT(id), Memc[line])) + stat = NO + else + stat = YES + + call sfree (sp) + return (stat) +end + + +# ID_DBSECTION -- Make the IDENTIFY section. + +procedure id_dbsection (id, name, ap, section, sz_section) + +pointer id #I ID pointer +char name[SZ_LINE] #I Image name +int ap[2] #I Aperture number +char section[sz_section] #O IDENTIFY section +int sz_section #I Size of section string + +pointer sh, smw +bool streq() + +begin + sh = ID_SH(id) + smw = MW(sh) + + switch (SMW_FORMAT(smw)) { + case SMW_ND: + section[1] = EOS + if (streq (name, Memc[ID_IMAGE(id)])) { + switch (SMW_LDIM(smw)) { + case 2: + switch (SMW_LAXIS(smw,1)) { + case 1: + call sprintf (section, sz_section, "[*,%d]") + case 2: + call sprintf (section, sz_section, "[%d,*]") + } + #call pargi (LINDEX(sh,1)) + call pargi (ap[1]) + case 3: + switch (SMW_LAXIS(smw,1)) { + case 1: + call sprintf (section, sz_section, "[*,%d,%d]") + case 2: + call sprintf (section, sz_section, "[%d,*,%d]") + case 3: + call sprintf (section, sz_section, "[%d,%d,*]") + } + #call pargi (LINDEX(sh,1)) + #call pargi (LINDEX(sh,2)) + call pargi (ap[1]) + call pargi (ap[2]) + } + } + case SMW_ES, SMW_MS: + call sprintf (section, sz_section, " - Ap %d") + call pargi (ap[1]) + } +end diff --git a/noao/rv/rvidlines/iddeblend.x b/noao/rv/rvidlines/iddeblend.x new file mode 100644 index 00000000..75e32a78 --- /dev/null +++ b/noao/rv/rvidlines/iddeblend.x @@ -0,0 +1,413 @@ +include <mach.h> + + +# ID_MR_DOFIT -- Fit gaussian components. This is an interface to ID_DOFIT1 +# which puts parameters into the form required by ID_DOFIT1 and vice-versa. +# It also implements a constrained approach to the solution. + +procedure id_mr_dofit (bkgfit, posfit, sigfit, x, y, npts, y1, dy, xg, yg, sg, + ng, chisq) + +int bkgfit # Fit background (0=no, 1=yes) +int posfit # Position fitting flag (1=fixed, 2=single, 3=all) +int sigfit # Sigma fitting flag (1=fixed, 2=single, 3=all) +real x[npts] # X data +real y[npts] # Y data +int npts # Number of points +real y1 # Continuum offset +real dy # Continuum slope +real xg[ng] # Initial and final x coordinates of gaussians +real yg[ng] # Initial and final y coordinates of gaussians +real sg[ng] # Initial and final sigmas of gaussians +int ng # Number of gaussians +real chisq # Chi squared + +int i +pointer sp, a, j +errchk id_dofit1 + +begin + call smark (sp) + call salloc (a, 4 + 3 * ng, TY_REAL) + + # Convert positions and widths relative to first component. + Memr[a] = y1 + Memr[a+1] = dy + Memr[a+2] = xg[1] + Memr[a+3] = sg[1] + do i = 1, ng { + j = a + 3 * i + 1 + Memr[j] = yg[i] + Memr[j+1] = xg[i] - Memr[a+2] + Memr[j+2] = sg[i] / Memr[a+3] + } + + # Do fit. + do i = 0, bkgfit { + switch (10*posfit+sigfit) { + case 11: + call id_dofit1 (i, 1, 1, x, y, npts, Memr[a], ng, chisq) + case 12: + call id_dofit1 (i, 1, 2, x, y, npts, Memr[a], ng, chisq) + case 13: + call id_dofit1 (i, 1, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 1, 3, x, y, npts, Memr[a], ng, chisq) + case 21: + call id_dofit1 (i, 2, 1, x, y, npts, Memr[a], ng, chisq) + case 22: + call id_dofit1 (i, 1, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 2, 2, x, y, npts, Memr[a], ng, chisq) + case 23: + call id_dofit1 (i, 1, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 2, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 2, 3, x, y, npts, Memr[a], ng, chisq) + case 31: + call id_dofit1 (i, 2, 1, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 3, 1, x, y, npts, Memr[a], ng, chisq) + case 32: + call id_dofit1 (i, 1, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 2, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 3, 2, x, y, npts, Memr[a], ng, chisq) + case 33: + call id_dofit1 (i, 1, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 2, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 3, 2, x, y, npts, Memr[a], ng, chisq) + call id_dofit1 (i, 3, 3, x, y, npts, Memr[a], ng, chisq) + } + } + + y1 = Memr[a] + dy = Memr[a+1] + do i = 1, ng { + j = a + 3 * i + 1 + yg[i] = Memr[j] + xg[i] = Memr[j+1] + Memr[a+2] + sg[i] = abs (Memr[j+2] * Memr[a+3]) + } + + call sfree (sp) +end + + +# ID_MODEL -- Compute model. +# +# I(x) = I(i) exp {-[(x-xg(i)) / sg(i)]**2 / 2.} +# +# where the params are I1, I2, xg, yg, and sg. + +real procedure id_model (x, xg, yg, sg, ng) + +real x # X value to be evaluated +real xg[ng] # X coordinates of gaussians +real yg[ng] # Y coordinates of gaussians +real sg[ng] # Sigmas of gaussians +int ng # Number of gaussians + +int i +real y, arg + +begin + y = 0. + do i = 1, ng { + arg = (x - xg[i]) / sg[i] + if (abs (arg) < 7.) + y = y + yg[i] * exp (-arg**2 / 2.) + } + return (y) +end + + +# ID_DOFIT1 -- Perform nonlinear iterative fit for the specified parameters. +# This uses the Levenberg-Marquardt method from NUMERICAL RECIPES. + +procedure id_dofit1 (bkgfit, posfit, sigfit, x, y, npts, a, nlines, chisq) + +int bkgfit # Background fit (0=no, 1=yes) +int posfit # Position fitting flag (1=fixed, 2=one, 3=all) +int sigfit # Sigma fitting flag (1=fixed, 2=one, 3=all) +real x[npts] # X data +real y[npts] # Y data +int npts # Number of points +real a[ARB] # Fitting parameters +int nlines # Number of lines +real chisq # Chi squared + +int i, np, nfit +real mr, chi2 +pointer sp, flags, ptr +errchk id_mr_solve + +begin + # Number of terms is 3 for each line plus common background, center + # and sigma. + + np = 3 * nlines + 4 + + call smark (sp) + call salloc (flags, np, TY_INT) + ptr = flags + + # Background. + if (bkgfit == 1) { + Memi[ptr] = 1 + Memi[ptr+1] = 2 + ptr = ptr + 2 + } + + # Peaks are always fit. + do i = 1, nlines { + Memi[ptr] = 3 * i + 2 + ptr = ptr + 1 + } + + # Positions. + switch (posfit) { + case 2: + Memi[ptr] = 3 + ptr = ptr + 1 + case 3: + Memi[ptr] = 3 + ptr = ptr + 1 + do i = 1, nlines { + Memi[ptr] = 3 * i + 3 + ptr = ptr + 1 + } + } + + # Sigmas. + switch (sigfit) { + case 2: + Memi[ptr] = 4 + ptr = ptr + 1 + case 3: + Memi[ptr] = 4 + ptr = ptr + 1 + do i = 1, nlines { + Memi[ptr] = 3 * i + 4 + ptr = ptr + 1 + } + } + + nfit = ptr - flags + mr = -1. + i = 0 + chi2 = MAX_REAL + repeat { + call id_mr_solve (x, y, npts, a, Memi[flags], np, nfit, mr, chisq) + if (chi2 - chisq > 1.) + i = 0 + else + i = i + 1 + chi2 = chisq + } until (i == 3) + + mr = 0. + call id_mr_solve (x, y, npts, a, Memi[flags], np, nfit, mr, chisq) + + call sfree (sp) +end + + +# ID_DERIVS -- Compute model and derivatives for MR_SOLVE procedure. +# +# I(x) = I1 + I2 * x + I(i) exp {-[(x-xc-dx(i)) / (sig * sig(i))]**2 / 2.} +# +# where the params are I1, I2, xc, sig, I(i), dx(i), and sig(i) (i=1,nlines). + +procedure id_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 + +int i +real sig, arg, ex, fac + +begin + y = a[1] + a[2] * x + dyda[1] = 1. + dyda[2] = x + dyda[3] = 0. + dyda[4] = 0. + do i = 5, na, 3 { + sig = a[4] * a[i+2] + arg = (x - a[3] - a[i+1]) / sig + if (abs (arg) < 7.) + ex = exp (-arg**2 / 2.) + else + ex = 0. + fac = a[i] * ex * arg + + y = y + a[i] * ex + dyda[3] = dyda[3] + fac / sig + dyda[4] = dyda[4] + fac * arg / a[4] + dyda[i] = ex + dyda[i+1] = fac / sig + dyda[i+2] = fac * arg / a[i+2] + } +end + + +# ID_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 id_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 id_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 id_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 id_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 id_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 + + +# ID_MR_EVAL -- Evaluate curvature matrix. This calls procedure DERIVS. + +procedure id_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 id_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 id_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 diff --git a/noao/rv/rvidlines/iddelete.x b/noao/rv/rvidlines/iddelete.x new file mode 100644 index 00000000..cd96abb1 --- /dev/null +++ b/noao/rv/rvidlines/iddelete.x @@ -0,0 +1,26 @@ +include "identify.h" + +# ID_DELETE -- Delete a feature. + +procedure id_delete (id, feature) + +pointer id # ID pointer +int feature # Feature to be deleted + +int i + +begin + call mfree (Memi[ID_LABEL(id)+feature-1], TY_CHAR) + do i = feature + 1, ID_NFEATURES(id) { + PIX(id,i-1) = PIX(id,i) + FIT(id,i-1) = FIT(id,i) + USER(id,i-1) = USER(id,i) + WTS(id,i-1) = WTS(id,i) + FWIDTH(id,i-1) = FWIDTH(id,i) + FTYPE(id,i-1) = FTYPE(id,i) + Memi[ID_LABEL(id)+i-2] = Memi[ID_LABEL(id)+i-1] + } + Memi[ID_LABEL(id)+ID_NFEATURES(id)-1] = NULL + ID_NFEATURES(id) = ID_NFEATURES(id) - 1 + ID_NEWFEATURES(id) = YES +end diff --git a/noao/rv/rvidlines/iddofit.x b/noao/rv/rvidlines/iddofit.x new file mode 100644 index 00000000..691e7350 --- /dev/null +++ b/noao/rv/rvidlines/iddofit.x @@ -0,0 +1,101 @@ +include "identify.h" + +# ID_DOFIT -- Fit a function to the features. Eliminate INDEF points. + +procedure id_dofit (id, interactive) + +pointer id # ID pointer +int interactive # Interactive fit? + +int i, j, k, nfit, ic_geti() +pointer gt1, sp, x, y, wts, rejpts, str, gt_init() + +begin + if (ID_NFEATURES(id) == 0) { + if (ID_CV(id) != NULL) { + call dcvfree (ID_CV(id)) + ID_SHIFT(id) = 0. + ID_REDSHIFT(id) = 0. + ID_NEWGRAPH(id) = YES + ID_NEWCV(id) = YES + } + return + } + + call smark (sp) + call salloc (x, ID_NFEATURES(id), TY_DOUBLE) + call salloc (y, ID_NFEATURES(id), TY_DOUBLE) + call salloc (wts, ID_NFEATURES(id), TY_DOUBLE) + + nfit = 0 + do i = 1, ID_NFEATURES(id) { + if (IS_INDEFD (PIX(id,i)) || IS_INDEFD (USER(id,i))) + next + Memd[x+nfit] = PIX(id,i) + Memd[y+nfit] = USER(id,i) + Memd[wts+nfit] = 1. + nfit = nfit + 1 + } + + if (nfit > 1) { + if (interactive == YES) { + call salloc (str, SZ_LINE, TY_CHAR) + gt1 = gt_init() + call icg_fitd (ID_IC(id), ID_GP(id), "cursor", gt1, ID_CV(id), + Memd[x], Memd[y], Memd[wts], nfit) + call gt_free (gt1) + } else + call ic_fitd (ID_IC(id), ID_CV(id), Memd[x], Memd[y], Memd[wts], + nfit, YES, YES, YES, YES) + + if (ic_geti (ID_IC(id), "nreject") > 0 && + ic_geti (ID_IC(id), "nfit") == nfit) + rejpts = ic_geti (ID_IC(id), "rejpts") + else + rejpts = NULL + + j = 0 + k = 0 + do i = 1, ID_NFEATURES(id) { + if (IS_INDEFD (PIX(id,i)) || IS_INDEFD (USER(id,i))) { + j = j + 1 + PIX(id,j) = PIX(id,i) + FIT(id,j) = FIT(id,i) + USER(id,j) = USER(id,i) + WTS(id,j) = WTS(id,i) + FWIDTH(id,j) = FWIDTH(id,i) + FTYPE(id,j) = FTYPE(id,i) + } else { + if (Memd[wts+k] != 0.) { + j = j + 1 + PIX(id,j) = Memd[x+k] + FIT(id,j) = FIT(id,i) + USER(id,j) = Memd[y+k] + WTS(id,j) = Memd[wts+k] + if (rejpts != NULL) + if (Memi[rejpts+k] == YES) + WTS(id,j) = 0. + FWIDTH(id,j) = FWIDTH(id,i) + FTYPE(id,j) = FTYPE(id,i) + } + k = k + 1 + } + } + ID_NFEATURES(id) = j + + ID_SHIFT(id) = 0. + ID_REDSHIFT(id) = 0. + ID_NEWCV(id) = YES + ID_NEWGRAPH(id) = YES + } else { + if (ID_CV(id) != NULL) { + call dcvfree (ID_CV(id)) + ID_SHIFT(id) = 0. + ID_REDSHIFT(id) = 0. + ID_NEWCV(id) = YES + ID_NEWGRAPH(id) = YES + } + } + + call sfree (sp) +end diff --git a/noao/rv/rvidlines/iddoshift.x b/noao/rv/rvidlines/iddoshift.x new file mode 100644 index 00000000..6e397455 --- /dev/null +++ b/noao/rv/rvidlines/iddoshift.x @@ -0,0 +1,42 @@ +include "identify.h" + +# ID_DOSHIFT -- Minimize residuals by constant shift. + +procedure id_doshift (id, interactive) + +pointer id # ID pointer +int interactive # Called interactively? + +int i, j +double shft, delta, rms, id_fitpt() + +begin + shft = 0. + rms = 0. + j = 0 + for (i=1; i <= ID_NFEATURES(id); i = i + 1) { + if (IS_INDEFD (USER(id,i)) || WTS(id,i) == 0.) + next + delta = USER(id,i) - id_fitpt (id, PIX(id,i)) + shft = shft + delta + rms = rms + delta * delta + j = j + 1 + } + + if (j > 0) { + shft = shft / j + rms = rms / j + if (interactive == YES) { + call printf ("%s%s: Coordinate shift=%5f, rms=%5f, npts=%3d\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargd (shft) + call pargd (sqrt (rms - shft ** 2)) + call pargi (j) + } + ID_SHIFT(id) = ID_SHIFT(id) + shft + ID_REDSHIFT(id) = 0. + ID_NEWCV(id) = YES + ID_NEWGRAPH(id) = YES + } +end diff --git a/noao/rv/rvidlines/identify.h b/noao/rv/rvidlines/identify.h new file mode 100644 index 00000000..ad34b767 --- /dev/null +++ b/noao/rv/rvidlines/identify.h @@ -0,0 +1,97 @@ +# Task parameters + +define LEN_IDSTRUCT 64 # Length ID structure + +define ID_TASK Memi[$1] # Task ID +define ID_IMAGE Memi[$1+1] # Image (pointer) +define ID_SECTION Memi[$1+2] # Section for 2D and 3D images (pointer) +define ID_LINE Memi[$1+$2+2] # Image line or column [2] +define ID_MAXLINE Memi[$1+$2+4] # Maximum line or column [2] +define ID_AP Memi[$1+$2+6] # Aperture if appropriate [2] +define ID_APS Memi[$1+9] # Array of apertures (pointer) +define ID_NSUM Memi[$1+$2+10] # Number of lines to sum [2] +define ID_MAXFEATURES Memi[$1+13] # Maximum number of features +define ID_FTYPE Memi[$1+14] # Feature type +define ID_MINSEP Memr[P2R($1+15)] # Minimum pixel separation +define ID_MATCH Memr[P2R($1+16)] # Maximum matching separation +define ID_FWIDTH Memr[P2R($1+17)] # Feature width in pixels +define ID_CRADIUS Memr[P2R($1+18)] # Centering radius in pixels +define ID_THRESHOLD Memr[P2R($1+19)] # Centering threshold +define ID_ZWIDTH Memr[P2R($1+20)] # Zoom window width in fit units +define ID_DATABASE Memi[$1+21] # Name of database (pointer) +define ID_COORDLIST Memi[$1+22] # Name of coordinate list (pointer) +define ID_LL Memi[$1+23] # Pointer to lines in coordinate list +define ID_LABELS Memi[$1+24] # Type of feature labels +define ID_LOGFILES Memi[$1+25] # List of logfiles + +# Common image data + +define ID_SHIFT Memd[P2D($1+26)]# Wavelength shift +define ID_REDSHIFT Memd[P2D($1+28)]# Redshift of spectrum +define ID_RMSRED Memd[P2D($1+30)]# Redshift of spectrum +define ID_ZHELIO Memd[P2D($1+32)]# Heliocentric correction in redshift +define ID_IMDATA Memi[$1+34] # Image data (pointer) +define ID_PIXDATA Memi[$1+35] # Pixel coordinates (pointer) +define ID_FITDATA Memi[$1+36] # Fit coordinates (pointer) +define ID_NPTS Memi[$1+37] # Number of points + +# Features + +define ID_NFEATURES Memi[$1+38] # Number of features +define ID_NALLOC Memi[$1+39] # Length of allocated feature arrays +define ID_PIX Memi[$1+40] # Feature pixel coordinates (pointer) +define ID_FIT Memi[$1+41] # Feature fit coordinates (pointer) +define ID_USER Memi[$1+42] # Feature user coordinates (pointer) +define ID_WTS Memi[$1+43] # Feature weights (pointer) +define ID_FWIDTHS Memi[$1+44] # Feature width (pointer) +define ID_FTYPES Memi[$1+45] # Feature type (pointer) +define ID_LABEL Memi[$1+46] # Feature label (pointer) +define ID_CURRENT Memi[$1+47] # Current feature + +# Pointers for other packages and to save data + +define ID_SH Memi[$1+48] # SHDR pointer +define ID_LP Memi[$1+49] # Logical to physical transformation +define ID_PL Memi[$1+50] # Physical to logical transformation +define ID_IC Memi[$1+51] # ICFIT pointer +define ID_CV Memi[$1+52] # Curfit pointer +define ID_GP Memi[$1+53] # GIO pointer +define ID_GT Memi[$1+54] # Gtools pointer +define ID_ID Memi[$1+55] # Array of structure pointers (pointer) +define ID_NID Memi[$1+56] # Number of saved structure +define ID_DT Memi[$1+57] # Database pointer + +# Flags + +define ID_NEWFEATURES Memi[$1+58] # Has feature list changed? +define ID_NEWCV Memi[$1+59] # Has fitting function changed? +define ID_NEWGRAPH Memi[$1+60] # Has graph changed? +define ID_NEWDBENTRY Memi[$1+61] # Has database entry changed? +define ID_REFIT Memi[$1+62] # Refit feature data? +define ID_GTYPE Memi[$1+63] # Graph type + +# End of structure ---------------------------------------------------------- + +# Task ID +define IDENTIFY 1 # Standard identify +define RVIDLINES 2 # Line radial velocities + +define LABELS "|none|index|pixel|coord|user|both|" +define FTYPES "|emission|absorption|gemission|gabsorption|" +define EMISSION 1 # Emission feature (center1d) +define ABSORPTION 2 # Absorption feature (center1d) +define GEMISSION 3 # Emission feature (center1d) +define GABSORPTION 4 # Absorption feature (center1d) + +define IMDATA Memr[ID_IMDATA($1)+$2-1] +define PIXDATA Memd[ID_PIXDATA($1)+$2-1] +define FITDATA Memd[ID_FITDATA($1)+$2-1] + +define PIX Memd[ID_PIX($1)+$2-1] +define FIT Memd[ID_FIT($1)+$2-1] +define USER Memd[ID_USER($1)+$2-1] +define WTS Memd[ID_WTS($1)+$2-1] +define FWIDTH Memr[ID_FWIDTHS($1)+$2-1] +define FTYPE Memi[ID_FTYPES($1)+$2-1] + +define VLIGHT 2.997925e5 # Speed of light, Km/sec diff --git a/noao/rv/rvidlines/identify.key b/noao/rv/rvidlines/identify.key new file mode 100644 index 00000000..ae2f9339 --- /dev/null +++ b/noao/rv/rvidlines/identify.key @@ -0,0 +1,104 @@ + IDENTIFY HELP + + +STATUS LINE + +The status line gives the pixel position, fitted wavelength, user wavelength, +wavelength residual, and optional line identification: + + pixel fitted user residual [identification] + + +CURSOR KEY SUMMARY + +? Help l Match list (fit) w Window graph +a Affect all features m Mark feature x Crosscorrelate peaks +b Deblend n Next feature y Find peaks +c Center feature(s) o Go to line z Zoom graph +d Delete feature(s) p Pan graph + Next feature +f Fit positions q Quit - Previous feature +g Fit zero point shift r Redraw graph . Nearest feature +i Initialize s Shift feature I Interrupt +j Preceding line t Reset position +k Next line u Enter coordinate + + +COLON COMMAND SUMMARY + +:show [file] :features [file] :coordlist [file] +:cradius [value] :threshold [value] :database [file] +:ftype [type] :fwidth [value] :image [image] +:labels [type] :match [value] :maxfeatures [value] +:minsep [value] :read [image [ap]] :write [image [ap]] +:zwidth [value] :add [image [ap]] :vlog [file] + + +CURSOR KEYS + +? Clear the screen and print menu of options +a Apply next (c)enter or (d)elete operation to (a)ll features +b Mark and de(b)lend features by Gaussian fitting +c (C)enter the feature nearest the cursor +d (D)elete the feature nearest the cursor +f (F)it a function of pixel coordinate to the user coordinates +g Fit a zero point shift to the user coordinates +h Match coordinates in the coordinate list without modifying the fit +i (I)nitialize (delete features and coordinate fit) +j Go to the preceding image line or column in a 2D or multispec image +k Go to the next image line or column in a 2D or multispec image +l Match coordinates in the coordinate (l)ist and fit/refit the dispersion +m (M)ark a new feature near the cursor and enter coordinate and label +n Move the cursor or zoom to the (n)ext feature (same as +) +o Go to the specified image line or column in a 2D or multispec image +p (P)an to user defined window after (z)ooming on a feature +q (Q)uit and continue with next image (also carriage return) +r (R)edraw the graph +s (S)hift the current feature to the position of the cursor +t Reset the position of a feature without centering +u Enter a new (u)ser coordinate and label for the current feature +v Compute a redshift and velocity from the fitted and user coordinates +w (W)indow the graph. Use '?' to window prompt for more help. +x Crosscorrelate features with the data peaks and reregister +y Automatically find "maxfeatures" strongest peaks and identify them +z (Z)oom on the feature nearest the cursor +. Move the cursor or zoom to the feature nearest the cursor ++ Move the cursor or zoom to the next feature +- Move the cursor or zoom to the previous feature +I Interrupt task and exit immediately. Database information is not saved. + + +COLON COMMANDS + +The parameters are listed or set with the following commands which may be +abbreviated. To list the value of a parameter type the command alone. + +:show file Show the values of all the parameters +:features file Write feature list to file (default is STDOUT) +:vlog file Write velocity information to file (default is STDOUT) + +:coordlist file Coordinate list file +:cradius value Centering radius in pixels +:threshold value Detection threshold for feature centering +:database name Database for recording feature records +:ftype value Feature type (emission or absorption) +:fwidth value Feature width in pixels +:image imagename Set a new image or show the current image +:labels value Feature label type (none|index|pixel|coords|user|both) +:match value Coordinate list matching distance +:maxfeatures value Maximum number of features automatically found +:minsep value Minimum separation allowed between features +:read name ap Read a record from the database + (name and ap default to the current spectrum) +:write name ap Write a record to the database + (name and ap default to the current spectrum) +:add name ap Add features from the database + (name and ap default to the current spectrum) +:zwidth value Zoom width in user units + +Labels: + none - No labels + index - Sequential numbers in order of increasing pixel position + pixel - Pixel coordinates + coords - User coordinates such as wavelength + user - User labels + both - Combination of coords and user diff --git a/noao/rv/rvidlines/idfitdata.x b/noao/rv/rvidlines/idfitdata.x new file mode 100644 index 00000000..48c36984 --- /dev/null +++ b/noao/rv/rvidlines/idfitdata.x @@ -0,0 +1,140 @@ +include <smw.h> +include "identify.h" + +# ID_FITDATA -- Compute fit coordinates from pixel coordinates. + +procedure id_fitdata (id) + +pointer id # ID pointer +int i + +begin + call mfree (ID_FITDATA(id), TY_DOUBLE) + call malloc (ID_FITDATA(id), ID_NPTS(id), TY_DOUBLE) + + if (ID_CV(id) == NULL) + call achtrd (Memr[SX(ID_SH(id))], FITDATA(id,1), ID_NPTS(id)) + else { + call dcvvector (ID_CV(id), PIXDATA(id,1), FITDATA(id,1), + ID_NPTS(id)) + if (FITDATA(id,2) > FITDATA(id,1)) { + do i = 3, ID_NPTS(id) + if (FITDATA(id,i) < FITDATA(id,i-1)) + call error (1, "Coordinate solution is not monotonic") + } else { + do i = 3, ID_NPTS(id) + if (FITDATA(id,i) > FITDATA(id,i-1)) + call error (1, "Coordinate solution is not monotonic") + } + } + if (ID_SHIFT(id) != 0.) + call aaddkd (FITDATA(id,1), ID_SHIFT(id), FITDATA(id,1),ID_NPTS(id)) +end + + +# ID_FITFEATURES -- Compute fit coordinates for features. + +procedure id_fitfeatures (id) + +pointer id # ID pointer +int i + +double id_fitpt() + +begin + if (ID_NFEATURES(id) < 1) + return + + if (ID_CV(id) == NULL) + do i = 1, ID_NFEATURES(id) + FIT(id,i) = id_fitpt (id, PIX(id,i)) + else { + call dcvvector (ID_CV(id), PIX(id,1), FIT(id,1), ID_NFEATURES(id)) + if (ID_SHIFT(id) != 0.) + call aaddkd (FIT(id,1), ID_SHIFT(id), FIT(id,1), ID_NFEATURES(id)) + } +end + + +# ID_FITPT -- Compute fit coordinates from pixel coordinates. + +double procedure id_fitpt (id, pix) + +pointer id # ID pointer +double pix # Pixel coordinate + +double fit + +double smw_c1trand(), shdr_lw(), dcveval() + +begin + if (ID_CV(id) == NULL) { + fit = smw_c1trand (ID_PL(id), pix) + fit = shdr_lw (ID_SH(id), fit) + } else + fit = dcveval (ID_CV(id), pix) + fit = fit + ID_SHIFT(id) + + return (fit) +end + + +# FIT_TO_PIX -- Transform fit coordinate to pixel coordinate. + +define DXMIN .01 + +double procedure fit_to_pix (id, fitcoord) + +pointer id # ID pointer +double fitcoord # Fit coordinate to be transformed +double pixcoord # Pixel coordinate returned + +int i, np1 +double dx + +double smw_c1trand(), id_fitpt() + +begin + np1 = NP1(ID_SH(id)) - 1 + if (FITDATA(id,1) < FITDATA(id,ID_NPTS(id))) { + if ((fitcoord<FITDATA(id,1)) || (fitcoord>FITDATA(id,ID_NPTS(id)))) + return (INDEFD) + + for (i = 1; fitcoord > FITDATA(id,i); i = i + 1) + ; + + if (FITDATA(id,i) == fitcoord) + return (PIXDATA(id,i)) + + pixcoord = smw_c1trand (ID_LP(id), double(i+np1-.5)) + dx = smw_c1trand (ID_LP(id), double(i+np1+.5)) - pixcoord + while (dx > DXMIN) { + dx = dx / 2 + if (id_fitpt (id, pixcoord) < fitcoord) + pixcoord = pixcoord + dx + else + pixcoord = pixcoord - dx + } + } else { + if ((fitcoord<FITDATA(id,ID_NPTS(id))) || (fitcoord>FITDATA(id,1))) + return (INDEFD) + + for (i = 1; fitcoord < FITDATA(id,i); i = i + 1) + ; + + if (FITDATA(id,i) == fitcoord) + return (PIXDATA(id,i)) + + pixcoord = smw_c1trand (ID_LP(id), double(i+np1-.5)) + dx = smw_c1trand (ID_LP(id), double(i+np1+.5)) - pixcoord + while (dx > DXMIN) { + dx = dx / 2 + if (id_fitpt (id, pixcoord) < fitcoord) + pixcoord = pixcoord - dx + else + pixcoord = pixcoord + dx + } + } + + return (pixcoord) +end diff --git a/noao/rv/rvidlines/idfixx.x b/noao/rv/rvidlines/idfixx.x new file mode 100644 index 00000000..ae74fcdf --- /dev/null +++ b/noao/rv/rvidlines/idfixx.x @@ -0,0 +1,27 @@ +include <smw.h> + +# ID_FIXX - Adjust so that pixel indices are increasing. + +procedure id_fixx (sh, x1, x2, y1, y2, i1, i2) + +pointer sh +real x1, x2, y1, y2 +int i1, i2 + +double z, z1, z2, shdr_wl(), shdr_lw() + +begin + z1 = x1 + z2 = x2 + z1 = max (0.5D0, min (double (SN(sh)+.499), shdr_wl(sh, z1))) + z2 = max (0.5D0, min (double (SN(sh)+.499), shdr_wl(sh, z2))) + if (z1 > z2) { + z = y1; y1 = y2; y2 = z + z = z1; z1 = z2; z2 = z + } + + x1 = shdr_lw (sh, z1) + x2 = shdr_lw (sh, z2) + i1 = nint (z1) + i2 = nint (z2) +end diff --git a/noao/rv/rvidlines/idgdata.x b/noao/rv/rvidlines/idgdata.x new file mode 100644 index 00000000..caddce02 --- /dev/null +++ b/noao/rv/rvidlines/idgdata.x @@ -0,0 +1,74 @@ +include <imhdr.h> +include <imio.h> +include <pkg/gtools.h> +include <smw.h> +include "identify.h" + +define SZ_TITLE 320 # Size of long string for title. + +# ID_GDATA -- Get image data. + +procedure id_gdata (id) + +pointer id # ID pointer + +int i, np1 +double hjd +pointer sp, str, im, mw, sh + +double smw_c1trand() +errchk shdr_open, id_vhelio + +begin + call smark (sp) + call salloc (str, SZ_TITLE, TY_CHAR) + + sh = ID_SH(id) + im = IM(sh) + mw = MW(sh) + + # If format is multispec then header info depends on line. + if (SMW_FORMAT(mw) == SMW_ES || SMW_FORMAT(mw) == SMW_MS) + ID_LINE(id,2) = 1 + call shdr_open (im, mw, ID_LINE(id,1), ID_LINE(id,2), + INDEFI, SHDATA, sh) + ID_AP(id,1) = AP(sh) + ID_AP(id,2) = ID_LINE(id,2) + ID_NPTS(id) = SN(sh) + call id_dbsection (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + Memc[ID_SECTION(id)], SZ_FNAME) + call sprintf (Memc[str], SZ_TITLE, "%s %s%s\n%s") + if (ID_TASK(id) == IDENTIFY) + call pargstr ("identify") + else + call pargstr ("rvidlines") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargstr (TITLE(sh)) + call gt_sets (ID_GT(id), GTTITLE, Memc[str]) + + # Free previous vectors and allocate new vectors. + call mfree (ID_PIXDATA(id), TY_DOUBLE) + + call malloc (ID_PIXDATA(id), ID_NPTS(id), TY_DOUBLE) + + # Set the physical coordinates. + np1 = NP1(sh) - 1 + do i = 1, ID_NPTS(id) + PIXDATA(id,i) = smw_c1trand (ID_LP(id), double(i+np1)) + + # Set the image data + ID_IMDATA(id) = SY(sh) + + # Set the heliocentric correction. + if (ID_TASK(id) == RVIDLINES) { + call id_vhelio (im, ID_ZHELIO(id), hjd, NULL) + ID_ZHELIO(id) = ID_ZHELIO(id) / VLIGHT + } else + ID_ZHELIO(id) = 0 + + ID_NEWGRAPH(id) = YES + ID_NEWCV(id) = YES + + call sfree (sp) +end diff --git a/noao/rv/rvidlines/idgraph.x b/noao/rv/rvidlines/idgraph.x new file mode 100644 index 00000000..c8d92b79 --- /dev/null +++ b/noao/rv/rvidlines/idgraph.x @@ -0,0 +1,168 @@ +include <gset.h> +include <pkg/gtools.h> +include <smw.h> +include "identify.h" + +# ID_GRAPH -- Graph image vector in which features are to be identified. + +procedure id_graph (id, gtype) + +pointer id # ID pointer +int gtype # Graph type + +begin + switch (gtype) { + case 1: + call id_graph1 (id) + case 2: + call id_graph2 (id) + default: + call id_graph1 (id) + } +end + + +procedure id_graph1 (id) + +pointer id # ID pointer + +int i, n +real xmin, xmax, ymin, ymax, dy, xminz, xmaxz, id_zshiftr() +pointer gp, sh, sp, x, y, str + +begin + gp = ID_GP(id) + sh = ID_SH(id) + + call smark (sp) + call salloc (x, SN(sh), TY_REAL) + y = SY(sh) + n = SN(sh) + + call achtdr (FITDATA(id,1), Memr[x], n) + + call gclear (gp) + xmin = min (Memr[x], Memr[x+n-1]) + xmax = max (Memr[x], Memr[x+n-1]) + call alimr (Memr[y], n, ymin, ymax) + dy = ymax - ymin + call gswind (gp, xmin, xmax, ymin - .2 * dy, ymax + .2 * dy) + call gt_swind (gp, ID_GT(id)) + + if (ID_TASK(id) == RVIDLINES && ID_REDSHIFT(id) != 0D0) { + call salloc (str, SZ_LINE, TY_CHAR) + if (ID_ZHELIO(id) == 0D0) + call sprintf (Memc[str], SZ_LINE, + "Vobs = %.5g, Zobs = %.5g\n\n\n") + else + call sprintf (Memc[str], SZ_LINE, + "Vhelio = %.5g, Zhelio = %.5g\n\n\n") + call pargd ((ID_REDSHIFT(id)+ID_ZHELIO(id)) * VLIGHT) + call pargd (ID_REDSHIFT(id)+ID_ZHELIO(id)) + call gt_sets (ID_GT(id), GTSUBTITLE, Memc[str]) + call gseti (gp, G_XDRAWAXES, 1) + call gt_labax (gp, ID_GT(id)) + call gt_sets (ID_GT(id), GTSUBTITLE, "") + + call ggwind (gp, xmin, xmax, ymin, ymax) + xminz = id_zshiftr (id, xmin, 0) + xmaxz = id_zshiftr (id, xmax, 0) + call gswind (gp, xminz, xmaxz, ymin, ymax) + call gseti (gp, G_XDRAWAXES, 2) + call gseti (gp, G_YDRAWAXES, 0) + call glabax (gp, "", "", "") + + call gswind (gp, xmin, xmax, ymin, ymax) + call gctran (gp, xmin, ymin, xmax, ymax, 1, 0) + call gctran (gp, xmax, ymax, xmin, ymin, 0, 1) + } else + call gt_labax (gp, ID_GT(id)) + + call gt_plot (gp, ID_GT(id), Memr[x], Memr[y], n) + + do i = 1, ID_NFEATURES(id) + call id_mark (id, i) + + call sfree (sp) +end + + +# ID_GRAPH2 -- Make review graph for current feature. + +procedure id_graph2 (id) + +pointer id # ID pointer + +int i, j, k, n +real xmin, xmax, ymin, ymax, dy, xminz, xmaxz, id_zshiftr() +pointer gp, sh, sp, x, y, str + +begin + gp = ID_GP(id) + sh = ID_SH(id) + + call smark (sp) + call salloc (x, SN(sh), TY_REAL) + y = SY(sh) + n = SN(sh) + + call achtdr (FITDATA(id,1), Memr[x], n) + + xmin = real (FIT(id,ID_CURRENT(id))) - ID_ZWIDTH(id) / 2. + xmax = real (FIT(id,ID_CURRENT(id))) + ID_ZWIDTH(id) / 2. + + i = 0 + do k = 1, n { + if ((Memr[x+k-1] < xmin) || (Memr[x+k-1] > xmax)) + next + if (i == 0) + i = k + j = k + } + k = j - i + 1 + + call alimr (Memr[y+i-1], k, ymin, ymax) + dy = ymax - ymin + + call gclear (gp) + call gswind (gp, xmin, xmax, ymin - .2 * dy, ymax + .2 * dy) +# if (ID_GT(id) != NULL) { +# call gseti (gp, G_XTRAN, GT_XTRAN(ID_GT(id))) +# call gseti (gp, G_YTRAN, GT_YTRAN(ID_GT(id))) +# } + if (ID_TASK(id) == RVIDLINES && ID_REDSHIFT(id) != 0D0) { + call salloc (str, SZ_LINE, TY_CHAR) + if (ID_ZHELIO(id) == 0D0) + call sprintf (Memc[str], SZ_LINE, + "Vobs = %.5g, Zobs = %.5g\n\n\n") + else + call sprintf (Memc[str], SZ_LINE, + "Vhelio = %.5g, Zhelio = %.5g\n\n\n") + call pargd ((ID_REDSHIFT(id)+ID_ZHELIO(id)) * VLIGHT) + call pargd (ID_REDSHIFT(id)+ID_ZHELIO(id)) + call gt_sets (ID_GT(id), GTSUBTITLE, Memc[str]) + call gseti (gp, G_XDRAWAXES, 1) + call gt_labax (gp, ID_GT(id)) + call gt_sets (ID_GT(id), GTSUBTITLE, "") + + call ggwind (gp, xmin, xmax, ymin, ymax) + xminz = id_zshiftr (id, xmin, 0) + xmaxz = id_zshiftr (id, xmax, 0) + call gswind (gp, xminz, xmaxz, ymin, ymax) + call gseti (gp, G_XDRAWAXES, 2) + call gseti (gp, G_YDRAWAXES, 0) + call glabax (gp, "", "", "") + + call gswind (gp, xmin, xmax, ymin, ymax) + call gctran (gp, xmin, ymin, xmax, ymax, 1, 0) + call gctran (gp, xmax, ymax, xmin, ymin, 0, 1) + } else + call gt_labax (gp, ID_GT(id)) + + call gt_plot (gp, ID_GT(id), Memr[x], Memr[y], n) + + do i = 1, ID_NFEATURES(id) + call id_mark (id, i) + + call sfree (sp) +end diff --git a/noao/rv/rvidlines/ididentify.x b/noao/rv/rvidlines/ididentify.x new file mode 100644 index 00000000..9874865e --- /dev/null +++ b/noao/rv/rvidlines/ididentify.x @@ -0,0 +1,795 @@ +include <error.h> +include <imhdr.h> +include <gset.h> +include <smw.h> +include "identify.h" + +define HELP "noao$onedspec/identify/identify.key" +define RVHELP "noao$rv/rvidlines/rvidlines.key" +define ICFITHELP "noao$lib/scr/idicgfit.key" +define PROMPT "identify options" + +define PAN 1 # Pan graph +define ZOOM 2 # Zoom graph + +# ID_IDENTIFY -- Identify features in an image. +# This is the main interactive loop. + +procedure id_identify (id) + +pointer id # ID pointer + +real wx, wy, wx2, wy2 +int wcs, key +char cmd[SZ_LINE] + +char newimage[SZ_FNAME] +int i, j, last, all, prfeature, nfeatures1, npeaks, ftype, newline[2] +bool answer +double pix, fit, user, shift, pix_shift, z_shift, xg[10] +pointer peaks, label + +bool clgetb() +pointer gopen() +int clgcur(), scan(), nscan(), find_peaks(), errcode(), id_gid(), nowhite() +double id_center(), fit_to_pix(), id_fitpt() +double id_shift(), id_rms(), id_zshiftd(), id_zval() +errchk id_gdata(), id_graph(), id_dbread(), xt_mk1d(), id_log() + +define newim_ 10 +define newkey_ 20 +define beep_ 99 + +begin +newim_ + # Open the image and return if there is an error. + iferr (call id_map (id)) { + call erract (EA_WARN) + return + } + + # Get the image data and return if there is an error. + iferr (call id_gdata (id)) { + call erract (EA_WARN) + return + } + + # Get the database entry for the image if it exists. + iferr { + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO, YES) + ID_NEWDBENTRY(id) = NO + } then + if ((ID_NFEATURES(id) > 0) || (ID_CV(id) != NULL)) + ID_NEWDBENTRY(id) = YES + + # Set the coordinate information. + iferr (call id_fitdata (id)) + ; + + # Set fitting limits. + call ic_putr (ID_IC(id), "xmin", real (PIXDATA(id,1))) + call ic_putr (ID_IC(id), "xmax", real (PIXDATA(id,ID_NPTS(id)))) + call ic_pstr (ID_IC(id), "help", ICFITHELP) + + # Open graphics. + call clgstr ("graphics", newimage, SZ_FNAME) + ID_GP(id) = gopen (newimage, NEW_FILE, STDGRAPH) + + # Initialize. + ID_GTYPE(id) = PAN + all = 0 + last = ID_CURRENT(id) + newimage[1] = EOS + newline[1] = ID_LINE(id,1) + newline[2] = ID_LINE(id,2) + ID_REFIT(id) = NO + ID_NEWFEATURES(id) = NO + ID_NEWCV(id) = NO + wy = INDEF + key = 'r' + + repeat { + prfeature = YES + if (all != 0) + all = mod (all + 1, 3) + + switch (key) { + case '?': # Print help + if (ID_TASK(id) == IDENTIFY) + call gpagefile (ID_GP(id), HELP, PROMPT) + else + call gpagefile (ID_GP(id), RVHELP, PROMPT) + case ':': # Process colon commands + if (cmd[1] == '/') + call gt_colon (cmd, ID_GP(id), ID_GT(id), ID_NEWGRAPH(id)) + else + call id_colon (id, cmd, newimage, prfeature) + case ' ': # Go to current feature + case '.': # Go to nearest feature + if (ID_NFEATURES(id) == 0) + goto beep_ + call id_nearest (id, double (wx)) + case '-': # Go to previous feature + if (ID_CURRENT(id) == 1) + goto beep_ + ID_CURRENT(id) = ID_CURRENT(id) - 1 + case '+', 'n': # Go to next feature + if (ID_CURRENT(id) == ID_NFEATURES(id)) + goto beep_ + ID_CURRENT(id) = ID_CURRENT(id) + 1 + case 'a': # Set all flag for next key + all = 1 + case 'b': # Mark blended features + i = 1 + fit = wx + xg[i] = fit_to_pix (id, fit) + call printf ("mark other components (exit with 'q'):") + while (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE)!=EOF) { + if (key == 'q') + break + i = i + 1 + fit = wx + xg[i] = fit_to_pix (id, fit) + if (i == 10) + break + } + + call printf ("mark two background points: ") + j = clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) + j = clgcur ("cursor", wx2, wy2, wcs, key, cmd, SZ_LINE) + wx = fit_to_pix (id, double (wx)) + wx2 = fit_to_pix (id, double (wx2)) + + switch (ID_FTYPE(id)) { + case EMISSION: + ftype = GEMISSION + case ABSORPTION: + ftype = GABSORPTION + default: + ftype = ID_FTYPE(id) + } + iferr (call id_gcenter (id, xg, i, wx, wy, wx2, wy2, + ID_FWIDTH(id), ftype, YES)) { + call erract (EA_WARN) + prfeature = NO + goto newkey_ + } + + do j = 1, i { + pix = xg[j] + fit = id_fitpt (id, pix) + user = fit + call id_newfeature (id, pix, fit, user, 1.0D0, + ID_FWIDTH(id), ftype, NULL) + USER(id,ID_CURRENT(id)) = INDEFD + call id_match (id, FIT(id,ID_CURRENT(id)), + USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + call id_mark (id, ID_CURRENT(id)) + call printf ("%10.2f %10.8g ") + call pargd (PIX(id,ID_CURRENT(id))) + call pargd (FIT(id,ID_CURRENT(id))) + if (ID_REDSHIFT(id) != 0.) { + call printf ("%10.8g ") + call pargd ( + id_zshiftd (id, FIT(id,ID_CURRENT(id)), 0)) + } + call printf ("(%10.8g %s): ") + call pargd (USER(id,ID_CURRENT(id))) + label = Memi[ID_LABEL(id)+ID_CURRENT(id)-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + call gargwrd (cmd, SZ_LINE) + i = nscan() + if (i > 0) { + USER(id,ID_CURRENT(id)) = user + fit = id_zshiftd (id, user, 1) + call id_match (id, fit, USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + } + if (i > 1) { + call reset_scan () + call gargd (user) + call gargstr (cmd, SZ_LINE) + call id_label (cmd, + Memi[ID_LABEL(id)+ID_CURRENT(id)-1]) + } + } + } + case 'c': # Recenter features + if (all != 0) { + for (i = 1; i <= ID_NFEATURES(id); i = i + 1) { + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, i) + call gseti (ID_GP(id), G_PLTYPE, 1) + FWIDTH(id,i) = ID_FWIDTH(id) + PIX(id,i) = id_center (id, PIX(id,i), 1, FWIDTH(id,i), + FTYPE(id,i), NO) + if (!IS_INDEFD (PIX(id,i))) { + FIT(id,i) = id_fitpt (id, PIX(id,i)) + call id_mark (id, i) + } else { + call id_delete (id, i) + i = i - 1 + } + } + ID_NEWFEATURES(id) = YES + } else { + if (ID_NFEATURES(id) < 1) + goto beep_ + call id_nearest (id, double (wx)) + pix = PIX(id,ID_CURRENT(id)) + pix = id_center (id, pix, 1, ID_FWIDTH(id), + FTYPE(id,ID_CURRENT(id)), NO) + if (!IS_INDEFD (pix)) { + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, ID_CURRENT(id)) + PIX(id,ID_CURRENT(id)) = pix + FWIDTH(id,ID_CURRENT(id)) = ID_FWIDTH(id) + FIT(id,ID_CURRENT(id)) = id_fitpt (id, pix) + call gseti (ID_GP(id), G_PLTYPE, 1) + call id_mark (id, ID_CURRENT(id)) + ID_NEWFEATURES(id) = YES + } else { + call printf ("Centering failed\n") + prfeature = NO + } + } + case 'd': # Delete features + if (all != 0) { + ID_NFEATURES(id) = 0 + ID_CURRENT(id) = 0 + ID_NEWFEATURES(id) = YES + ID_NEWGRAPH(id) = YES + } else { + if (ID_NFEATURES(id) < 1) + goto beep_ + call id_nearest (id, double (wx)) + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, ID_CURRENT(id)) + call gseti (ID_GP(id), G_PLTYPE, 1) + call id_delete (id, ID_CURRENT(id)) + ID_CURRENT(id) = min (ID_NFEATURES(id), ID_CURRENT(id)) + last = 0 + } + case 'f': # Fit dispersion function + if (ID_TASK(id) == IDENTIFY) { + call id_dofit (id, YES) + } else { + call id_velocity (id, YES) + prfeature = NO + } + case 'g': # Fit shift + if (ID_TASK(id) == RVIDLINES) + goto beep_ + + call id_doshift (id, YES) + prfeature = NO + case 'i': # Initialize + call dcvfree (ID_CV(id)) + ID_SHIFT(id) = 0. + ID_REDSHIFT(id) = 0. + ID_NEWCV(id) = YES + ID_NFEATURES(id) = 0 + ID_CURRENT(id) = 0 + ID_NEWFEATURES(id) = YES + ID_NEWGRAPH(id) = YES + case 'j': # Go to previous line + newline[1] = ID_LINE(id,1) - ID_NSUM(id,1) + if (newline[1] < 1) { + newline[1] = newline[1] + ID_MAXLINE(id,1) + newline[2] = ID_LINE(id,2) - ID_NSUM(id,2) + if (newline[2] < 1) + newline[2] = newline[2] + ID_MAXLINE(id,2) + } + case 'k': # Go to next line + newline[1] = ID_LINE(id,1) + ID_NSUM(id,1) + if (newline[1] > ID_MAXLINE(id,1)) { + newline[1] = newline[1] - ID_MAXLINE(id,1) + newline[2] = ID_LINE(id,2) + ID_NSUM(id,2) + if (newline[2] > ID_MAXLINE(id,2)) + newline[2] = newline[2] - ID_MAXLINE(id,2) + } + case 'l': # Find features from line list + if (ID_TASK(id) == IDENTIFY) { + if (ID_NFEATURES(id) >= 2) + call id_dofit (id, NO) + if (ID_NEWCV(id) == YES) { + iferr (call id_fitdata(id)) + ; + call id_fitfeatures(id) + ID_NEWCV(id) = NO + } + call id_linelist (id) + if (ID_NEWFEATURES(id) == YES) + ID_REFIT(id) = YES + } else { + call id_velocity (id, NO) + call id_linelist (id) + if (ID_NEWFEATURES(id) == YES) { + call id_velocity (id, NO) + ID_NEWGRAPH(id) = YES + } + } + case 'm': # Mark new feature + fit = wx + pix = fit_to_pix (id, fit) + pix = id_center (id, pix, 1, ID_FWIDTH(id), ID_FTYPE(id), YES) + if (IS_INDEFD (pix)) + goto beep_ + fit = id_fitpt (id, pix) + user = fit + call id_newfeature (id, pix, fit, user, 1.0D0, ID_FWIDTH(id), + ID_FTYPE(id), NULL) + USER(id,ID_CURRENT(id)) = INDEFD + call id_match (id, FIT(id,ID_CURRENT(id)), + USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + call id_mark (id, ID_CURRENT(id)) + call printf ("%10.2f %10.8g ") + call pargd (PIX(id,ID_CURRENT(id))) + call pargd (FIT(id,ID_CURRENT(id))) + if (ID_REDSHIFT(id) != 0.) { + call printf ("%10.8g ") + call pargd ( + id_zshiftd (id, FIT(id,ID_CURRENT(id)), 0)) + } + call printf ("(%10.8g %s): ") + call pargd (USER(id,ID_CURRENT(id))) + label = Memi[ID_LABEL(id)+ID_CURRENT(id)-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + call gargwrd (cmd, SZ_LINE) + i = nscan() + if (i > 0) { + USER(id,ID_CURRENT(id)) = user + fit = id_zshiftd (id, user, 1) + call id_match (id, fit, USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + } + if (i > 1) { + call reset_scan () + call gargd (user) + call gargstr (cmd, SZ_LINE) + call id_label (cmd, Memi[ID_LABEL(id)+ID_CURRENT(id)-1]) + } + } + case 'o': # Go to a specified line + call printf ("Line/Column/Band (%d %d): ") + call pargi (ID_LINE(id,1)) + call pargi (ID_LINE(id,2)) + call flush (STDOUT) + if (scan() != EOF) { + call gargi (j) + if (nscan() == 1) { + if (j < 1 || j > ID_MAXLINE(id,1)) + goto beep_ + newline[1] = j + call gargi (j) + if (nscan() == 2) { + if (j < 1 || j > ID_MAXLINE(id,2)) + goto beep_ + newline[2] = j + } + } + } + case 'p': # Switch to pan mode + if (ID_GTYPE(id) != PAN) { + ID_GTYPE(id) = PAN + ID_NEWGRAPH(id) = YES + } + case 'q': # Exit loop + break + case 'r': # Redraw the graph + ID_NEWGRAPH(id) = YES + case 's', 'x': # Shift or correlate features + if (ID_TASK(id) == RVIDLINES) + goto beep_ + + # Get coordinate shift. + switch (key) { + case 's': + call printf ("User coordinate (%10.8g): ") + call pargr (wx) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + if (nscan() == 1) + shift = wx - user + } else + shift = 0. + case 'x': + if (ID_NFEATURES(id) > 5) + shift = id_shift (id) + else + goto beep_ + } + + ID_NEWFEATURES(id) = YES + ID_NEWCV(id) = YES + ID_NEWGRAPH(id) = YES + prfeature = NO + + if (ID_NFEATURES(id) < 1) { + call printf ("User coordinate shift=%5f\n") + call pargd (shift) + ID_SHIFT(id) = ID_SHIFT(id) + shift + goto newkey_ + } + + # Recenter features. + pix_shift = 0. + z_shift = 0. + nfeatures1 = ID_NFEATURES(id) + + j = 0. + do i = 1, ID_NFEATURES(id) { + pix = fit_to_pix (id, FIT(id,i) + shift) + pix = id_center (id, pix, 1, FWIDTH(id,i), FTYPE(id,i), NO) + if (IS_INDEFD (pix)) { + if (ID_CURRENT(id) == i) + ID_CURRENT(id) = i + 1 + next + } + fit = id_fitpt (id, pix) + + pix_shift = pix_shift + pix - PIX(id,i) + if (FIT(id,i) != 0.) + z_shift = z_shift + id_zval (id, fit, FIT(id,i)) + + j = j + 1 + PIX(id,j) = pix + FIT(id,j) = FIT(id,i) + USER(id,j) = USER(id,i) + WTS(id,j) = WTS(id,i) + FWIDTH(id,j) = FWIDTH(id,i) + FTYPE(id,j) = FTYPE(id,i) + if (ID_CURRENT(id) == i) + ID_CURRENT(id) = j + } + if (j != ID_NFEATURES(id)) { + ID_NFEATURES(id) = j + ID_CURRENT(id) = min (ID_CURRENT(id), ID_NFEATURES(id)) + } + + if (ID_NFEATURES(id) < 1) { + call printf ("User coordinate shift=%5f") + call pargd (shift) + call printf (", No features found during recentering\n") + ID_SHIFT(id) = ID_SHIFT(id) + shift + goto newkey_ + } + + # Adjust shift. + pix = ID_SHIFT(id) + call id_doshift (id, NO) + call id_fitfeatures (id) + + # Print results. + call printf ("Recentered=%d/%d") + call pargi (ID_NFEATURES(id)) + call pargi (nfeatures1) + call printf ( + ", pixel shift=%.2f, user shift=%5f, z=%7.3g, rms=%5g\n") + call pargd (pix_shift / ID_NFEATURES(id)) + call pargd (pix - ID_SHIFT(id)) + call pargd (z_shift / ID_NFEATURES(id)) + call pargd (id_rms(id)) + case 't': # Move the current feature + if (ID_CURRENT(id) < 1) + goto beep_ + pix = fit_to_pix (id, double (wx)) + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, ID_CURRENT(id)) + PIX(id,ID_CURRENT(id)) = pix + FIT(id,ID_CURRENT(id)) = id_fitpt (id, pix) + call gseti (ID_GP(id), G_PLTYPE, 1) + call id_mark (id, ID_CURRENT(id)) + ID_NEWFEATURES(id) = YES + case 'u': # Set user coordinate + if (ID_NFEATURES(id) < 1) + goto beep_ + call printf ("%10.2f %10.8g ") + call pargd (PIX(id,ID_CURRENT(id))) + call pargd (FIT(id,ID_CURRENT(id))) + if (ID_REDSHIFT(id) != 0.) { + call printf ("%10.8g ") + call pargd (id_zshiftd (id, FIT(id,ID_CURRENT(id)), 0)) + } + call printf ("(%10.8g %s): ") + call pargd (USER(id,ID_CURRENT(id))) + label = Memi[ID_LABEL(id)+ID_CURRENT(id)-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + call gargwrd (cmd, SZ_LINE) + i = nscan() + if (i > 0) { + USER(id,ID_CURRENT(id)) = user + ID_NEWFEATURES(id) = YES + } + if (i > 1) { + call reset_scan () + call gargd (user) + call gargstr (cmd, SZ_LINE) + call id_label (cmd, Memi[ID_LABEL(id)+ID_CURRENT(id)-1]) + } + } + call printf ("Weight (%g): ") + call pargd (WTS(id,ID_CURRENT(id))) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + if (nscan() > 0) + WTS(id,ID_CURRENT(id)) = user + } + case 'w': # Window graph + call gt_window (ID_GT(id), ID_GP(id), "cursor", ID_NEWGRAPH(id)) + case 'y': # Find peaks + call alimr (IMDATA(id,1), ID_NPTS(id), wx, wy) + call malloc (peaks, ID_NPTS(id), TY_REAL) + if (ID_FTYPE(id) == ABSORPTION || ID_FTYPE(id) == GABSORPTION) + npeaks = find_peaks (IMDATA(id,1), Memr[peaks], + ID_NPTS(id), -1., int (ID_MINSEP(id)), 0, + ID_MAXFEATURES(id), wy, false) + else + npeaks = find_peaks (IMDATA(id,1), Memr[peaks], + ID_NPTS(id), 0., int (ID_MINSEP(id)), 0, + ID_MAXFEATURES(id), wx, false) + for (j = 1; j <= ID_NFEATURES(id); j = j + 1) { + for (i = 1; i <= npeaks; i = i + 1) { + if (!IS_INDEF (Memr[peaks+i-1])) { + pix = Memr[peaks+i-1] + if (abs (pix - PIX(id,j)) < ID_MINSEP(id)) + Memr[peaks+i-1] = INDEF + } + } + } + for (i = 1; i <= npeaks; i = i + 1) { + if (IS_INDEF(Memr[peaks+i-1])) + next + pix = Memr[peaks+i-1] + pix = id_center(id, pix, 1, ID_FWIDTH(id), ID_FTYPE(id), NO) + if (IS_INDEFD (pix)) + next + fit = id_fitpt (id, pix) + user = INDEFD + call id_match (id, fit, user, label, ID_MATCH(id)) + call id_newfeature (id, pix, fit, user, 1.0D0, + ID_FWIDTH(id), ID_FTYPE(id), label) + call id_mark (id, ID_CURRENT(id)) + } + call mfree (peaks, TY_REAL) + case 'z': # Go to zoom mode + if (ID_NFEATURES(id) < 1) + goto beep_ + if (ID_GTYPE(id) == PAN) + ID_NEWGRAPH(id) = YES + ID_GTYPE(id) = ZOOM + call id_nearest (id, double (wx)) + case 'I': + call fatal (0, "Interrupt") + default: +beep_ call printf ("\007") + } + +newkey_ + # Set update flag if anything has changed. + if ((ID_NEWFEATURES(id) == YES) || (ID_NEWCV(id) == YES)) + ID_NEWDBENTRY(id) = YES + + # If a new image exit loop, update database, and start over. + if (newimage[1] != EOS) + break + + # If a new line, save features and set new line. + if (newline[1] != ID_LINE(id,1) || newline[2] != ID_LINE(id,2)) { + call id_saveid (id, ID_LINE(id,1)) + ID_LINE(id,1) = newline[1] + ID_LINE(id,2) = newline[2] + call id_gdata (id) + if (id_gid (id, newline) == EOF) { + iferr { + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + NO, NO) + ID_NEWDBENTRY(id) = NO + ID_NEWFEATURES(id) = NO + } then + if ((ID_NFEATURES(id) > 0) || (ID_CV(id) != NULL)) + ID_NEWDBENTRY(id) = YES + } + ID_NEWCV(id) = YES + ID_NEWGRAPH(id) = YES + wy = INDEF + } + + # Refit dispersion function + if (ID_REFIT(id) == YES) { + call id_dofit (id, NO) + ID_REFIT(id) = NO + } + + # If there is a new dispersion solution evaluate the coordinates + if (ID_NEWCV(id) == YES) { + iferr (call id_fitdata (id)) + ; + call id_fitfeatures (id) + ID_NEWCV(id) = NO + } + + # Draw new graph in zoom mode if current feature has changed. + if ((ID_GTYPE(id) == ZOOM) && (last != ID_CURRENT(id))) + ID_NEWGRAPH(id) = YES + + # Draw new graph. + if (ID_NEWGRAPH(id) == YES) { + call id_graph (id, ID_GTYPE(id)) + ID_NEWGRAPH(id) = NO + } + + # Set cursor and print status of current feature (unless canceled). + if (ID_CURRENT(id) > 0) { + if (IS_INDEF (wy)) { + i = max (1, min (ID_NPTS(id), int (PIX(id,ID_CURRENT(id))))) + wy = IMDATA(id,i) + } + + call gscur (ID_GP(id), real (FIT(id,ID_CURRENT(id))), wy) + if (errcode() == OK && prfeature == YES) { + i = ID_CURRENT(id) + pix = PIX(id,i) + fit = FIT(id,i) + user = USER(id,i) + if (ID_TASK(id) == IDENTIFY) { + if (IS_INDEFD(user)) + shift = INDEF + else + shift = fit - user + call printf ("%10.2f %10.8g %10.8g %10.3g %s") + call pargd (pix) + call pargd (fit) + call pargd (user) + call pargd (shift) + label = Memi[ID_LABEL(id)+i-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + } else { + if (IS_INDEFD(user)) + shift = INDEF + else { + shift = id_zval (id, fit, user) - ID_REDSHIFT(id) + if (abs (shift) < 0.01) + shift = shift * VLIGHT + } + call printf ("%10.2f %10.8g %10.8g %10.8g %10.3g %s") + call pargd (pix) + call pargd (fit) + call pargd (id_zshiftd (id, fit, 0)) + call pargd (user) + if (IS_INDEFD(user)) + call pargd (INDEFD) + else + call pargd (shift) + label = Memi[ID_LABEL(id)+i-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + } + } + } + + # Print delayed error message + if (errcode() != OK) + call erract (EA_WARN) + + last = ID_CURRENT(id) + } until (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) + call gclose (ID_GP(id)) + + # Write velocity logfile. + if (ID_TASK(id) == RVIDLINES) { + call clgstr ("logfile", cmd, SZ_LINE) + if (nowhite (cmd, cmd, SZ_LINE) == 0) + answer = false + else + answer = true + if (answer && !clgetb ("autowrite")) { + call printf ("Write velocity data to the logfile (yes)? ") + call flush (STDOUT) + if (scan() != EOF) + call gargb (answer) + } + if (answer) { + iferr { + if (ID_NID(id) == 0) + call id_log (id, cmd, NULL) + else { + call id_saveid (id, ID_LINE(id,1)) + for (i = 0; i < ID_NID(id); i = i + 1) { + j = Memi[ID_ID(id)+i] + j =id_gid (id, ID_LINE(j,1)) + call id_dbsection (id, Memc[ID_IMAGE(id)], + ID_AP(id,1), Memc[ID_SECTION(id)], + SZ_FNAME) + call id_log (id, cmd, NULL) + } + } + } then + call erract (EA_WARN) + } + } + + # Warn user that feature data is newer than database entry. + if (ID_NEWDBENTRY(id) == YES) + answer = true + else { + answer = false + for (i = 0; i < ID_NID(id); i = i + 1) { + if (ID_NEWDBENTRY(Memi[ID_ID(id)+i]) == YES) { + answer = true + break + } + } + } + if (answer) { + if (!clgetb ("autowrite")) { + call printf ("Write feature data to the database (yes)? ") + call flush (STDOUT) + if (scan() != EOF) + call gargb (answer) + } + if (answer) { + newline[1] = ID_LINE(id,1) + newline[2] = ID_LINE(id,2) + if (ID_NEWDBENTRY(id) == YES) + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + for (i = 0; i < ID_NID(id); i = i + 1) { + j = Memi[ID_ID(id)+i] + if (ID_NEWDBENTRY(j) == YES && + (ID_LINE(j,1)!=newline[1]||ID_LINE(j,2)!=newline[2])) { + j =id_gid (id, ID_LINE(j,1)) + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + NO) + } + } + } + } + + call flush (STDOUT) + + # Free image data. + call mfree (ID_PIXDATA(id), TY_DOUBLE) + call mfree (ID_FITDATA(id), TY_DOUBLE) + call id_free1 (id) + + call smw_close (MW(ID_SH(id))) + call imunmap (IM(ID_SH(id))) + call shdr_close (ID_SH(id)) + + # If a new image was requested with colon command start over. + if (newimage[1] != EOS) { + call strcpy (newimage, Memc[ID_IMAGE(id)], SZ_FNAME) + goto newim_ + } +end diff --git a/noao/rv/rvidlines/idinit.x b/noao/rv/rvidlines/idinit.x new file mode 100644 index 00000000..b17f94a1 --- /dev/null +++ b/noao/rv/rvidlines/idinit.x @@ -0,0 +1,352 @@ +include <gset.h> +include <math/curfit.h> +include "identify.h" + +# ID_INIT -- Allocate identify structure + +procedure id_init (id, taskid) + +int taskid #I Task ID +pointer id #O ID pointer + +begin + call calloc (id, LEN_IDSTRUCT, TY_STRUCT) + + ID_TASK(id) = taskid + ID_NALLOC(id) = 20 + ID_NFEATURES(id) = 0 + ID_CURRENT(id) = 0 + ID_NID(id) = 0 + ID_DT(id) = NULL + + call malloc (ID_IMAGE(id), SZ_FNAME, TY_CHAR) + call malloc (ID_SECTION(id), SZ_FNAME, TY_CHAR) + call malloc (ID_DATABASE(id), SZ_FNAME, TY_CHAR) + call malloc (ID_COORDLIST(id), SZ_FNAME, TY_CHAR) + + call malloc (ID_PIX(id), ID_NALLOC(id), TY_DOUBLE) + call malloc (ID_FIT(id), ID_NALLOC(id), TY_DOUBLE) + call malloc (ID_USER(id), ID_NALLOC(id), TY_DOUBLE) + call malloc (ID_WTS(id), ID_NALLOC(id), TY_DOUBLE) + call malloc (ID_FWIDTHS(id), ID_NALLOC(id), TY_REAL) + call malloc (ID_FTYPES(id), ID_NALLOC(id), TY_INT) + call calloc (ID_LABEL(id), ID_NALLOC(id), TY_POINTER) +end + + +# ID_FREE -- Free identify structure. + +procedure id_free (id) + +pointer id # ID pointer + +int i +pointer ptr + +begin + call mfree (ID_IMAGE(id), TY_CHAR) + call mfree (ID_SECTION(id), TY_CHAR) + call mfree (ID_DATABASE(id), TY_CHAR) + call mfree (ID_COORDLIST(id), TY_CHAR) + call mfree (ID_APS(id), TY_INT) + + ptr = ID_LABEL(id) + do i = 1, ID_NALLOC(id) { + call mfree (Memi[ptr], TY_CHAR) + ptr = ptr + 1 + } + + call mfree (ID_PIX(id), TY_DOUBLE) + call mfree (ID_FIT(id), TY_DOUBLE) + call mfree (ID_USER(id), TY_DOUBLE) + call mfree (ID_WTS(id), TY_DOUBLE) + call mfree (ID_FWIDTHS(id), TY_REAL) + call mfree (ID_FTYPES(id), TY_INT) + call mfree (ID_LABEL(id), TY_POINTER) + + if (ID_DT(id) != NULL) + call dtunmap (ID_DT(id)) + call id_free1 (id) + call id_unmapll (id) + call gt_free (ID_GT(id)) + call dcvfree (ID_CV(id)) + call ic_closed (ID_IC(id)) + + call mfree (id, TY_STRUCT) +end + + +# ID_FREE1 -- Free saved identify structures. + +procedure id_free1 (id) + +pointer id # ID pointer + +int i, j +pointer id1, ptr + +begin + for (i = 0; i < ID_NID(id); i = i + 1) { + id1 = Memi[ID_ID(id)+i] + + ptr = ID_LABEL(id1) + do j = 1, ID_NALLOC(id1) { + call mfree (Memi[ptr], TY_CHAR) + ptr = ptr + 1 + } + + call mfree (ID_PIX(id1), TY_DOUBLE) + call mfree (ID_FIT(id1), TY_DOUBLE) + call mfree (ID_USER(id1), TY_DOUBLE) + call mfree (ID_WTS(id1), TY_DOUBLE) + call mfree (ID_FWIDTHS(id1), TY_REAL) + call mfree (ID_FTYPES(id1), TY_INT) + call mfree (ID_LABEL(id1), TY_POINTER) + if (ID_CV(id1) != NULL) + call dcvfree (ID_CV(id1)) + if (ID_IC(id1) != NULL) + call ic_closed (ID_IC(id1)) + call shdr_close (ID_SH(id1)) + call mfree (id1, TY_STRUCT) + } + call mfree (ID_ID(id), TY_POINTER) + + ID_NID(id) = 0 +end + + +# ID_SAVEID -- Save identify information by line. + +procedure id_saveid (id, line) + +pointer id # IDENTIFY structure +int line[2] # Save as line + +int i +pointer id1 + +begin + # Check if already saved. If not saved allocate memory. + for (i = 1; i <= ID_NID(id); i = i + 1) { + id1 = Memi[ID_ID(id)+i-1] + if (ID_LINE(id1,1) == line[1] && ID_LINE(id1,2) == line[2]) + break + } + + call id_sid (id, i) +end + + + +# ID_SID -- Save identify information by index. + +procedure id_sid (id, n) + +pointer id # IDENTIFY structure +int n # Save as index + +int i, j, dcvstati(), strlen() +pointer sp, id1, coeffs, ptr1, ptr2 + +begin + if (n > ID_NID(id)) { + if (n == 1) + call malloc (ID_ID(id), 1, TY_POINTER) + else + call realloc (ID_ID(id), n, TY_POINTER) + call calloc (id1, LEN_IDSTRUCT, TY_STRUCT) + Memi[ID_ID(id)+n-1] = id1 + ID_NID(id) = n + } else + id1 = Memi[ID_ID(id)+n-1] + + # Allocate or reallocate memory for features and copy them. + if (ID_NFEATURES(id) > 0) { + if (ID_NALLOC(id1) == 0) { + call malloc (ID_PIX(id1), ID_NFEATURES(id), TY_DOUBLE) + call malloc (ID_FIT(id1), ID_NFEATURES(id), TY_DOUBLE) + call malloc (ID_USER(id1), ID_NFEATURES(id), TY_DOUBLE) + call malloc (ID_WTS(id1), ID_NFEATURES(id), TY_DOUBLE) + call malloc (ID_FWIDTHS(id1), ID_NFEATURES(id), TY_REAL) + call malloc (ID_FTYPES(id1), ID_NFEATURES(id), TY_INT) + call calloc (ID_LABEL(id1), ID_NFEATURES(id), TY_POINTER) + } else if (ID_NALLOC(id1) != ID_NFEATURES(id)) { + call realloc (ID_PIX(id1), ID_NFEATURES(id), TY_DOUBLE) + call realloc (ID_FIT(id1), ID_NFEATURES(id), TY_DOUBLE) + call realloc (ID_USER(id1), ID_NFEATURES(id), TY_DOUBLE) + call realloc (ID_WTS(id1), ID_NFEATURES(id), TY_DOUBLE) + call realloc (ID_FWIDTHS(id1), ID_NFEATURES(id), TY_REAL) + call realloc (ID_FTYPES(id1), ID_NFEATURES(id), TY_INT) + call realloc (ID_LABEL(id1), ID_NFEATURES(id), TY_POINTER) + + j = ID_NALLOC(id1) + i = ID_NFEATURES(id) - j + if (i > 0) + call aclri (Memi[ID_LABEL(id1)+j], i) + } + call amovd (PIX(id,1), PIX(id1,1), ID_NFEATURES(id)) + call amovd (FIT(id,1), FIT(id1,1), ID_NFEATURES(id)) + call amovd (USER(id,1), USER(id1,1), ID_NFEATURES(id)) + call amovd (WTS(id,1), WTS(id1,1), ID_NFEATURES(id)) + call amovr (FWIDTH(id,1), FWIDTH(id1,1), ID_NFEATURES(id)) + call amovi (FTYPE(id,1), FTYPE(id1,1), ID_NFEATURES(id)) + + ptr1 = ID_LABEL(id) + ptr2 = ID_LABEL(id1) + do i = 1, ID_NFEATURES(id) { + call mfree (Memi[ptr2], TY_CHAR) + if (Memi[ptr1] != NULL) { + j = strlen (Memc[Memi[ptr1]]) + call malloc (Memi[ptr2], j, TY_CHAR) + call strcpy (Memc[Memi[ptr1]], Memc[Memi[ptr2]], j) + } + ptr1 = ptr1 + 1 + ptr2 = ptr2 + 1 + } + + ID_NALLOC(id1) = ID_NFEATURES(id) + } + + # Use a SAVE and RESTORE to copy the CURFIT data. + if (ID_CV(id1) != NULL) + call dcvfree (ID_CV(id1)) + if (ID_CV(id) != NULL) { + call smark (sp) + i = dcvstati (ID_CV(id), CVNSAVE) + call salloc (coeffs, i, TY_DOUBLE) + call dcvsave (ID_CV(id), Memd[coeffs]) + call dcvrestore (ID_CV(id1), Memd[coeffs]) + call sfree (sp) + + if (ID_IC(id1) == NULL) + call ic_open (ID_IC(id1)) + call ic_copy (ID_IC(id), ID_IC(id1)) + } + + #ID_LINE(id1,1) = line[1] + #ID_LINE(id1,2) = line[2] + ID_LINE(id1,1) = ID_LINE(id,1) + ID_LINE(id1,2) = ID_LINE(id,2) + ID_AP(id1,1) = ID_AP(id,1) + ID_AP(id1,2) = ID_AP(id,2) + ID_NFEATURES(id1) = ID_NFEATURES(id) + ID_SHIFT(id1) = ID_SHIFT(id) + ID_REDSHIFT(id1) = ID_REDSHIFT(id) + ID_RMSRED(id1) = ID_RMSRED(id) + ID_ZHELIO(id1) = ID_ZHELIO(id) + ID_CURRENT(id1) = ID_CURRENT(id) + + ID_NEWFEATURES(id1) = ID_NEWFEATURES(id) + ID_NEWCV(id1) = ID_NEWCV(id) + ID_NEWDBENTRY(id1) = ID_NEWDBENTRY(id) +end + + +# ID_GID -- Get saved identify information for specified line. + +int procedure id_gid (id, line) + +pointer id # IDENTIFY structure +int line[2] # Line number to get + +int i, id_getid() + +begin + # Check if saved. + for (i = 1; i <= ID_NID(id); i = i + 1) { + if (ID_LINE(Memi[ID_ID(id)+i-1],1) == line[1] && + ID_LINE(Memi[ID_ID(id)+i-1],2) == line[2]) + break + } + + return (id_getid (id, i)) +end + + +# ID_GETID -- Get saved identify information for specified index. + +int procedure id_getid (id, n) + +pointer id # IDENTIFY structure +int n # Index of saved features to be returned + +int i, j, dcvstati(), strlen() +pointer sp, id1, coeffs, ptr1, ptr2 + +begin + if (n < 1 || n > ID_NID(id)) + return (EOF) + + id1 = Memi[ID_ID(id)+n-1] + + # Reallocate memory for features and copy them. + if (ID_NFEATURES(id1) > 0) { + if (ID_NALLOC(id1) != ID_NALLOC(id)) { + call realloc (ID_PIX(id), ID_NALLOC(id1), TY_DOUBLE) + call realloc (ID_FIT(id), ID_NALLOC(id1), TY_DOUBLE) + call realloc (ID_USER(id), ID_NALLOC(id1), TY_DOUBLE) + call realloc (ID_WTS(id), ID_NALLOC(id1), TY_DOUBLE) + call realloc (ID_FWIDTHS(id), ID_NALLOC(id1), TY_REAL) + call realloc (ID_FTYPES(id), ID_NALLOC(id1), TY_INT) + call realloc (ID_LABEL(id), ID_NALLOC(id1), TY_POINTER) + + j = ID_NALLOC(id) + i = ID_NALLOC(id1) - j + if (i > 0) + call aclri (Memi[ID_LABEL(id)+j], i) + } + call amovd (PIX(id1,1), PIX(id,1), ID_NFEATURES(id1)) + call amovd (FIT(id1,1), FIT(id,1), ID_NFEATURES(id1)) + call amovd (USER(id1,1), USER(id,1), ID_NFEATURES(id1)) + call amovd (WTS(id1,1), WTS(id,1), ID_NFEATURES(id1)) + call amovr (FWIDTH(id1,1), FWIDTH(id,1), ID_NFEATURES(id1)) + call amovi (FTYPE(id1,1), FTYPE(id,1), ID_NFEATURES(id1)) + + ptr1 = ID_LABEL(id1) + ptr2 = ID_LABEL(id) + do i = 1, ID_NFEATURES(id1) { + call mfree (Memi[ptr2], TY_CHAR) + if (Memi[ptr1] != NULL) { + j = strlen (Memc[Memi[ptr1]]) + call malloc (Memi[ptr2], j, TY_CHAR) + call strcpy (Memc[Memi[ptr1]], Memc[Memi[ptr2]], j) + } + ptr1 = ptr1 + 1 + ptr2 = ptr2 + 1 + } + + ID_NALLOC(id) = ID_NALLOC(id1) + ID_NFEATURES(id) = ID_NFEATURES(id1) + ID_NEWFEATURES(id) = ID_NEWFEATURES(id1) + ID_CURRENT(id) = ID_CURRENT(id1) + ID_NEWDBENTRY(id) = ID_NEWDBENTRY(id1) + } + + # Use a SAVE and RESTORE to copy the CURFIT data. + if (ID_CV(id1) != NULL) { + if (ID_CV(id) != NULL) + call dcvfree (ID_CV(id)) + call smark (sp) + i = dcvstati (ID_CV(id1), CVNSAVE) + call salloc (coeffs, i, TY_DOUBLE) + call dcvsave (ID_CV(id1), Memd[coeffs]) + call dcvrestore (ID_CV(id), Memd[coeffs]) + call sfree (sp) + + call ic_copy (ID_IC(id1), ID_IC(id)) + + ID_SHIFT(id) = ID_SHIFT(id1) + ID_REDSHIFT(id) = ID_REDSHIFT(id1) + ID_RMSRED(id) = ID_RMSRED(id1) + ID_ZHELIO(id) = ID_ZHELIO(id1) + ID_NEWCV(id) = ID_NEWCV(id1) + ID_NEWDBENTRY(id) = ID_NEWDBENTRY(id1) + } + + ID_LINE(id,1) = ID_LINE(id1,1) + ID_LINE(id,2) = ID_LINE(id1,2) + ID_AP(id,1) = ID_AP(id1,1) + ID_AP(id,2) = ID_AP(id1,2) + + return (OK) +end diff --git a/noao/rv/rvidlines/idlabel.x b/noao/rv/rvidlines/idlabel.x new file mode 100644 index 00000000..cb5fa439 --- /dev/null +++ b/noao/rv/rvidlines/idlabel.x @@ -0,0 +1,30 @@ +define SKIP ($1==' '||$1=='\t'||$1=='"'||$1=='\'') + +# ID_LABEL -- Set label + +procedure id_label (str, label) + +char str[ARB] # String to be set +pointer label # Label pointer to be set + +int i, j, strlen() +pointer cp + +begin + call mfree (label, TY_CHAR) + + for (i=1; str[i]!=EOS && SKIP(str[i]); i=i+1) + ; + for (j=strlen(str); j>=i && SKIP(str[j]); j=j-1) + ; + + if (i <= j) { + call malloc (label, j-i+1, TY_CHAR) + cp = label + for (; i<=j; i=i+1) { + Memc[cp] = str[i] + cp = cp + 1 + } + Memc[cp] = EOS + } +end diff --git a/noao/rv/rvidlines/idlinelist.x b/noao/rv/rvidlines/idlinelist.x new file mode 100644 index 00000000..d427aad7 --- /dev/null +++ b/noao/rv/rvidlines/idlinelist.x @@ -0,0 +1,250 @@ +include <error.h> +include <mach.h> +include "identify.h" + +# ID_MAPLL -- Read the line list into memory. + +procedure id_mapll (id) + +pointer id # Identify structure + +int fd, nalloc, nlines +pointer ll1, ll2, str + +int open(), fscan(), nscan(), nowhite() +double value + +errchk open, fscan, malloc, realloc + +begin + ID_LL(id) = NULL + + if (nowhite (Memc[ID_COORDLIST(id)], + Memc[ID_COORDLIST(id)], SZ_FNAME) == 0) + return + iferr (fd = open (Memc[ID_COORDLIST(id)], READ_ONLY, TEXT_FILE)) { + call erract (EA_WARN) + return + } + + call malloc (str, SZ_LINE, TY_CHAR) + nalloc = 0 + nlines = 0 + while (fscan (fd) != EOF) { + call gargd (value) + if (nscan() != 1) + next + + if (nalloc == 0) { + nalloc = 100 + call malloc (ll1, nalloc, TY_DOUBLE) + call calloc (ll2, nalloc, TY_POINTER) + } else if (nlines == nalloc) { + nalloc = nalloc + 100 + call realloc (ll1, nalloc, TY_DOUBLE) + call realloc (ll2, nalloc, TY_POINTER) + call aclri (Memi[ll2+nalloc-100], 100) + } + + Memd[ll1+nlines] = value + call gargstr (Memc[str], SZ_LINE) + call id_label (Memc[str], Memi[ll2+nlines]) + + nlines = nlines + 1 + } + call mfree (str, TY_CHAR) + call close (fd) + + if (nlines == 0) + return + + call realloc (ll1, nlines + 1, TY_DOUBLE) + call realloc (ll2, nlines + 1, TY_POINTER) + Memd[ll1+nlines] = INDEFD + call malloc (ID_LL(id), 2, TY_POINTER) + Memi[ID_LL(id)] = ll1 + Memi[ID_LL(id)+1] = ll2 +end + + +# ID_UNMAPLL -- Unmap the linelist. + +procedure id_unmapll (id) + +pointer id # Identify structure + +pointer ll1, ll2 + +begin + if (ID_LL(id) == NULL) + return + + ll1 = Memi[ID_LL(id)] + ll2 = Memi[ID_LL(id)+1] + while (!IS_INDEFD(Memd[ll1])) { + call mfree (Memi[ll2], TY_CHAR) + ll1 = ll1 + 1 + ll2 = ll2 + 1 + } + + call mfree (Memi[ID_LL(id)], TY_DOUBLE) + call mfree (Memi[ID_LL(id)+1], TY_POINTER) + call mfree (ID_LL(id), TY_POINTER) +end + + + +# ID_MATCH -- Match current feature against a line list. +# +# This is extremely inefficient. It can be greatly improved. + +procedure id_match (id, in, out, label, diff) + +pointer id # Identify structure +double in # Coordinate to be matched +double out # Matched coordinate +pointer label # Pointer to label +real diff # Maximum difference + +double zin, delta, deltamin, id_zshiftd() +pointer ll1, ll2, tmp +int strlen() + +begin + if (ID_LL(id) == NULL) { + out = id_zshiftd (id, in, 0) + label = NULL + return + } + + zin = id_zshiftd (id, in, 0) + deltamin = MAX_REAL + + ll1 = Memi[ID_LL(id)] + ll2 = Memi[ID_LL(id)+1] + while (!IS_INDEFD(Memd[ll1])) { + delta = abs (zin - Memd[ll1]) + if (delta < deltamin) { + deltamin = delta + if (deltamin <= diff) { + out = Memd[ll1] + label = Memi[ll2] + } + } + ll1 = ll1 + 1 + ll2 = ll2 + 1 + } + + if (label != NULL) { + call malloc (tmp, strlen (Memc[label]), TY_CHAR) + call strcpy (Memc[label], Memc[tmp], ARB) + label = tmp + } +end + +# ID_LINELIST -- Add features from a line list. + +procedure id_linelist (id) + +pointer id # Identify structure + +int i, nfound, nextpix, lastpix, cursave +double pix, fit, fit1, fit2, user, peak, minval, diff, diff1 +pointer sp, pixes, fits, users, labels, ll1, ll2, label + +double id_center(), fit_to_pix(), id_fitpt(), id_peak(), id_zshiftd() + +begin + if (ID_LL(id) == NULL) + return + + call smark (sp) + call salloc (pixes, ID_MAXFEATURES(id), TY_DOUBLE) + call salloc (fits, ID_MAXFEATURES(id), TY_DOUBLE) + call salloc (users, ID_MAXFEATURES(id), TY_DOUBLE) + call salloc (labels, ID_MAXFEATURES(id), TY_POINTER) + + nfound = 0 + lastpix = 0 + minval = MAX_REAL + + fit1 = min (FITDATA(id,1), FITDATA(id,ID_NPTS(id))) + fit2 = max (FITDATA(id,1), FITDATA(id,ID_NPTS(id))) + ll1 = Memi[ID_LL(id)] + ll2 = Memi[ID_LL(id)+1] + while (!IS_INDEFD(Memd[ll1])) { + user = id_zshiftd (id, Memd[ll1], 1) + label = Memi[ll2] + ll1 = ll1 + 1 + ll2 = ll2 + 1 + if (user < fit1) + next + if (user > fit2) + break + + pix = id_center (id, fit_to_pix (id, user), 1, ID_FWIDTH(id), + ID_FTYPE(id), NO) + if (!IS_INDEFD(pix)) { + fit = id_fitpt (id, pix) + diff = abs (fit - user) + if (diff > ID_MATCH(id)) + next + if (lastpix > 0) { + if (abs (pix - Memd[pixes+lastpix-1]) < 0.01) { + diff1 = abs (Memd[fits+lastpix-1]-Memd[users+lastpix-1]) + if (diff < diff1) { + Memd[pixes+lastpix-1] = pix + Memd[fits+lastpix-1] = fit + Memd[users+lastpix-1] = id_zshiftd (id, user, 0) + Memi[labels+lastpix-1] = label + } + next + } + } + + peak = abs (id_peak (id, pix)) + if (nfound < ID_MAXFEATURES(id)) { + nfound = nfound + 1 + if (peak < minval) { + nextpix = nfound + minval = peak + } + Memd[pixes+nfound-1] = pix + Memd[fits+nfound-1] = id_fitpt (id, pix) + Memd[users+nfound-1] = id_zshiftd (id, user, 0) + Memi[labels+nfound-1] = label + lastpix = nfound + } else if (peak > minval) { + Memd[pixes+nextpix-1] = pix + Memd[fits+nextpix-1] = id_fitpt (id, pix) + Memd[users+nextpix-1] = id_zshiftd (id, user, 0) + Memi[labels+nextpix-1] = label + lastpix = nextpix + + minval = MAX_REAL + do i = 1, nfound { + pix = Memd[pixes+i-1] + peak = abs (id_peak (id, pix)) + if (peak < minval) { + nextpix = i + minval = peak + } + } + } + } + } + + do i = 1, nfound { + pix = Memd[pixes+i-1] + fit = Memd[fits+i-1] + user = Memd[users+i-1] + label = Memi[labels+i-1] + call id_newfeature (id, pix, fit, user, 1.0D0, ID_FWIDTH(id), + ID_FTYPE(id), label) + if (i == 1) + cursave = ID_CURRENT(id) + } + ID_CURRENT(id) = cursave + + call sfree (sp) +end diff --git a/noao/rv/rvidlines/idlog.x b/noao/rv/rvidlines/idlog.x new file mode 100644 index 00000000..58645fc1 --- /dev/null +++ b/noao/rv/rvidlines/idlog.x @@ -0,0 +1,190 @@ +include <smw.h> +include <time.h> +include "identify.h" + + +# ID_LOG -- Write log + +procedure id_log (id, file, logfd) + +pointer id # ID pointer +char file[ARB] # Log file +int logfd # Log fd + +char str[SZ_TIME] +int i, fd, nrms +double z, zrms, zerr, zhelio, resid, rms, v, verr, vhelio, hjd + +int open() +double id_zshiftd(), id_zval() +long clktime() +errchk open, id_velocity, id_vhelio + +begin + if (ID_NFEATURES(id) == 0) + return + + if (logfd == NULL) + fd = open (file, APPEND, TEXT_FILE) + else + fd = logfd + + if (ID_TASK(id) == IDENTIFY) { + + call cnvtime (clktime (0), str, SZ_TIME) + call fprintf (fd, "\n%s\n") + call pargstr (str) + call fprintf (fd, "Features identified in image %s%s: %s\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargstr (TITLE(ID_SH(id))) + + call fprintf (fd, " %8s %10s %10s %10s %5s %s\n") + call pargstr ("Pixel") + call pargstr ("Fit") + call pargstr ("User") + call pargstr ("Residual") + call pargstr ("Fwidth") + call pargstr ("Wt") + call pargstr ("Label") + + rms = 0. + nrms = 0 + do i = 1, ID_NFEATURES(id) { + call fprintf (fd, + "%2d %8.2f %10.8g %10.8g %10.4g %4f %s\n") + call pargi (i) + call pargd (PIX(id,i)) + call pargd (FIT(id,i)) + call pargd (USER(id,i)) + if (IS_INDEFD (USER(id,i))) + call pargd (USER(id,i)) + else { + resid = FIT(id,i) - USER(id,i) + call pargd (resid) + if (WTS(id,i) > 0.) { + rms = rms + resid ** 2 + nrms = nrms + 1 + } + } + call pargd (WTS(id,i)) + if (Memi[ID_LABEL(id)+i-1] != NULL) + call pargstr (Memc[Memi[ID_LABEL(id)+i-1]]) + else + call pargstr ("") + } + + if (nrms > 1) { + call fprintf (fd, "RMS = %0.6g\n") + call pargd (sqrt (rms / nrms)) + } + + } else { + call id_velocity (id, NO) + z = ID_REDSHIFT(id) + zrms = ID_RMSRED(id) + zhelio = ID_ZHELIO(id) + v = ID_REDSHIFT(id) * VLIGHT + call id_vhelio (IM(ID_SH(id)), vhelio, hjd, fd) + + call cnvtime (clktime (0), str, SZ_TIME) + call fprintf (fd, "\n%s\n") + call pargstr (str) + call fprintf (fd, "Features identified in image %s%s: %s\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargstr (TITLE(ID_SH(id))) + + call fprintf (fd, "%10s %10s %10s %10s %10s %5s %s\n") + call pargstr ("Measured") + call pargstr ("User") + call pargstr ("Residual") + call pargstr ("Velocity") + call pargstr ("Residual") + call pargstr ("Wt") + call pargstr ("Label") + + rms = 0. + nrms = 0 + do i = 1, ID_NFEATURES(id) { + call fprintf (fd, + "%10.8g %10.8g %10.4g %10.8g %10.4g %4f %s\n") + call pargd (id_zshiftd (id, FIT(id,i), 0)) + if (IS_INDEFD (USER(id,i))) { + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (USER(id,i)) + resid = id_zshiftd (id, FIT(id,i), 0) - USER(id,i) + call pargd (resid) + if (WTS(id,i) > 0.) { + rms = rms + resid ** 2 + nrms = nrms + 1 + } + verr = id_zval (id, FIT(id,i), USER(id,i)) * VLIGHT + call pargd (verr + vhelio) + call pargd (verr - v) + } + call pargd (WTS(id,i)) + if (Memi[ID_LABEL(id)+i-1] != NULL) + call pargstr (Memc[Memi[ID_LABEL(id)+i-1]]) + else + call pargstr ("") + } + + if (nrms > 1) { + call fprintf (fd, "Wavelength RMS = %0.6g\n") + call pargd (sqrt (rms / nrms)) + call fprintf (fd, "Velocity RMS = %8.5g\n") + call pargd (zrms * VLIGHT) + } + + zerr = zrms + if (nrms > 1) + zerr = zerr / sqrt (nrms - 1.) + v = z * VLIGHT + verr = zerr * VLIGHT + + call fprintf (fd, "\n") + call fprintf (fd, "%s %3d : Zobs = %10.5g, ") + call pargstr (Memc[ID_IMAGE(id)]) + call pargi (ID_AP(id,1)) + call pargd (z) + call fprintf (fd, "Mean err = %10.5g, Lines = %3d\n") + call pargd (zerr) + call pargi (nrms) + call fprintf (fd, "%s %3d : Vobs = %8.5g km/s, ") + call pargstr (Memc[ID_IMAGE(id)]) + call pargi (ID_AP(id,1)) + call pargd (v) + call fprintf (fd, "Mean err = %8.5g km/s, Lines = %3d\n") + call pargd (verr) + call pargi (nrms) + if (zhelio != 0D0) { + call fprintf (fd, "%s %3d : Zhelio = %10.5g, ") + call pargstr (Memc[ID_IMAGE(id)]) + call pargi (ID_AP(id,1)) + call pargd (z + zhelio) + call fprintf (fd, "Mean err = %8.5g km/s, Lines = %3d\n") + call pargd (zerr) + call pargi (nrms) + call fprintf (fd, "%s %3d : Vhelio = %8.5g km/s, ") + call pargstr (Memc[ID_IMAGE(id)]) + call pargi (ID_AP(id,1)) + call pargd (v + vhelio) + call fprintf (fd, "Mean err = %8.5g km/s, Lines = %3d\n") + call pargd (verr) + call pargi (nrms) + call fprintf (fd, "%s %3d : HJD = %g\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargi (ID_AP(id,1)) + call pargd (hjd) + } + call fprintf (fd, "\n") + } + + if (logfd == NULL) + call close (fd) +end diff --git a/noao/rv/rvidlines/idmap.x b/noao/rv/rvidlines/idmap.x new file mode 100644 index 00000000..5af57217 --- /dev/null +++ b/noao/rv/rvidlines/idmap.x @@ -0,0 +1,379 @@ +include <ctype.h> +include <imhdr.h> +include <pkg/gtools.h> +include <smw.h> +include "identify.h" + +# Sepcial section words. +define SPECIAL "|first|middle|x|y|z|last|column|line|band|" +define FIRST 1 +define MIDDLE 2 +define X 3 +define Y 4 +define Z 5 +define LAST 6 +define COLUMN 7 +define LINE 8 +define BAND 9 + +# ID_MAP -- Map an image for IDENTIFY/REIDENTIFY +# The image must 1, 2, or 3 dimensional. An image section may be given with +# the image name or with the CL parameter "section". The CL parameter can +# have one of the following formats: +# 1. An IMIO image section +# 2. [line|column|x|y|z] [#|middle|last] [#|middle|last] +# 3. [#|middle|last] [#|middle|last] [line|column|x|y|z] +# where # is a line or column number. The strings may be abbreviated. +# The task returns and error if it cannot map the image or determine +# the 1D line or column desired. + +procedure id_map (id) + +pointer id # IDENTIFY data structure pointer + +int i, j, k, l, a, b, c, x1[3], x2[3], xs[3] +pointer sp, wrd1, wrd2, wrd3, im + +int imaccess(), strdic(), ctoi(), nscan() +pointer immap() +errchk immap, id_maphdr + +begin + # Separate the image name and image section and map the full image. + call imgsection (Memc[ID_IMAGE(id)], Memc[ID_SECTION(id)], SZ_FNAME) + call imgimage (Memc[ID_IMAGE(id)], Memc[ID_IMAGE(id)], SZ_FNAME) + call id_noextn (Memc[ID_IMAGE(id)]) + im = immap (Memc[ID_IMAGE(id)], READ_ONLY, 0) + + # If no image section is found use the "section" parameter. + if (Memc[ID_SECTION(id)] == EOS && IM_NDIM(im) > 1) { + call clgstr ("section", Memc[ID_SECTION(id)], SZ_FNAME) + call xt_stripwhite (Memc[ID_SECTION(id)]) + + # If not an image section construct one. + if (Memc[ID_SECTION(id)] != '[') { + call smark (sp) + call salloc (wrd1, SZ_FNAME, TY_CHAR) + call salloc (wrd2, SZ_FNAME, TY_CHAR) + call salloc (wrd3, SZ_FNAME, TY_CHAR) + + call sscan (Memc[ID_SECTION(id)]) + + # Parse axis and elements. + call gargwrd (Memc[wrd1], SZ_FNAME) + call gargwrd (Memc[wrd2], SZ_FNAME) + call gargwrd (Memc[wrd3], SZ_FNAME) + switch (nscan()) { + case 0: + a = X + b = MIDDLE + c = MIDDLE + case 1: + a = strdic (Memc[wrd1], Memc[wrd1], SZ_FNAME, SPECIAL) + b = MIDDLE + c = MIDDLE + case 2: + a = strdic (Memc[wrd1], Memc[wrd1], SZ_FNAME, SPECIAL) + if (a >= X) + b = strdic (Memc[wrd2], Memc[wrd2], SZ_FNAME, SPECIAL) + else { + b = a + a = strdic (Memc[wrd2], Memc[wrd2], SZ_FNAME, SPECIAL) + call strcpy (Memc[wrd1], Memc[wrd2], SZ_FNAME) + } + c = MIDDLE + call strcpy (Memc[wrd2], Memc[wrd3], SZ_FNAME) + case 3: + a = strdic (Memc[wrd1], Memc[wrd1], SZ_FNAME, SPECIAL) + if (a >= X) { + b = strdic (Memc[wrd2], Memc[wrd2], SZ_FNAME, SPECIAL) + c = strdic (Memc[wrd3], Memc[wrd3], SZ_FNAME, SPECIAL) + } else { + b = a + a = strdic (Memc[wrd2], Memc[wrd2], SZ_FNAME, SPECIAL) + if (a >= X) { + c = strdic (Memc[wrd3], Memc[wrd3],SZ_FNAME,SPECIAL) + call strcpy (Memc[wrd1], Memc[wrd2], SZ_FNAME) + } else { + c = b + b = a + a = strdic (Memc[wrd3], Memc[wrd3],SZ_FNAME,SPECIAL) + call strcpy (Memc[wrd2], Memc[wrd3], SZ_FNAME) + call strcpy (Memc[wrd1], Memc[wrd2], SZ_FNAME) + } + } + } + + switch (a) { + case X, LINE: + i = 1 + j = 2 + k = 3 + case Y, COLUMN: + i = 2 + j = 1 + k = 3 + case Z, BAND: + i = 3 + j = 1 + k = 2 + default: + call imunmap (im) + call error (1, + "Error in section specification or non-unique abbreviation") + } + + switch (b) { + case FIRST: + ID_LINE(id,1) = 1 + case MIDDLE: + ID_LINE(id,1) = (1 + IM_LEN(im,j)) / 2 + case LAST: + ID_LINE(id,1) = IM_LEN(im,j) + default: + l = 1 + if (ctoi (Memc[wrd2], l, ID_LINE(id,1)) == 0) + call error (1, "Error in section specification") + } + + switch (c) { + case FIRST: + ID_LINE(id,2) = 1 + case MIDDLE: + ID_LINE(id,2) = (1 + IM_LEN(im,k)) / 2 + case LAST: + ID_LINE(id,2) = IM_LEN(im,k) + default: + l = 1 + if (ctoi (Memc[wrd3], l, ID_LINE(id,2)) == 0) + call error (1, "Error in section specification") + } + + # Format section. + switch (IM_NDIM(im)) { + case 2: + switch (i) { + case 1: + call sprintf (Memc[ID_SECTION(id)], SZ_FNAME, "[*,%d]") + case 2: + call sprintf (Memc[ID_SECTION(id)], SZ_FNAME, "[%d,*]") + default: + call error (1, "Error in section specification") + } + call pargi (ID_LINE(id,1)) + case 3: + switch (i) { + case 1: + call sprintf (Memc[ID_SECTION(id)],SZ_FNAME,"[*,%d,%d]") + case 2: + call sprintf (Memc[ID_SECTION(id)],SZ_FNAME,"[%d,*,%d]") + case 3: + call sprintf (Memc[ID_SECTION(id)],SZ_FNAME,"[%d,%d,*]") + } + call pargi (ID_LINE(id,1)) + call pargi (ID_LINE(id,2)) + case 4: + call error (1, "Image dimension greater than 3 not allowed") + } + + call sfree (sp) + } + } + + # Parse the image section. + x1[1] = 1; x2[1] = IM_LEN(im,1); xs[1] = 1 + x1[2] = 1; x2[2] = IM_LEN(im,2); xs[2] = 1 + x1[3] = 1; x2[3] = IM_LEN(im,3); xs[3] = 1 + call id_section (Memc[ID_SECTION(id)], x1, x2, xs, 3) + + # Set the axes. The axis to be identified is the longest one. + i = 1 + if (IM_NDIM(im) > 1 && abs (x1[2]-x2[2]) >= abs (x1[i]-x2[i])) + i = 2 + if (IM_NDIM(im) > 2 && abs (x1[3]-x2[3]) >= abs (x1[i]-x2[i])) + i = 3 + if (IM_NDIM(im) > 3) + call error (1, "Image dimension greater than 3 not allowed") + + switch (i) { + case 1: + j = 2 + k = 3 + case 2: + j = 1 + k = 3 + case 3: + j = 1 + k = 2 + } + + ID_LINE(id,1) = (x1[j] + x2[j]) / 2 + ID_LINE(id,2) = (x1[k] + x2[k]) / 2 + ID_MAXLINE(id,1) = IM_LEN(im, j) + ID_MAXLINE(id,2) = IM_LEN(im, k) + ID_NSUM(id,1) = min (ID_MAXLINE(id,1), ID_NSUM(id,1)) + ID_NSUM(id,2) = min (ID_MAXLINE(id,2), ID_NSUM(id,2)) + call smw_daxis (NULL, NULL, i, ID_NSUM(id,1), ID_NSUM(id,2)) + + call id_maphdr (id, im) + + # Open the image READ_WRITE if possible in order to add REFSPEC. + # This is not done earlier to avoid updating of the WCS. + + call imunmap (im) + if (imaccess (Memc[ID_IMAGE(id)], READ_WRITE) == YES) + im = immap (Memc[ID_IMAGE(id)], READ_WRITE, 0) + else + im = immap (Memc[ID_IMAGE(id)], READ_ONLY, 0) + IM(ID_SH(id)) = im +end + + +# ID_MAPHDR -- Map image header. + +procedure id_maphdr (id, im) + +pointer id # ID pointer +pointer im # IMIO pointer + +int i +pointer mw, sh, smw_openim(), smw_sctran() +errchk smw_openim(), shdr_open(), smw_sctran + +begin + mw = smw_openim (im) + if (SMW_TRANS(mw) == YES) { + if (SMW_PAXIS(mw,1) == 1) + call smw_daxis (mw, im, 2, INDEFI, INDEFI) + else + call smw_daxis (mw, im, 1, INDEFI, INDEFI) + call smw_saxes (mw, NULL, im) + } + call shdr_open (im, mw, ID_LINE(id,1), ID_LINE(id,2), + INDEFI, SHHDR, ID_SH(id)) + sh = ID_SH(id) + + if (SMW_FORMAT(mw) == SMW_MS || SMW_FORMAT(mw) == SMW_ES) { + ID_MAXLINE(id,1) = IM_LEN(im,2) + ID_MAXLINE(id,2) = IM_LEN(im,3) + ID_NSUM(id,1) = 1 + ID_NSUM(id,2) = 1 + ID_LINE(id,1) = max (1, min (ID_MAXLINE(id,1), ID_LINE(id,1))) + ID_LINE(id,2) = 1 + call mfree (ID_APS(id), TY_INT) + call malloc (ID_APS(id), ID_MAXLINE(id,1), TY_INT) + do i = 1, ID_MAXLINE(id,1) { + call shdr_open (im, mw, i, 1, INDEFI, SHHDR, sh) + Memi[ID_APS(id)+i-1] = AP(sh) + } + ID_AP(id,1) = Memi[ID_APS(id)+ID_LINE(id,1)-1] + ID_AP(id,2) = 1 + } else { + call mfree (ID_APS(id), TY_INT) + ID_AP(id,1) = ID_LINE(id,1) + ID_AP(id,2) = ID_LINE(id,2) + } + ID_NPTS(id) = IM_LEN(im, SMW_LAXIS(mw,1)) + + call gt_sets (ID_GT(id), GTXLABEL, LABEL(sh)) + call ic_pstr (ID_IC(id), "ylabel", LABEL(sh)) + call gt_sets (ID_GT(id), GTXUNITS, UNITS(sh)) + call ic_pstr (ID_IC(id), "yunits", UNITS(sh)) + + # Set logical / physical transformations + i = 2 ** (SMW_PAXIS(mw,1) - 1) + ID_LP(id) = smw_sctran (mw, "logical", "physical", i) + ID_PL(id) = smw_sctran (mw, "physical", "logical", i) +end + + +# ID_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 id_section (section, x1, x2, xs, ndim) + +char section[ARB] # Image section +int x1[ndim] # Starting pixel +int x2[ndim] # Ending pixel +int xs[ndim] # Step +int ndim # Number of dimensions + +int i, ip, a, b, c, temp, ctoi() +define error_ 99 + +begin + # Decode the section string. + ip = 1 + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == '[') + ip = ip + 1 + else if (section[ip] == EOS) + return + else + goto error_ + + do i = 1, ndim { + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == ']') + break + + # Default values + a = x1[i] + b = x2[i] + c = xs[i] + + # Get a:b:c. Allow notation such as "-*:c" + # (or even "-:c") where the step is obviously negative. + + if (ctoi (section, ip, temp) > 0) { # a + a = temp + if (section[ip] == ':') { + ip = ip + 1 + if (ctoi (section, ip, b) == 0) # a:b + goto error_ + } else + b = a + } else if (section[ip] == '-') { # -* + temp = a + a = b + b = temp + ip = ip + 1 + if (section[ip] == '*') + ip = ip + 1 + } else if (section[ip] == '*') # * + ip = ip + 1 + if (section[ip] == ':') { # ..:step + ip = ip + 1 + if (ctoi (section, ip, c) == 0) + goto error_ + else if (c == 0) + goto error_ + } + if (a > b && c > 0) + c = -c + + x1[i] = a + x2[i] = b + xs[i] = c + + while (IS_WHITE(section[ip])) + ip = ip + 1 + if (section[ip] == ',') + ip = ip + 1 + } + + if (section[ip] != ']') + goto error_ + + return +error_ + call error (0, "Error in image section specification") +end diff --git a/noao/rv/rvidlines/idmark.x b/noao/rv/rvidlines/idmark.x new file mode 100644 index 00000000..8f874560 --- /dev/null +++ b/noao/rv/rvidlines/idmark.x @@ -0,0 +1,97 @@ +include <gset.h> +include <smw.h> +include "identify.h" + +procedure id_mark (id, feature) + +pointer id # ID pointer +int feature + +int pix, color, gstati() +real x, y +real mx, my, x1, x2, y1, y2, tick, gap +pointer sp, format, label, ptr +double smw_c1trand() + +define TICK .03 # Tick size in NDC +define GAP .02 # Gap size in NDC + +begin + call ggwind (ID_GP(id), x1, x2, y1, y2) + + x = FIT(id,feature) + + if ((x < min (x1, x2)) || (x > max (x1, x2))) + return + + pix = smw_c1trand (ID_PL(id), PIX(id,feature)) - NP1(ID_SH(id)) + 1 + pix = max (1, min (pix, ID_NPTS(id)-1)) + + call smark (sp) + call salloc (format, SZ_LINE, TY_CHAR) + call salloc (label, SZ_LINE, TY_CHAR) + switch (FTYPE(id,feature)) { + case EMISSION, GEMISSION: + y = max (IMDATA(id,pix), IMDATA(id,pix+1)) + tick = TICK + gap = GAP + call strcpy ("u=180;h=c;v=b;s=0.5", Memc[format], SZ_LINE) + case ABSORPTION, GABSORPTION: + y = min (IMDATA(id,pix), IMDATA(id,pix+1)) + tick = -TICK + gap = -GAP + call strcpy ("u=0;h=c;v=t;s=0.5", Memc[format], SZ_LINE) + } + + call gctran (ID_GP(id), x, y, mx, my, 1, 0) + call gctran (ID_GP(id), mx, my + gap, x1, y1, 0, 1) + call gctran (ID_GP(id), mx, my + gap + tick, x1, y2, 0, 1) + color = gstati (ID_GP(id), G_PLCOLOR) + call gseti (ID_GP(id), G_PLCOLOR, color+1) + call gline (ID_GP(id), x1, y1, x1, y2) + call gseti (ID_GP(id), G_PLCOLOR, color) + + call gctran (ID_GP(id), mx, my + tick + 2 * gap, x1, y2, 0, 1) + color = gstati (ID_GP(id), G_TXCOLOR) + call gseti (ID_GP(id), G_TXCOLOR, color+1) + switch (ID_LABELS(id)) { + case 2: + call sprintf (Memc[label], SZ_LINE, "%d") + call pargi (feature) + call gtext (ID_GP(id), x1, y2, Memc[label], Memc[format]) + case 3: + call sprintf (Memc[label], SZ_LINE, "%0.2f") + call pargd (PIX(id,feature)) + call gtext (ID_GP(id), x1, y2, Memc[label], Memc[format]) + case 4: + if (!IS_INDEFD (USER(id,feature))) { + call sprintf (Memc[label], SZ_LINE, "%0.4f") + call pargd (USER(id,feature)) + call gtext (ID_GP(id), x1, y2, Memc[label], Memc[format]) + } + case 5: + label = Memi[ID_LABEL(id)+feature-1] + if (label != NULL) + call gtext (ID_GP(id), x1, y2, Memc[label], Memc[format]) + case 6: + Memc[label] = EOS + ptr = Memi[ID_LABEL(id)+feature-1] + if (!IS_INDEFD (USER(id,feature))) { + if (ptr != NULL) { + call sprintf (Memc[label], SZ_LINE, "%0.4f %s") + call pargd (USER(id,feature)) + call pargstr (Memc[ptr]) + } else { + call sprintf (Memc[label], SZ_LINE, "%0.4f") + call pargd (USER(id,feature)) + } + } else if (ptr != NULL) + call strcpy (Memc[ptr], Memc[label], SZ_LINE) + if (Memc[label] != EOS) + call gtext (ID_GP(id), x1, y2, Memc[label], Memc[format]) + } + call gseti (ID_GP(id), G_TXCOLOR, color) + + call sfree (sp) + call gflush (ID_GP(id)) +end diff --git a/noao/rv/rvidlines/idnearest.x b/noao/rv/rvidlines/idnearest.x new file mode 100644 index 00000000..41aa4c61 --- /dev/null +++ b/noao/rv/rvidlines/idnearest.x @@ -0,0 +1,29 @@ +include "identify.h" + +# ID_NEAREST -- Find the nearest feature to a given coordinate. + +procedure id_nearest (id, fitnear) + +pointer id # ID pointer +double fitnear # Coordinate to find nearest feature + +int i +double delta, delta1 + +begin + if (ID_NFEATURES(id) < 1) { + ID_CURRENT(id) = 0 + return + } + + ID_CURRENT(id) = 1 + delta = abs (FIT(id,1) - fitnear) + + do i = 2, ID_NFEATURES(id) { + delta1 = abs (FIT(id,i) - fitnear) + if (delta1 < delta) { + ID_CURRENT(id) = i + delta = delta1 + } + } +end diff --git a/noao/rv/rvidlines/idnewfeature.x b/noao/rv/rvidlines/idnewfeature.x new file mode 100644 index 00000000..efa489b4 --- /dev/null +++ b/noao/rv/rvidlines/idnewfeature.x @@ -0,0 +1,87 @@ +include <mach.h> +include "identify.h" + +# ID_NEWFEATURE -- Allocate and initialize memory for a new feature. + +procedure id_newfeature (id, pix, fit, user, wt, width, type, label) + +pointer id # ID pointer +double pix # Pixel coordinate +double fit # Fit coordinate +double user # User coordinate +double wt # Feature weight +real width # Feature width +int type # Feature type +pointer label # Pointer to feature label + +int i, current, strlen() +double delta + +define NALLOC 20 # Length of additional allocations + +begin + if (IS_INDEFD (pix)) + return + + delta = MAX_REAL + do i = 1, ID_NFEATURES(id) { + if (abs (pix - PIX(id,i)) < delta) { + delta = abs (pix - PIX(id,i)) + current = i + } + } + + if (delta >= ID_MINSEP(id)) { + ID_NFEATURES(id) = ID_NFEATURES(id) + 1 + if (ID_NALLOC(id) < ID_NFEATURES(id)) { + ID_NALLOC(id) = ID_NALLOC(id) + NALLOC + call realloc (ID_PIX(id), ID_NALLOC(id), TY_DOUBLE) + call realloc (ID_FIT(id), ID_NALLOC(id), TY_DOUBLE) + call realloc (ID_USER(id), ID_NALLOC(id), TY_DOUBLE) + call realloc (ID_WTS(id), ID_NALLOC(id), TY_DOUBLE) + call realloc (ID_FWIDTHS(id), ID_NALLOC(id), TY_REAL) + call realloc (ID_FTYPES(id), ID_NALLOC(id), TY_INT) + call realloc (ID_LABEL(id), ID_NALLOC(id), TY_POINTER) + call aclri (Memi[ID_LABEL(id)+ID_NALLOC(id)-NALLOC], NALLOC) + } + for (current=ID_NFEATURES(id); (current>1)&&(pix<PIX(id,current-1)); + current=current-1) { + PIX(id,current) = PIX(id,current-1) + FIT(id,current) = FIT(id,current-1) + USER(id,current) = USER(id,current-1) + WTS(id,current) = WTS(id,current-1) + FWIDTH(id,current) = FWIDTH(id,current-1) + FTYPE(id,current) = FTYPE(id,current-1) + Memi[ID_LABEL(id)+current-1] = Memi[ID_LABEL(id)+current-2] + } + PIX(id,current) = pix + FIT(id,current) = fit + USER(id,current) = user + WTS(id,current) = wt + FWIDTH(id,current) = width + FTYPE(id,current) = type + if (label != NULL) { + i = strlen (Memc[label]) + call malloc (Memi[ID_LABEL(id)+current-1], i, TY_CHAR) + call strcpy (Memc[label], Memc[Memi[ID_LABEL(id)+current-1]], i) + } else + Memi[ID_LABEL(id)+current-1] = NULL + ID_NEWFEATURES(id) = YES + } else if (abs (fit-user) < abs (FIT(id,current)-USER(id,current))) { + PIX(id,current) = pix + FIT(id,current) = fit + USER(id,current) = user + WTS(id,current) = wt + FWIDTH(id,current) = width + FTYPE(id,current) = type + if (label != NULL) { + i = strlen (Memc[label]) + call malloc (Memi[ID_LABEL(id)+current-1], i, TY_CHAR) + call strcpy (Memc[label], Memc[Memi[ID_LABEL(id)+current-1]], i) + } else + Memi[ID_LABEL(id)+current-1] = NULL + ID_NEWFEATURES(id) = YES + } + + ID_CURRENT(id) = current +end diff --git a/noao/rv/rvidlines/idnoextn.x b/noao/rv/rvidlines/idnoextn.x new file mode 100644 index 00000000..6c82d778 --- /dev/null +++ b/noao/rv/rvidlines/idnoextn.x @@ -0,0 +1,11 @@ +# ID_NOEXTN -- Remove standard image extensions. + +procedure id_noextn (image) + +char image[ARB] # Image name + +int strlen() + +begin + call xt_imroot (image, image, strlen (image)) +end diff --git a/noao/rv/rvidlines/idpeak.x b/noao/rv/rvidlines/idpeak.x new file mode 100644 index 00000000..9cba49c4 --- /dev/null +++ b/noao/rv/rvidlines/idpeak.x @@ -0,0 +1,23 @@ +include "identify.h" + +# ID_PEAK -- Find the peak value above continuum. + +double procedure id_peak (id, pix) + +pointer id # ID pointer +double pix # Pixel position +double peak # Peak value + +int c, l, u + +begin + if (IS_INDEFD(pix)) + return (INDEFD) + + c = nint (pix) + l = max (1, nint (pix - ID_FWIDTH(id))) + u = min (ID_NPTS(id), nint (pix + ID_FWIDTH(id))) + peak = IMDATA(id,c) - (IMDATA(id,l) + IMDATA(id,u)) / 2. + + return (peak) +end diff --git a/noao/rv/rvidlines/idrms.x b/noao/rv/rvidlines/idrms.x new file mode 100644 index 00000000..257675de --- /dev/null +++ b/noao/rv/rvidlines/idrms.x @@ -0,0 +1,28 @@ +include "identify.h" + +# ID_RMS -- Compute RMS of fit about the user coordinates + +double procedure id_rms (id) + +pointer id # ID pointer + +int i, nrms +double rms, id_zshiftd() + +begin + rms = 0. + nrms = 0 + for (i=1; i<=ID_NFEATURES(id); i=i+1) { + if (!IS_INDEFD (USER(id,i)) && WTS(id,i) != 0.) { + rms = rms + (id_zshiftd (id, FIT(id,i), 0) - USER(id,i)) ** 2 + nrms = nrms + 1 + } + } + + if (nrms > 0) + rms = sqrt (rms / nrms) + else + rms = INDEFD + + return (rms) +end diff --git a/noao/rv/rvidlines/idshift.x b/noao/rv/rvidlines/idshift.x new file mode 100644 index 00000000..3fa9f9bf --- /dev/null +++ b/noao/rv/rvidlines/idshift.x @@ -0,0 +1,65 @@ +include "identify.h" + +define NBIN 10 # Bin parameter for mode determination + +# ID_SHIFT -- Determine a shift by correlating feature user positions +# with peaks in the image data. + +double procedure id_shift (id) + +pointer id # ID pointer + +int i, j, npeaks, ndiff, find_peaks() +real d, dmin +double pix, id_center(), id_fitpt() +pointer x, y, diff +errchk malloc, find_peaks + +begin + # Find the peaks in the image data and center. + call malloc (x, ID_NPTS(id), TY_REAL) + npeaks = find_peaks (IMDATA(id,1), Memr[x], ID_NPTS(id), 0., + int (ID_MINSEP(id)), 0, ID_MAXFEATURES(id), 0., false) + + # Center the peaks and convert to user coordinates. + call malloc (y, npeaks, TY_DOUBLE) + j = 0 + do i = 1, npeaks { + pix = id_center (id, double(Memr[x+i-1]), 1, ID_FWIDTH(id), + ID_FTYPE(id), NO) + if (!IS_INDEFD (pix)) { + Memd[y+j] = id_fitpt (id, pix) + j = j + 1 + } + } + npeaks = j + + # Compute differences with feature list. + ndiff = npeaks * ID_NFEATURES(id) + call malloc (diff, ndiff, TY_REAL) + ndiff = 0 + do i = 1, ID_NFEATURES(id) { + do j = 1, npeaks { + Memr[diff+ndiff] = Memd[y+j-1] - FIT(id,i) + ndiff = ndiff + 1 + } + } + call mfree (x, TY_REAL) + call mfree (y, TY_DOUBLE) + + # Sort the differences and find the mode. + call asrtr (Memr[diff], Memr[diff], ndiff) + + dmin = Memr[diff+ndiff-1] - Memr[diff] + do i = 0, ndiff-NBIN-1 { + j = i + NBIN + d = Memr[diff+j] - Memr[diff+i] + if (d < dmin) { + dmin = d + pix = Memr[diff+i] + d / 2. + } + } + call mfree (diff, TY_REAL) + + return (pix) +end diff --git a/noao/rv/rvidlines/idshow.x b/noao/rv/rvidlines/idshow.x new file mode 100644 index 00000000..a01fba6f --- /dev/null +++ b/noao/rv/rvidlines/idshow.x @@ -0,0 +1,83 @@ +include "identify.h" + +# ID_SHOW -- Show parameter information. + +procedure id_show (id, file) + +pointer id # ID pointer +char file[ARB] # File + +char line[SZ_LINE] +int fd + +int open(), ic_geti() +errchk open() + +begin + fd = open (file, APPEND, TEXT_FILE) + + call sysid (line, SZ_LINE) + call fprintf (fd, "%s\n") + call pargstr (line) + + call fprintf (fd, "image %s\n") + call pargstr (Memc[ID_IMAGE(id)]) + call fprintf (fd, "nsum %d\n") + call pargi (ID_NSUM(id,1)) + switch (ID_FTYPE(id)) { + case EMISSION: + call fprintf (fd, "ftype emission\n") + case ABSORPTION: + call fprintf (fd, "ftype absorption\n") + case GEMISSION: + call fprintf (fd, "ftype gemission\n") + case GABSORPTION: + call fprintf (fd, "ftype gabsorption\n") + } + switch (ID_LABELS(id)) { + case 2: + call fprintf (fd, "labels index\n") + case 3: + call fprintf (fd, "labels pixel\n") + case 4: + call fprintf (fd, "labels coords\n") + case 5: + call fprintf (fd, "labels user\n") + case 6: + call fprintf (fd, "labels both\n") + default: + call fprintf (fd, "labels none\n") + } + call fprintf (fd, "maxfeatures %d\n") + call pargi (ID_MAXFEATURES(id)) + call fprintf (fd, "match %g\n") + call pargr (ID_MATCH(id)) + call fprintf (fd, "zwidth %g\n") + call pargr (ID_ZWIDTH(id)) + call fprintf (fd, "fwidth %g\n") + call pargr (ID_FWIDTH(id)) + call fprintf (fd, "database %s\n") + call pargstr (Memc[ID_DATABASE(id)]) + call fprintf (fd, "coordlist %s\n") + call pargstr (Memc[ID_COORDLIST(id)]) + call fprintf (fd, "cradius %g\n") + call pargr (ID_CRADIUS(id)) + call fprintf (fd, "threshold %g\n") + call pargr (ID_THRESHOLD(id)) + call fprintf (fd, "minsep %g\n") + call pargr (ID_MINSEP(id)) + if (ID_CV(id) != NULL) { + call fprintf (fd, "function = %s\n") + call ic_gstr (ID_IC(id), "function", line, SZ_LINE) + call pargstr (line) + call fprintf (fd, "order = %d\n") + call pargi (ic_geti (ID_IC(id), "order")) + call fprintf (fd, "Fit at first pixel = %0.8g\n") + call pargd (FITDATA(id,1)) + call fprintf (fd, "Average fit interval = %0.8g\n") + call pargd ((FITDATA(id,ID_NPTS(id))-FITDATA(id,1))/ + (ID_NPTS(id)-1)) + } + + call close (fd) +end diff --git a/noao/rv/rvidlines/idvelocity.x b/noao/rv/rvidlines/idvelocity.x new file mode 100644 index 00000000..c62e5c89 --- /dev/null +++ b/noao/rv/rvidlines/idvelocity.x @@ -0,0 +1,188 @@ +include <smw.h> +include <units.h> +include "identify.h" + + +# ID_VELOCITY -- Compute velocity. + +procedure id_velocity (id, interactive) + +pointer id # ID pointer +int interactive # Called interactively? + +int i, n +double z, sumz, sumz2, sumw, zerr, zhelio, v, verr, id_zval() + +begin + sumz = 0 + sumw = 0 + n = 0 + for (i=1; i <= ID_NFEATURES(id); i = i + 1) { + if (IS_INDEFD (USER(id,i)) || WTS(id,i) == 0.) + next + z = id_zval (id, FIT(id,i), USER(id,i)) + sumz = sumz + WTS(id,i) * z + sumw = sumw + WTS(id,i) + n = n + 1 + } + + if (sumw > 0.) { + zhelio = ID_ZHELIO(id) + sumz = sumz / sumw + + sumz2 = 0. + for (i=1; i <= ID_NFEATURES(id); i = i + 1) { + if (IS_INDEFD (USER(id,i)) || WTS(id,i) == 0.) + next + z = id_zval (id, FIT(id,i), USER(id,i)) + sumz2 = sumz2 + WTS(id,i) * (z - sumz) ** 2 + } + if (sumz2 > 0.) + sumz2 = sqrt (sumz2 / sumw) + else + sumz2 = 0. + zerr = sumz2 + if (n > 1) + zerr = zerr / sqrt (n - 1.) + + if (interactive == YES) { + v = (sumz + zhelio) * VLIGHT + verr = zerr * VLIGHT + + if (zhelio == 0D0) + call printf ( + "%s%s: Lines=%3d, Vobs=%.5g (%.5g), Zobs=%.5g (%.5g)\n") + else + call printf ( + "%s%s: Lines=%3d, Vhelio=%.5g (%.5g), Zhelio=%.5g (%.5g)\n") + + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargi (n) + call pargd (v) + call pargd (verr) + call pargd (sumz + zhelio) + call pargd (zerr) + } + ID_REDSHIFT(id) = sumz + ID_RMSRED(id) = sumz2 + ID_ZHELIO(id) = zhelio + } +end + + +# ID_ZVAL -- Compute Z value. + +double procedure id_zval (id, x, xref) + +pointer id #I Identify pointer +double x #I Coordinate +double xref #I Reference coordinate +double z #O Z value + +double y, yref +pointer un + +begin + y = x + yref = xref + + un = UN(ID_SH(id)) + if (UN_LOG(un) == YES) { + y = 10D0 ** y + yref = 10D0 ** yref + } + if (UN_INV(un) == YES) { + y = 1D0 / y + yref = 1D0 / yref + } + + switch (UN_CLASS(un)) { + case UN_WAVE: + z = (y - yref) / yref + case UN_FREQ, UN_ENERGY: + z = (yref - y) / y + case UN_VEL: + y = sqrt ((1 + y) / (1 - y)) + yref = sqrt ((1 + yref) / (1 - yref)) + z = (y - yref) / yref + case UN_DOP: + y = y + 1 + yref = yref + 1 + z = (y - yref) / yref + } + + return (z) +end + + + +# ID_ZSHIFTD -- Shift coordinate by redshift. + +double procedure id_zshiftd (id, x, dir) + +pointer id #I Identify pointer +double x #I Coordinate +int dir #I Direction (0=to rest, 1=from rest) +double y #O Shifted coordinate + +pointer un + +begin + y = x + + un = UN(ID_SH(id)) + if (UN_LOG(un) == YES) + y = 10D0 ** y + if (UN_INV(un) == YES) + y = 1D0 / y + + switch (UN_CLASS(un)) { + case UN_WAVE: + if (dir == 0) + y = y / (1 + ID_REDSHIFT(id)) + else + y = y * (1 + ID_REDSHIFT(id)) + case UN_FREQ, UN_ENERGY: + if (dir == 0) + y = y * (1 + ID_REDSHIFT(id)) + else + y = y / (1 + ID_REDSHIFT(id)) + case UN_VEL: + y = sqrt ((1 + y) / (1 - y)) + if (dir == 0) + y = y / (1 + ID_REDSHIFT(id)) + else + y = y * (1 + ID_REDSHIFT(id)) + y = y ** 2 + y = (y - 1) / (y + 1) + case UN_DOP: + y = (y + 1) + if (dir == 0) + y = (y + 1) / (1 + ID_REDSHIFT(id)) - 1 + else + y = (y + 1) * (1 + ID_REDSHIFT(id)) - 1 + } + + if (UN_INV(un) == YES) + y = 1D0 / y + if (UN_LOG(un) == YES) + y = log10 (y) + + return (y) +end + + +# ID_ZSHIFTR -- Shift coordinate by redshift. + +real procedure id_zshiftr (id, x, dir) + +pointer id #I Identify pointer +real x #I Coordinate +int dir #I Direction (0=to rest, 1=from rest) + +double id_zshiftd() + +begin + return (real (id_zshiftd (id, double(x), dir))) +end diff --git a/noao/rv/rvidlines/idvhelio.x b/noao/rv/rvidlines/idvhelio.x new file mode 100644 index 00000000..803efc2d --- /dev/null +++ b/noao/rv/rvidlines/idvhelio.x @@ -0,0 +1,102 @@ +include <error.h> + +# ID_VHELIO -- Compute helocentric velocity. + +procedure id_vhelio (im, vhelio, hjd, fd) + +pointer im #I IMIO pointer +double vhelio #O Heliocentric velocity correction +double hjd #O Heliocentric Julian Date +int fd #I Log file descriptor + +bool newobs, obshead +int year, month, day, flags, dummy +double ra, dec, ep, ut, lt +double epoch, vrot, vbary, vorb +double latitude, longitude, altitude +pointer sp, str1, str2, tmp, obs, kp + +int dtm_decode() +double imgetd(), obsgetd() +pointer clopset() + +int err +data err/0/ + +errchk imgetd, imgstr, obsopen + + +begin + call smark (sp) + call salloc (str1, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + obs = NULL + + iferr { + # Get the observatory data. + call clgstr ("observatory", Memc[str1], SZ_LINE) + tmp = NULL + call obsimopen (tmp, im, Memc[str1], NO, newobs, obshead) + obs = tmp + + latitude = obsgetd (obs, "latitude") + longitude = obsgetd (obs, "longitude") + altitude = obsgetd (obs, "altitude") + + # Get the image header data. + kp = clopset ("keywpars") + + call clgpset (kp, "date_obs", Memc[str1], SZ_LINE) + call imgstr (im, Memc[str1], Memc[str2], SZ_LINE) + if (dtm_decode (Memc[str2],year,month,day,ut,flags) == ERR) + call error (1, "Error in date string") + + call clgpset (kp, "ut", Memc[str1], SZ_LINE) + call imgstr (im, Memc[str1], Memc[str2], SZ_LINE) + if (dtm_decode (Memc[str2],dummy,dummy,dummy,ut,flags) == ERR) { + iferr (ut = imgetd (im, Memc[str1])) + call error (1, "Error in UT keyword") + } + + call clgpset (kp, "ra", Memc[str1], SZ_LINE) + ra = imgetd (im, Memc[str1]) + call clgpset (kp, "dec", Memc[str1], SZ_LINE) + dec = imgetd (im, Memc[str1]) + call clgpset (kp, "epoch", Memc[str1], SZ_LINE) + ep = imgetd (im, Memc[str1]) + call clcpset (kp) + + # Determine epoch of observation and precess coordinates. + call ast_date_to_epoch (year, month, day, ut, epoch) + call ast_precess (ra, dec, ep, ra, dec, epoch) + + # Determine velocity components. + call ast_vorbit (ra, dec, epoch, vorb) + call ast_vbary (ra, dec, epoch, vbary) + call ast_vrotate (ra, dec, epoch, latitude, longitude, + altitude, vrot) + call ast_hjd (ra, dec, epoch, lt, hjd) + + vhelio = vrot + vbary + vorb + + if (fd != NULL) + call obslog (obs, + "RVIDLINES", "latitude longitude altitude", fd) + + } then { + vhelio = 0. + if (err == 0) { + call eprintf ("Warning: Can't compute heliocentric velocity\n") + call erract (EA_WARN) + err = err + 1 + } + } + + iferr { # This IFERR is to clear errcode. + if (obs != NULL) + call obsclose (obs) + } then + ; + call sfree (sp) +end diff --git a/noao/rv/rvidlines/mkpkg b/noao/rv/rvidlines/mkpkg new file mode 100644 index 00000000..a18105f8 --- /dev/null +++ b/noao/rv/rvidlines/mkpkg @@ -0,0 +1,47 @@ +# RVIDLINES + +$checkout libpkg.a .. +$update libpkg.a +$checkin libpkg.a .. +$exit + +libpkg.a: + $ifeq (USE_GENERIC, yes) + $ifolder (peaks.x, peaks.gx) + $generic -k peaks.gx -o peaks.x $endif $endif + + # Version from V2.10.3 ONEDSPEC that conflicts with V2.10.2 RV + iddeblend.x <mach.h> + + idcenter.x identify.h <gset.h> <smw.h> + idcolon.x identify.h <error.h> <gset.h> <smw.h> + iddb.x identify.h <imset.h> <math/curfit.h> <smw.h> + iddelete.x identify.h + iddofit.x identify.h + iddoshift.x identify.h + idfitdata.x identify.h <smw.h> + idfixx.x <smw.h> + idgdata.x identify.h <imhdr.h> <imio.h> <pkg/gtools.h> <smw.h> + idgraph.x identify.h <gset.h> <pkg/gtools.h> <smw.h> + ididentify.x identify.h <error.h> <gset.h> <imhdr.h> <smw.h> + idinit.x identify.h <gset.h> <math/curfit.h> + idlabel.x + idlinelist.x identify.h <error.h> <mach.h> + idlog.x identify.h <smw.h> <time.h> + idmap.x identify.h <ctype.h> <imhdr.h> <pkg/gtools.h> <smw.h> + idmark.x identify.h <gset.h> <smw.h> + idnearest.x identify.h + idnewfeature.x identify.h <mach.h> + idnoextn.x + idpeak.x identify.h + idrms.x identify.h + idshift.x identify.h + idshow.x identify.h + idvelocity.x identify.h <smw.h> <units.h> + idvhelio.x <error.h> + peaks.x + reidentify.x identify.h <error.h> <gset.h> <imhdr.h> + t_identify.x identify.h <mach.h> <pkg/gtools.h> + t_reidentify.x identify.h <error.h> <fset.h> <gset.h> <pkg/gtools.h>\ + <smw.h> + ; diff --git a/noao/rv/rvidlines/peaks.gx b/noao/rv/rvidlines/peaks.gx new file mode 100644 index 00000000..32764505 --- /dev/null +++ b/noao/rv/rvidlines/peaks.gx @@ -0,0 +1,447 @@ +# PEAKS -- The following procedures are general numerical functions +# dealing with finding peaks in a data array. +# +# FIND_PEAKS Find the peaks in the data array. +# FIND_LOCAL_MAXIMA Find the local minima/maxima in the data array. +# IS_LOCAL_MAX Test a point to determine if it is a local min/max. +# FIND_THRESHOLD Find the peaks with positions satisfying threshold +# and contrast constraints. +# FIND_ISOLATED Flag peaks which are within separation of a peak +# with a higher peak value. +# FIND_NMAX Select up to the nmax highest ranked peaks. +# COMPARE Compare procedure for sort used in FIND_PEAKS. + +# FIND_PEAKS -- Find the peaks in the data array. +# +# The peaks are found using the following algorithm: +# +# 1. Find the local minima/maxima. +# 2. Reject peaks below the threshold. +# 3. Determine the ranks of the remaining peaks. +# 4. Flag weaker peaks within separation of a stronger peak. +# 5. Accept at most the nmax strongest peaks. +# +# Indefinite points are ignored. The peak positions are returned in the +# array x. + +$for (r) +int procedure find_peaks (data, x, npoints, contrast, separation, edge, nmax, + threshold, debug) + +# Procedure parameters: +PIXEL data[npoints] # Input data array +PIXEL x[npoints] # Output peak position array +int npoints # Number of data points +real contrast # Maximum contrast between strongest and weakest +int separation # Minimum separation between peaks +int edge # Minimum distance from the edge +int nmax # Maximum number of peaks to be returned +real threshold # Minimum threshold level for peaks +bool debug # Print diagnostic information? + +int i, j +int nlmax, nthreshold, nisolated, npeaks +pointer sp, rank + +int find_local_maxima(), find_threshold(), find_isolated(), find_nmax() +int compare() + +extern compare() + +pointer y +int maxima +common /sort/ y, maxima + +begin + # Find the local minima/maxima in data and put column positions in x.. + if (contrast < 0.) + maxima = NO + else + maxima = YES + + nlmax = find_local_maxima (data, x, npoints, debug) + + # Reject local minima/maxima near the edge. + if (edge > 0) { + j = 0 + do i = 1, nlmax { + if ((x[i] > edge) && (x[i] <= npoints - edge)) { + j = j + 1 + x[j] = x[i] + } + } + nlmax = j + } + + # Allocate a working array y. + call smark (sp) + call salloc (y, npoints, TY_PIXEL) + + # Reject the local minima/maxima which do not satisfy the thresholds. + # The array y is set to the peak values of the remaining peaks. + nthreshold = find_threshold (data, x, Mem$t[y], nlmax, + contrast, threshold, debug) + + # Rank the peaks by peak value. + call salloc (rank, nthreshold, TY_INT) + do i = 1, nthreshold + Memi[rank + i - 1] = i + call qsort (Memi[rank], nthreshold, compare) + + # Reject the weaker peaks within sep of a stronger peak. + nisolated = find_isolated (x, Memi[rank], nthreshold, separation, + debug) + + # Select the strongest nmax peaks. + npeaks = find_nmax (data, x, Memi[rank], nthreshold, nmax, debug) + + call sfree (sp) + return (npeaks) +end + + +# FIND_LOCAL_MAXIMA -- Find the local minima/maxima in the data array. +# +# A data array is input and the local minima/maxima positions array is output. +# The number of local minima/maxima found is returned. + +int procedure find_local_maxima (data, x, npoints, debug) + +PIXEL data[npoints] # Input data array +PIXEL x[npoints] # Output local min/max positions array +int npoints # Number of input points +bool debug # Print debugging information? + +int i, nlmax + +bool is_local_max() + +begin + nlmax = 0 + do i = 1, npoints { + if (is_local_max (i, data, npoints)) { + nlmax = nlmax + 1 + x[nlmax] = i + } + } + + if (debug) { + call printf (" Number of local minima/maxima found = %d.\n") + call pargi (nlmax) + } + + return (nlmax) +end + + +# IS_LOCAL_MAX -- Test a point to determine if it is a local minima/maximum. +# +# Indefinite points are ignored. + +bool procedure is_local_max (index, data, npoints) + +# Procedure parameters: +int index # Index to test for local minimum/maximum +PIXEL data[npoints] # Data values +int npoints # Number of points in the data vector + +int i, j, nright, nleft + +pointer y +int maxima +common /sort/ y, maxima + +begin + # INDEF points cannot be local minima/axima. + if (IS_INDEF (data[index])) + return (FALSE) + + # Find the left and right indices where data values change and the + # number of points with the same value. Ignore INDEF points. + nleft = 0 + for (i = index - 1; i >= 1; i = i - 1) { + if (!IS_INDEF (data[i])) { + if (data[i] != data[index]) + break + nleft = nleft + 1 + } + } + nright = 0 + for (j = index + 1; i <= npoints; j = j + 1) { + if (!IS_INDEF (data[j])) { + if (data[j] != data[index]) + break + nright = nright + 1 + } + } + + # Test for failure to be a local minima/axima + if (maxima == YES) { + if ((i == 0) && (j == npoints)) { + return (FALSE) # Data is constant + } else if (i == 0) { + if (data[j] > data[index]) + return (FALSE) # Data increases to right + } else if (j == npoints) { + if (data[i] > data[index]) # Data increase to left + return (FALSE) + } else if ((data[i] > data[index]) || (data[j] > data[index])) { + return (FALSE) # Not a local maximum + } else if (!((nleft - nright == 0) || (nleft - nright == 1))) { + return (FALSE) # Not center of plateau + } + } else { + if ((i == 0) && (j == npoints)) { + return (FALSE) # Data is constant + } else if (i == 0) { + if (data[j] < data[index]) + return (FALSE) # Data decreases to right + } else if (j == npoints) { + if (data[i] < data[index]) # Data decrease to left + return (FALSE) + } else if ((data[i] < data[index]) || (data[j] < data[index])) { + return (FALSE) # Not a local maximum + } else if (!((nleft - nright == 0) || (nleft - nright == 1))) { + return (FALSE) # Not center of plateau + } + } + + # Point is a local minima/maxima + return (TRUE) +end + + +# FIND_THRESHOLD -- Find the peaks with positions satisfying threshold +# and contrast constraints. +# +# The input is the data array, data, and the peak positions array, x. +# The x array is resorted to the nthreshold peaks satisfying the constraints. +# The corresponding nthreshold data values are returned the y array. +# The number of peaks satisfying the constraints (nthreshold) is returned. + +int procedure find_threshold (data, x, y, npoints, contrast, threshold, debug) + +PIXEL data[ARB] # Input data values +PIXEL x[npoints] # Input/Output peak positions +PIXEL y[npoints] # Output peak data values +int npoints # Number of peaks input +real contrast # Contrast constraint +real threshold # Threshold constraint +bool debug # Print debugging information? + +int i, j, nthreshold +PIXEL minval, maxval, lcut + +pointer dummy +int maxima +common /sort/ dummy, maxima + +begin + # Set the y array to be the values at the peak positions. + do i = 1, npoints { + j = x[i] + y[i] = data[j] + } + + # Determine the min and max values of the peaks. + call alim$t (y, npoints, minval, maxval) + + # Set the threshold based on the max of the absolute threshold and the + # contrast. Use arlt to set peaks below threshold to INDEF. + + if (maxima == YES) { + lcut = max (PIXEL (threshold), PIXEL (contrast * maxval)) + call arlt$t (y, npoints, lcut, INDEF) + } else { + lcut = threshold + call argt$t (y, npoints, lcut, INDEF) + } + + if (debug) { + call printf (" Highest peak value = %g.\n") + call parg$t (maxval) + call printf (" Peak cutoff threshold = %g.\n") + call parg$t (lcut) + do i = 1, npoints { + if (IS_INDEF (y[i])) { + j = x[i] + call printf ( + " Peak at column %d with value %g below threshold.\n") + call pargi (j) + call parg$t (data[j]) + } + } + } + + # Determine the number of acceptable peaks & resort the x and y arrays. + nthreshold = 0 + do i = 1, npoints { + if (IS_INDEF (y[i])) + next + nthreshold = nthreshold + 1 + x[nthreshold] = x[i] + y[nthreshold] = y[i] + } + + if (debug) { + call printf (" Number of peaks above the threshold = %d.\n") + call pargi (nthreshold) + } + + return (nthreshold) +end + +# FIND_ISOLATED -- Flag peaks which are within separation of a peak +# with a higher peak value. +# +# The peak positions, x, and their ranks, rank, are input. +# The rank array contains the indices of the peak positions in order from +# the highest peak value to the lowest peak value. Starting with +# highest rank (rank[1]) all peaks of lower rank within separation +# are marked by setting their positions to INDEF. The number of +# unflaged peaks is returned. + +int procedure find_isolated (x, rank, npoints, separation, debug) + +# Procedure parameters: +PIXEL x[npoints] # Positions of points +int rank[npoints] # Rank of peaks +int npoints # Number of peaks +int separation # Minimum allowed separation +bool debug # Print diagnostic information + +int i, j +int nisolated + +begin + # Eliminate close neighbors. The eliminated + # peaks are marked by setting their positions to INDEF. + nisolated = 0 + do i = 1, npoints { + if (IS_INDEF (x[rank[i]])) + next + nisolated = nisolated + 1 + do j = i + 1, npoints { + if (IS_INDEF (x[rank[j]])) + next + if (abs (x[rank[i]] - x[rank[j]]) < separation) { + if (debug) { + call printf ( + " Peak at column %d too near peak at column %d.\n") + call pargi (int (x[rank[j]])) + call pargi (int (x[rank[i]])) + } + x[rank[j]] = INDEF + } + } + } + + if (debug) { + call printf (" Number of peaks separated by %d pixels = %d.\n") + call pargi (separation) + call pargi (nisolated) + } + + # Return number of isolated peaks. + return (nisolated) +end + + +# FIND_NMAX -- Select up to the nmax highest ranked peaks. +# +# The data values, data, peak positions, x, and their ranks, rank, are input. +# The data values are used only in printing debugging information. +# Peak positions previously eliminated are flaged by the value INDEF. +# The rank array contains the indices to the peak positions in order from +# the highest peak value to the lowest peak value. +# First all but the nmax highest ranked peaks (which have not been previously +# eliminated) are eliminated by marking their positions with the value INDEF. +# Then the remaining peaks are resorted to contain only the unflaged +# peaks and the number of such peaks is returned. + +int procedure find_nmax (data, x, rank, npoints, nmax, debug) + +PIXEL data[ARB] # Input data values +PIXEL x[npoints] # Peak positions +int rank[npoints] # Ranks of peaks +int npoints # Number of input peaks +int nmax # Max number of peaks to be selected +bool debug # Print debugging information? + +int i, j, npeaks + +begin + # Only mark peaks to reject if the number peaks is greater than nmax. + if (nmax < npoints) { + npeaks = 0 + do i = 1, npoints { + if (IS_INDEF (x[rank[i]])) + next + npeaks = npeaks + 1 + if (npeaks > nmax) { + if (debug) { + j = x[rank[i]] + call printf ( + " Reject peak at column %d with rank %d and value %g.\n") + call pargi (j) + call pargi (i) + call parg$t (data[j]) + } + x[rank[i]] = INDEF + } + } + } + + # Eliminate INDEF points and determine the number of spectra found. + npeaks = 0 + do i = 1, npoints { + if (IS_INDEF (x[i])) + next + npeaks = npeaks + 1 + x[npeaks] = x[i] + } + + return (npeaks) +end + + +# COMPARE -- Compare procedure for sort used in FIND_PEAKS. +# Larger values are indexed first. INDEF values are indexed last. + +int procedure compare (index1, index2) + +# Procedure parameters: +int index1 # Comparison index +int index2 # Comparison index + +pointer y +int maxima +common /sort/ y, maxima + +begin + # INDEF points are considered to be smallest/largest possible values. + if (maxima == YES) { + if (IS_INDEF (Mem$t[y - 1 + index1])) + return (1) + else if (IS_INDEF (Mem$t[y - 1 + index2])) + return (-1) + else if (Mem$t[y - 1 + index1] < Mem$t[y - 1 + index2]) + return (1) + else if (Mem$t[y - 1 + index1] > Mem$t[y - 1 + index2]) + return (-1) + else + return (0) + } else { + if (IS_INDEF (Mem$t[y - 1 + index1])) + return (-1) + else if (IS_INDEF (Mem$t[y - 1 + index2])) + return (1) + else if (Mem$t[y - 1 + index1] < Mem$t[y - 1 + index2]) + return (-1) + else if (Mem$t[y - 1 + index1] > Mem$t[y - 1 + index2]) + return (1) + else + return (0) + } +end +$endfor diff --git a/noao/rv/rvidlines/peaks.x b/noao/rv/rvidlines/peaks.x new file mode 100644 index 00000000..8ee27f51 --- /dev/null +++ b/noao/rv/rvidlines/peaks.x @@ -0,0 +1,446 @@ +# PEAKS -- The following procedures are general numerical functions +# dealing with finding peaks in a data array. +# +# FIND_PEAKS Find the peaks in the data array. +# FIND_LOCAL_MAXIMA Find the local minima/maxima in the data array. +# IS_LOCAL_MAX Test a point to determine if it is a local min/max. +# FIND_THRESHOLD Find the peaks with positions satisfying threshold +# and contrast constraints. +# FIND_ISOLATED Flag peaks which are within separation of a peak +# with a higher peak value. +# FIND_NMAX Select up to the nmax highest ranked peaks. +# COMPARE Compare procedure for sort used in FIND_PEAKS. + +# FIND_PEAKS -- Find the peaks in the data array. +# +# The peaks are found using the following algorithm: +# +# 1. Find the local minima/maxima. +# 2. Reject peaks below the threshold. +# 3. Determine the ranks of the remaining peaks. +# 4. Flag weaker peaks within separation of a stronger peak. +# 5. Accept at most the nmax strongest peaks. +# +# Indefinite points are ignored. The peak positions are returned in the +# array x. + + +int procedure find_peaks (data, x, npoints, contrast, separation, edge, nmax, + threshold, debug) + +# Procedure parameters: +real data[npoints] # Input data array +real x[npoints] # Output peak position array +int npoints # Number of data points +real contrast # Maximum contrast between strongest and weakest +int separation # Minimum separation between peaks +int edge # Minimum distance from the edge +int nmax # Maximum number of peaks to be returned +real threshold # Minimum threshold level for peaks +bool debug # Print diagnostic information? + +int i, j +int nlmax, nthreshold, nisolated, npeaks +pointer sp, rank + +int find_local_maxima(), find_threshold(), find_isolated(), find_nmax() +int compare() + +extern compare() + +pointer y +int maxima +common /sort/ y, maxima + +begin + # Find the local minima/maxima in data and put column positions in x.. + if (contrast < 0.) + maxima = NO + else + maxima = YES + + nlmax = find_local_maxima (data, x, npoints, debug) + + # Reject local minima/maxima near the edge. + if (edge > 0) { + j = 0 + do i = 1, nlmax { + if ((x[i] > edge) && (x[i] <= npoints - edge)) { + j = j + 1 + x[j] = x[i] + } + } + nlmax = j + } + + # Allocate a working array y. + call smark (sp) + call salloc (y, npoints, TY_REAL) + + # Reject the local minima/maxima which do not satisfy the thresholds. + # The array y is set to the peak values of the remaining peaks. + nthreshold = find_threshold (data, x, Memr[y], nlmax, + contrast, threshold, debug) + + # Rank the peaks by peak value. + call salloc (rank, nthreshold, TY_INT) + do i = 1, nthreshold + Memi[rank + i - 1] = i + call qsort (Memi[rank], nthreshold, compare) + + # Reject the weaker peaks within sep of a stronger peak. + nisolated = find_isolated (x, Memi[rank], nthreshold, separation, + debug) + + # Select the strongest nmax peaks. + npeaks = find_nmax (data, x, Memi[rank], nthreshold, nmax, debug) + + call sfree (sp) + return (npeaks) +end + + +# FIND_LOCAL_MAXIMA -- Find the local minima/maxima in the data array. +# +# A data array is input and the local minima/maxima positions array is output. +# The number of local minima/maxima found is returned. + +int procedure find_local_maxima (data, x, npoints, debug) + +real data[npoints] # Input data array +real x[npoints] # Output local min/max positions array +int npoints # Number of input points +bool debug # Print debugging information? + +int i, nlmax + +bool is_local_max() + +begin + nlmax = 0 + do i = 1, npoints { + if (is_local_max (i, data, npoints)) { + nlmax = nlmax + 1 + x[nlmax] = i + } + } + + if (debug) { + call printf (" Number of local minima/maxima found = %d.\n") + call pargi (nlmax) + } + + return (nlmax) +end + + +# IS_LOCAL_MAX -- Test a point to determine if it is a local minima/maximum. +# +# Indefinite points are ignored. + +bool procedure is_local_max (index, data, npoints) + +# Procedure parameters: +int index # Index to test for local minimum/maximum +real data[npoints] # Data values +int npoints # Number of points in the data vector + +int i, j, nright, nleft + +pointer y +int maxima +common /sort/ y, maxima + +begin + # INDEF points cannot be local minima/axima. + if (IS_INDEFR (data[index])) + return (FALSE) + + # Find the left and right indices where data values change and the + # number of points with the same value. Ignore INDEF points. + nleft = 0 + for (i = index - 1; i >= 1; i = i - 1) { + if (!IS_INDEFR (data[i])) { + if (data[i] != data[index]) + break + nleft = nleft + 1 + } + } + nright = 0 + for (j = index + 1; i <= npoints; j = j + 1) { + if (!IS_INDEFR (data[j])) { + if (data[j] != data[index]) + break + nright = nright + 1 + } + } + + # Test for failure to be a local minima/axima + if (maxima == YES) { + if ((i == 0) && (j == npoints)) { + return (FALSE) # Data is constant + } else if (i == 0) { + if (data[j] > data[index]) + return (FALSE) # Data increases to right + } else if (j == npoints) { + if (data[i] > data[index]) # Data increase to left + return (FALSE) + } else if ((data[i] > data[index]) || (data[j] > data[index])) { + return (FALSE) # Not a local maximum + } else if (!((nleft - nright == 0) || (nleft - nright == 1))) { + return (FALSE) # Not center of plateau + } + } else { + if ((i == 0) && (j == npoints)) { + return (FALSE) # Data is constant + } else if (i == 0) { + if (data[j] < data[index]) + return (FALSE) # Data decreases to right + } else if (j == npoints) { + if (data[i] < data[index]) # Data decrease to left + return (FALSE) + } else if ((data[i] < data[index]) || (data[j] < data[index])) { + return (FALSE) # Not a local maximum + } else if (!((nleft - nright == 0) || (nleft - nright == 1))) { + return (FALSE) # Not center of plateau + } + } + + # Point is a local minima/maxima + return (TRUE) +end + + +# FIND_THRESHOLD -- Find the peaks with positions satisfying threshold +# and contrast constraints. +# +# The input is the data array, data, and the peak positions array, x. +# The x array is resorted to the nthreshold peaks satisfying the constraints. +# The corresponding nthreshold data values are returned the y array. +# The number of peaks satisfying the constraints (nthreshold) is returned. + +int procedure find_threshold (data, x, y, npoints, contrast, threshold, debug) + +real data[ARB] # Input data values +real x[npoints] # Input/Output peak positions +real y[npoints] # Output peak data values +int npoints # Number of peaks input +real contrast # Contrast constraint +real threshold # Threshold constraint +bool debug # Print debugging information? + +int i, j, nthreshold +real minval, maxval, lcut + +pointer dummy +int maxima +common /sort/ dummy, maxima + +begin + # Set the y array to be the values at the peak positions. + do i = 1, npoints { + j = x[i] + y[i] = data[j] + } + + # Determine the min and max values of the peaks. + call alimr (y, npoints, minval, maxval) + + # Set the threshold based on the max of the absolute threshold and the + # contrast. Use arlt to set peaks below threshold to INDEF. + + if (maxima == YES) { + lcut = max (real (threshold), real (contrast * maxval)) + call arltr (y, npoints, lcut, INDEFR) + } else { + lcut = threshold + call argtr (y, npoints, lcut, INDEFR) + } + + if (debug) { + call printf (" Highest peak value = %g.\n") + call pargr (maxval) + call printf (" Peak cutoff threshold = %g.\n") + call pargr (lcut) + do i = 1, npoints { + if (IS_INDEFR (y[i])) { + j = x[i] + call printf ( + " Peak at column %d with value %g below threshold.\n") + call pargi (j) + call pargr (data[j]) + } + } + } + + # Determine the number of acceptable peaks & resort the x and y arrays. + nthreshold = 0 + do i = 1, npoints { + if (IS_INDEFR (y[i])) + next + nthreshold = nthreshold + 1 + x[nthreshold] = x[i] + y[nthreshold] = y[i] + } + + if (debug) { + call printf (" Number of peaks above the threshold = %d.\n") + call pargi (nthreshold) + } + + return (nthreshold) +end + +# FIND_ISOLATED -- Flag peaks which are within separation of a peak +# with a higher peak value. +# +# The peak positions, x, and their ranks, rank, are input. +# The rank array contains the indices of the peak positions in order from +# the highest peak value to the lowest peak value. Starting with +# highest rank (rank[1]) all peaks of lower rank within separation +# are marked by setting their positions to INDEF. The number of +# unflaged peaks is returned. + +int procedure find_isolated (x, rank, npoints, separation, debug) + +# Procedure parameters: +real x[npoints] # Positions of points +int rank[npoints] # Rank of peaks +int npoints # Number of peaks +int separation # Minimum allowed separation +bool debug # Print diagnostic information + +int i, j +int nisolated + +begin + # Eliminate close neighbors. The eliminated + # peaks are marked by setting their positions to INDEF. + nisolated = 0 + do i = 1, npoints { + if (IS_INDEFR (x[rank[i]])) + next + nisolated = nisolated + 1 + do j = i + 1, npoints { + if (IS_INDEFR (x[rank[j]])) + next + if (abs (x[rank[i]] - x[rank[j]]) < separation) { + if (debug) { + call printf ( + " Peak at column %d too near peak at column %d.\n") + call pargi (int (x[rank[j]])) + call pargi (int (x[rank[i]])) + } + x[rank[j]] = INDEFR + } + } + } + + if (debug) { + call printf (" Number of peaks separated by %d pixels = %d.\n") + call pargi (separation) + call pargi (nisolated) + } + + # Return number of isolated peaks. + return (nisolated) +end + + +# FIND_NMAX -- Select up to the nmax highest ranked peaks. +# +# The data values, data, peak positions, x, and their ranks, rank, are input. +# The data values are used only in printing debugging information. +# Peak positions previously eliminated are flaged by the value INDEF. +# The rank array contains the indices to the peak positions in order from +# the highest peak value to the lowest peak value. +# First all but the nmax highest ranked peaks (which have not been previously +# eliminated) are eliminated by marking their positions with the value INDEF. +# Then the remaining peaks are resorted to contain only the unflaged +# peaks and the number of such peaks is returned. + +int procedure find_nmax (data, x, rank, npoints, nmax, debug) + +real data[ARB] # Input data values +real x[npoints] # Peak positions +int rank[npoints] # Ranks of peaks +int npoints # Number of input peaks +int nmax # Max number of peaks to be selected +bool debug # Print debugging information? + +int i, j, npeaks + +begin + # Only mark peaks to reject if the number peaks is greater than nmax. + if (nmax < npoints) { + npeaks = 0 + do i = 1, npoints { + if (IS_INDEFR (x[rank[i]])) + next + npeaks = npeaks + 1 + if (npeaks > nmax) { + if (debug) { + j = x[rank[i]] + call printf ( + " Reject peak at column %d with rank %d and value %g.\n") + call pargi (j) + call pargi (i) + call pargr (data[j]) + } + x[rank[i]] = INDEFR + } + } + } + + # Eliminate INDEF points and determine the number of spectra found. + npeaks = 0 + do i = 1, npoints { + if (IS_INDEFR (x[i])) + next + npeaks = npeaks + 1 + x[npeaks] = x[i] + } + + return (npeaks) +end + + +# COMPARE -- Compare procedure for sort used in FIND_PEAKS. +# Larger values are indexed first. INDEF values are indexed last. + +int procedure compare (index1, index2) + +# Procedure parameters: +int index1 # Comparison index +int index2 # Comparison index + +pointer y +int maxima +common /sort/ y, maxima + +begin + # INDEF points are considered to be smallest/largest possible values. + if (maxima == YES) { + if (IS_INDEFR (Memr[y - 1 + index1])) + return (1) + else if (IS_INDEFR (Memr[y - 1 + index2])) + return (-1) + else if (Memr[y - 1 + index1] < Memr[y - 1 + index2]) + return (1) + else if (Memr[y - 1 + index1] > Memr[y - 1 + index2]) + return (-1) + else + return (0) + } else { + if (IS_INDEFR (Memr[y - 1 + index1])) + return (-1) + else if (IS_INDEFR (Memr[y - 1 + index2])) + return (1) + else if (Memr[y - 1 + index1] < Memr[y - 1 + index2]) + return (-1) + else if (Memr[y - 1 + index1] > Memr[y - 1 + index2]) + return (1) + else + return (0) + } +end diff --git a/noao/rv/rvidlines/reidentify.x b/noao/rv/rvidlines/reidentify.x new file mode 100644 index 00000000..ed8133b2 --- /dev/null +++ b/noao/rv/rvidlines/reidentify.x @@ -0,0 +1,609 @@ +include <error.h> +include <imhdr.h> +include <gset.h> +include "identify.h" + +define HELP "noao$onedspec/identify/identify.key" +define RVHELP "noao$rv/rvidlines/rvidlines.key" +define ICFITHELP "noao$lib/scr/idicgfit.key" +define PROMPT "identify options" + +define PAN 1 # Pan graph +define ZOOM 2 # Zoom graph + +# REIDENTIFY -- Reidentify features in an image. + +procedure reidentify (id) + +pointer id # ID pointer + +real wx, wy, wx2, wy2 +int wcs, key +char cmd[SZ_LINE] + +char newimage[SZ_FNAME] +int i, j, last, all, prfeature, nfeatures1, npeaks, ftype +double pix, fit, user, shift, pix_shift, z_shift, xg[10] +pointer peaks, label + +int clgcur(), scan(), nscan(), find_peaks(), errcode() +double id_center(), fit_to_pix(), id_fitpt() +double id_shift(), id_rms(), id_zshiftd(), id_zval() +errchk id_graph() + +define newim_ 10 +define newkey_ 20 +define beep_ 99 + +begin + # Initialize. + ID_GTYPE(id) = PAN + all = 0 + last = ID_CURRENT(id) + newimage[1] = EOS + ID_REFIT(id) = NO + ID_NEWFEATURES(id) = NO + ID_NEWCV(id) = NO + wy = INDEF + key = 'r' + + repeat { + prfeature = YES + if (all != 0) + all = mod (all + 1, 3) + + switch (key) { + case '?': # Print help + if (ID_TASK(id) == IDENTIFY) + call gpagefile (ID_GP(id), HELP, PROMPT) + else + call gpagefile (ID_GP(id), RVHELP, PROMPT) + case ':': # Process colon commands + if (cmd[1] == '/') + call gt_colon (cmd, ID_GP(id), ID_GT(id), ID_NEWGRAPH(id)) + else + call id_colon (id, cmd, newimage, prfeature) + case ' ': # Go to current feature + case '.': # Go to nearest feature + if (ID_NFEATURES(id) == 0) + goto beep_ + call id_nearest (id, double (wx)) + case '-': # Go to previous feature + if (ID_CURRENT(id) == 1) + goto beep_ + ID_CURRENT(id) = ID_CURRENT(id) - 1 + case '+', 'n': # Go to next feature + if (ID_CURRENT(id) == ID_NFEATURES(id)) + goto beep_ + ID_CURRENT(id) = ID_CURRENT(id) + 1 + case 'a': # Set all flag for next key + all = 1 + case 'b': # Mark blended features + i = 1 + fit = wx + xg[i] = fit_to_pix (id, fit) + call printf ("mark other components (exit with 'q'):") + while (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE)!=EOF) { + if (key == 'q') + break + i = i + 1 + fit = wx + xg[i] = fit_to_pix (id, fit) + if (i == 10) + break + } + + call printf ("mark two background points: ") + j = clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) + j = clgcur ("cursor", wx2, wy2, wcs, key, cmd, SZ_LINE) + wx = fit_to_pix (id, double (wx)) + wx2 = fit_to_pix (id, double (wx2)) + + switch (ID_FTYPE(id)) { + case EMISSION: + ftype = GEMISSION + case ABSORPTION: + ftype = GABSORPTION + default: + ftype = ID_FTYPE(id) + } + iferr (call id_gcenter (id, xg, i, wx, wy, wx2, wy2, + ID_FWIDTH(id), ftype, YES)) { + call erract (EA_WARN) + prfeature = NO + goto newkey_ + } + + do j = 1, i { + pix = xg[j] + fit = id_fitpt (id, pix) + user = fit + call id_newfeature (id, pix, fit, user, 1.0D0, + ID_FWIDTH(id), ftype, NULL) + USER(id,ID_CURRENT(id)) = INDEFD + call id_match (id, FIT(id,ID_CURRENT(id)), + USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + call id_mark (id, ID_CURRENT(id)) + call printf ("%10.2f %10.8g ") + call pargd (PIX(id,ID_CURRENT(id))) + call pargd (FIT(id,ID_CURRENT(id))) + if (ID_REDSHIFT(id) != 0.) { + call printf ("%10.8g ") + call pargd ( + id_zshiftd (id, FIT(id,ID_CURRENT(id)), 0)) + } + call printf ("(%10.8g %s): ") + call pargd (USER(id,ID_CURRENT(id))) + label = Memi[ID_LABEL(id)+ID_CURRENT(id)-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + call gargwrd (cmd, SZ_LINE) + i = nscan() + if (i > 0) { + USER(id,ID_CURRENT(id)) = user + fit = id_zshiftd (id, user, 1) + call id_match (id, fit, USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + } + if (i > 1) { + call reset_scan () + call gargd (user) + call gargstr (cmd, SZ_LINE) + call id_label (cmd, + Memi[ID_LABEL(id)+ID_CURRENT(id)-1]) + } + } + } + case 'c': # Recenter features + if (all != 0) { + for (i = 1; i <= ID_NFEATURES(id); i = i + 1) { + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, i) + call gseti (ID_GP(id), G_PLTYPE, 1) + FWIDTH(id,i) = ID_FWIDTH(id) + PIX(id,i) = id_center (id, PIX(id,i), 1, FWIDTH(id,i), + FTYPE(id,i), NO) + if (!IS_INDEFD (PIX(id,i))) { + FIT(id,i) = id_fitpt (id, PIX(id,i)) + call id_mark (id, i) + } else { + call id_delete (id, i) + i = i - 1 + } + } + ID_NEWFEATURES(id) = YES + } else { + if (ID_NFEATURES(id) < 1) + goto beep_ + call id_nearest (id, double (wx)) + pix = PIX(id,ID_CURRENT(id)) + pix = id_center (id, pix, 1, ID_FWIDTH(id), + FTYPE(id,ID_CURRENT(id)), NO) + if (!IS_INDEFD (pix)) { + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, ID_CURRENT(id)) + PIX(id,ID_CURRENT(id)) = pix + FWIDTH(id,ID_CURRENT(id)) = ID_FWIDTH(id) + FIT(id,ID_CURRENT(id)) = id_fitpt (id, pix) + call gseti (ID_GP(id), G_PLTYPE, 1) + call id_mark (id, ID_CURRENT(id)) + ID_NEWFEATURES(id) = YES + } else { + call printf ("Centering failed\n") + prfeature = NO + } + } + case 'd': # Delete features + if (all != 0) { + ID_NFEATURES(id) = 0 + ID_CURRENT(id) = 0 + ID_NEWFEATURES(id) = YES + ID_NEWGRAPH(id) = YES + } else { + if (ID_NFEATURES(id) < 1) + goto beep_ + call id_nearest (id, double (wx)) + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, ID_CURRENT(id)) + call gseti (ID_GP(id), G_PLTYPE, 1) + call id_delete (id, ID_CURRENT(id)) + ID_CURRENT(id) = min (ID_NFEATURES(id), ID_CURRENT(id)) + last = 0 + } + case 'f': # Fit dispersion function + if (ID_TASK(id) == IDENTIFY) { + call id_dofit (id, YES) + } else { + call id_velocity (id, YES) + prfeature = NO + } + case 'g': # Fit shift + if (ID_TASK(id) == RVIDLINES) + goto beep_ + + call id_doshift (id, YES) + prfeature = NO + case 'i': # Initialize + call dcvfree (ID_CV(id)) + ID_SHIFT(id) = 0. + ID_REDSHIFT(id) = 0. + ID_NEWCV(id) = YES + ID_NFEATURES(id) = 0 + ID_CURRENT(id) = 0 + ID_NEWFEATURES(id) = YES + ID_NEWGRAPH(id) = YES + case 'j', 'k', 'o': + call printf ("Command not available in REIDENTIFY") + prfeature = NO + case 'l': # Find features from line list + if (ID_TASK(id) == IDENTIFY) { + if (ID_NFEATURES(id) >= 2) + call id_dofit (id, NO) + if (ID_NEWCV(id) == YES) { + iferr (call id_fitdata(id)) + ; + call id_fitfeatures(id) + ID_NEWCV(id) = NO + } + call id_linelist (id) + if (ID_NEWFEATURES(id) == YES) + ID_REFIT(id) = YES + } else { + call id_velocity (id, NO) + call id_linelist(id) + if (ID_NEWFEATURES(id) == YES) { + call id_velocity (id, NO) + ID_NEWGRAPH(id) = YES + } + } + case 'm': # Mark new feature + fit = wx + pix = fit_to_pix (id, fit) + pix = id_center (id, pix, 1, ID_FWIDTH(id), ID_FTYPE(id), YES) + if (IS_INDEFD (pix)) + goto beep_ + fit = id_fitpt (id, pix) + user = fit + call id_newfeature (id, pix, fit, user, 1.0D0, ID_FWIDTH(id), + ID_FTYPE(id), NULL) + USER(id,ID_CURRENT(id)) = INDEFD + call id_match (id, FIT(id,ID_CURRENT(id)), + USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + call id_mark (id, ID_CURRENT(id)) + call printf ("%10.2f %10.8g ") + call pargd (PIX(id,ID_CURRENT(id))) + call pargd (FIT(id,ID_CURRENT(id))) + if (ID_REDSHIFT(id) != 0.) { + call printf ("[%10.8g] ") + call pargd ( + id_zshiftd (id, FIT(id,ID_CURRENT(id)), 0)) + } + call printf ("(%10.8g %s): ") + call pargd (USER(id,ID_CURRENT(id))) + label = Memi[ID_LABEL(id)+ID_CURRENT(id)-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + call gargwrd (cmd, SZ_LINE) + i = nscan() + if (i > 0) { + USER(id,ID_CURRENT(id)) = user + call id_match (id, user, USER(id,ID_CURRENT(id)), + Memi[ID_LABEL(id)+ID_CURRENT(id)-1], + ID_MATCH(id)) + } + if (i > 1) { + call reset_scan () + call gargd (user) + call gargstr (cmd, SZ_LINE) + call id_label (cmd, Memi[ID_LABEL(id)+ID_CURRENT(id)-1]) + } + } + case 'p': # Switch to pan mode + if (ID_GTYPE(id) != PAN) { + ID_GTYPE(id) = PAN + ID_NEWGRAPH(id) = YES + } + case 'q': # Exit loop + break + case 'r': # Redraw the graph + ID_NEWGRAPH(id) = YES + case 's', 'x': # Shift or correlate features + if (ID_TASK(id) == RVIDLINES) + goto beep_ + + # Get coordinate shift. + switch (key) { + case 's': + call printf ("User coordinate (%10.8g): ") + call pargr (wx) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + if (nscan() == 1) + shift = wx - user + } else + shift = 0. + case 'x': + if (ID_NFEATURES(id) > 5) + shift = id_shift (id) + else + goto beep_ + } + + ID_NEWFEATURES(id) = YES + ID_NEWCV(id) = YES + ID_NEWGRAPH(id) = YES + prfeature = NO + + if (ID_NFEATURES(id) < 1) { + call printf ("User coordinate shift=%5f\n") + call pargd (shift) + ID_SHIFT(id) = ID_SHIFT(id) + shift + goto newkey_ + } + + # Recenter features. + pix_shift = 0. + z_shift = 0. + nfeatures1 = ID_NFEATURES(id) + + j = 0. + do i = 1, ID_NFEATURES(id) { + pix = fit_to_pix (id, FIT(id,i) + shift) + pix = id_center (id, pix, 1, FWIDTH(id,i), FTYPE(id,i), NO) + if (IS_INDEFD (pix)) { + if (ID_CURRENT(id) == i) + ID_CURRENT(id) = i + 1 + next + } + fit = id_fitpt (id, pix) + + pix_shift = pix_shift + pix - PIX(id,i) + if (FIT(id,i) != 0.) + z_shift = z_shift + id_zval (id, fit, FIT(id,i)) + + j = j + 1 + PIX(id,j) = pix + FIT(id,j) = FIT(id,i) + USER(id,j) = USER(id,i) + WTS(id,j) = WTS(id,i) + FWIDTH(id,j) = FWIDTH(id,i) + FTYPE(id,j) = FTYPE(id,i) + if (ID_CURRENT(id) == i) + ID_CURRENT(id) = j + } + if (j != ID_NFEATURES(id)) { + ID_NFEATURES(id) = j + ID_CURRENT(id) = min (ID_CURRENT(id), ID_NFEATURES(id)) + } + + if (ID_NFEATURES(id) < 1) { + call printf ("User coordinate shift=%5f") + call pargd (shift) + call printf (", No features found during recentering\n") + ID_SHIFT(id) = ID_SHIFT(id) + shift + goto newkey_ + } + + # Adjust shift. + pix = ID_SHIFT(id) + call id_doshift (id, NO) + call id_fitfeatures (id) + + # Print results. + call printf ("Recentered=%d/%d") + call pargi (ID_NFEATURES(id)) + call pargi (nfeatures1) + call printf ( + ", pixel shift=%.2f, user shift=%5f, z=%7.3g, rms=%5g\n") + call pargd (pix_shift / ID_NFEATURES(id)) + call pargd (pix - ID_SHIFT(id)) + call pargd (z_shift / ID_NFEATURES(id)) + call pargd (id_rms(id)) + case 't': # Move the current feature + if (ID_CURRENT(id) < 1) + goto beep_ + pix = fit_to_pix (id, double (wx)) + call gseti (ID_GP(id), G_PLTYPE, 0) + call id_mark (id, ID_CURRENT(id)) + PIX(id,ID_CURRENT(id)) = pix + FIT(id,ID_CURRENT(id)) = id_fitpt (id, pix) + call gseti (ID_GP(id), G_PLTYPE, 1) + call id_mark (id, ID_CURRENT(id)) + ID_NEWFEATURES(id) = YES + case 'u': # Set user coordinate + if (ID_NFEATURES(id) < 1) + goto beep_ + call printf ("%10.2f %10.8g ") + call pargd (PIX(id,ID_CURRENT(id))) + call pargd (FIT(id,ID_CURRENT(id))) + if (ID_REDSHIFT(id) != 0.) { + call printf ("[%10.8g] ") + call pargd (id_zshiftd (id, FIT(id,ID_CURRENT(id)), 0)) + } + call printf ("(%10.8g %s): ") + call pargd (USER(id,ID_CURRENT(id))) + label = Memi[ID_LABEL(id)+ID_CURRENT(id)-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + call gargwrd (cmd, SZ_LINE) + i = nscan() + if (i > 0) { + USER(id,ID_CURRENT(id)) = user + ID_NEWFEATURES(id) = YES + } + if (i > 1) { + call reset_scan () + call gargd (user) + call gargstr (cmd, SZ_LINE) + call id_label (cmd, Memi[ID_LABEL(id)+ID_CURRENT(id)-1]) + } + } + call printf ("Weight (%g): ") + call pargd (WTS(id,ID_CURRENT(id))) + call flush (STDOUT) + if (scan() != EOF) { + call gargd (user) + if (nscan() > 0) + WTS(id,ID_CURRENT(id)) = user + } + case 'w': # Window graph + call gt_window (ID_GT(id), ID_GP(id), "cursor", ID_NEWGRAPH(id)) + case 'y': # Find peaks + call malloc (peaks, ID_NPTS(id), TY_REAL) + npeaks = find_peaks (IMDATA(id,1), Memr[peaks], ID_NPTS(id), 0., + int (ID_MINSEP(id)), 0, ID_MAXFEATURES(id), 0., false) + for (j = 1; j <= ID_NFEATURES(id); j = j + 1) { + for (i = 1; i <= npeaks; i = i + 1) { + if (!IS_INDEF (Memr[peaks+i-1])) { + pix = Memr[peaks+i-1] + if (abs (pix - PIX(id,j)) < ID_MINSEP(id)) + Memr[peaks+i-1] = INDEF + } + } + } + for (i = 1; i <= npeaks; i = i + 1) { + if (IS_INDEF(Memr[peaks+i-1])) + next + pix = Memr[peaks+i-1] + pix = id_center(id, pix, 1, ID_FWIDTH(id), ID_FTYPE(id), NO) + if (IS_INDEFD (pix)) + next + fit = id_fitpt (id, pix) + user = INDEFD + call id_match (id, fit, user, label, ID_MATCH(id)) + call id_newfeature (id, pix, fit, user, 1.0D0, + ID_FWIDTH(id), ID_FTYPE(id), label) + call id_mark (id, ID_CURRENT(id)) + } + call mfree (peaks, TY_REAL) + case 'z': # Go to zoom mode + if (ID_NFEATURES(id) < 1) + goto beep_ + if (ID_GTYPE(id) == PAN) + ID_NEWGRAPH(id) = YES + ID_GTYPE(id) = ZOOM + call id_nearest (id, double (wx)) + case 'I': + call fatal (0, "Interrupt") + default: +beep_ call printf ("\007") + } + +newkey_ + # Set update flag if anything has changed. + if ((ID_NEWFEATURES(id) == YES) || (ID_NEWCV(id) == YES)) + ID_NEWDBENTRY(id) = YES + + # If a new image exit loop, update database, and start over. + if (newimage[1] != EOS) { + call printf ("Can't change image in REIDENTIFY") + newimage[1] = EOS + prfeature = NO + } + + # Refit dispersion function + if (ID_REFIT(id) == YES) { + call id_dofit (id, NO) + ID_REFIT(id) = NO + } + + # If there is a new dispersion solution evaluate the coordinates + if (ID_NEWCV(id) == YES) { + iferr (call id_fitdata (id)) + ; + call id_fitfeatures (id) + ID_NEWCV(id) = NO + } + + # Draw new graph in zoom mode if current feature has changed. + if ((ID_GTYPE(id) == ZOOM) && (last != ID_CURRENT(id))) + ID_NEWGRAPH(id) = YES + + # Draw new graph. + if (ID_NEWGRAPH(id) == YES) { + call id_graph (id, ID_GTYPE(id)) + ID_NEWGRAPH(id) = NO + } + + # Set cursor and print status of current feature (unless canceled). + if (ID_CURRENT(id) > 0) { + if (IS_INDEF (wy)) { + i = max (1, min (ID_NPTS(id), int (PIX(id,ID_CURRENT(id))))) + wy = IMDATA(id,i) + } + + call gscur (ID_GP(id), real (FIT(id,ID_CURRENT(id))), wy) + if (errcode() == OK && prfeature == YES) { + i = ID_CURRENT(id) + pix = PIX(id,i) + fit = FIT(id,i) + user = USER(id,i) + if (ID_TASK(id) == IDENTIFY) { + if (IS_INDEFD(user)) + shift = INDEF + else + shift = fit - user + call printf ("%10.2f %10.8g %10.8g %10.3g %s") + call pargd (pix) + call pargd (fit) + call pargd (user) + call pargd (shift) + label = Memi[ID_LABEL(id)+i-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + } else { + if (IS_INDEFD(user)) + shift = INDEF + else { + shift = id_zval (id, fit, user) - ID_REDSHIFT(id) + if (abs (shift) < 0.01) + shift = shift * VLIGHT + } + call printf ("%10.2f %10.8g %10.8g %10.8g %10.4g %s") + call pargd (pix) + call pargd (fit) + call pargd (id_zshiftd (id, fit, 0)) + call pargd (user) + if (IS_INDEFD(user)) + call pargd (INDEFD) + else + call pargd (shift) + label = Memi[ID_LABEL(id)+i-1] + if (label != NULL) + call pargstr (Memc[label]) + else + call pargstr ("") + } + } + } + + # Print delayed error message + if (errcode() != OK) + call erract (EA_WARN) + + last = ID_CURRENT(id) + } until (clgcur ("cursor", wx, wy, wcs, key, cmd, SZ_LINE) == EOF) +end diff --git a/noao/rv/rvidlines/rvidlines.key b/noao/rv/rvidlines/rvidlines.key new file mode 100644 index 00000000..cfccacde --- /dev/null +++ b/noao/rv/rvidlines/rvidlines.key @@ -0,0 +1,100 @@ + RVIDLINES HELP + + +STATUS LINE + +The status line gives the pixel position, observed wavelength, +rest wavelength, user wavelength, velocity residual, and optional +line identification: + + pixel observed rest user Vresidual [identification] + + +CURSOR KEY SUMMARY + +? Help l Match list w Window graph +a Affect all features m Mark feature y Find peaks +b Deblend n Next feature z Zoom graph +c Center feature(s) o Go to line + Next feature +d Delete feature(s) p Pan graph - Previous feature +f Fit velocity q Quit . Nearest feature +i Initialize r Redraw graph I Interrupt +j Preceding line t Reset position +k Next line u Enter coordinate + + +COLON COMMAND SUMMARY + +:show [file] :features [file] :coordlist [file] +:cradius [value] :threshold [value] :database [file] +:ftype [type] :fwidth [value] :image [image] +:labels [type] :match [value] :maxfeatures [value] +:minsep [value] :read [image [ap]] :write [image [ap]] +:zwidth [value] :add [image [ap]] + + +CURSOR KEYS + +? Clear the screen and print menu of options +a Apply next (c)enter or (d)elete operation to (a)ll features +b Mark and de(b)lend features by Gaussian fitting +c (C)enter the feature nearest the cursor +d (D)elete the feature nearest the cursor +f (F)it a redshift and velocity from the fitted and user coordinates +i (I)nitialize (delete features and coordinate fit) +j Go to the preceding image line or column in a 2D or multispec image +k Go to the next image line or column in a 2D or multispec image +l Match coordinates in the coordinate (l)ist +m (M)ark a new feature near the cursor and enter coordinate and label +n Move the cursor or zoom to the (n)ext feature (same as +) +o Go to the specified image line or column in a 2D or multispec image +p (P)an to user defined window after (z)ooming on a feature +q (Q)uit and continue with next image (also carriage return) +r (R)edraw the graph +t Reset the position of a feature without centering +u Enter a new (u)ser coordinate and label for the current feature +w (W)indow the graph. Use '?' to window prompt for more help. +y Automatically find "maxfeatures" strongest peaks and identify them +z (Z)oom on the feature nearest the cursor +. Move the cursor or zoom to the feature nearest the cursor ++ Move the cursor or zoom to the next feature +- Move the cursor or zoom to the previous feature +I Interrupt task and exit immediately. Database information is not saved. + + +COLON COMMANDS + +The parameters are listed or set with the following commands which may be +abbreviated. To list the value of a parameter type the command alone. + +:show file Show the values of all the parameters +:features file Write feature list to file (default is STDOUT) + +:coordlist file Coordinate list file +:cradius value Centering radius in pixels +:threshold value Detection threshold for feature centering +:database name Database for recording feature records +:ftype value Feature type + (emission|absorption|gemission|gabsorption) +:fwidth value Feature width in pixels +:image imagename Set a new image or show the current image +:labels value Feature label type + (none|index|pixel|coords|user|both) +:match value Coordinate list matching distance +:maxfeatures value Maximum number of features automatically found +:minsep value Minimum separation allowed between features +:read name ap Read a record from the database + (name and ap default to the current spectrum) +:write name ap Write a record to the database + (name and ap default to the current spectrum) +:add name ap Add features from the database + (name and ap default to the current spectrum) +:zwidth value Zoom width in user units + +Labels: + none - No labels + index - Sequential numbers in order of increasing pixel position + pixel - Pixel coordinates + coords - User coordinates such as wavelength + user - User labels + both - Combination of coords and user diff --git a/noao/rv/rvidlines/t_identify.x b/noao/rv/rvidlines/t_identify.x new file mode 100644 index 00000000..aac9596f --- /dev/null +++ b/noao/rv/rvidlines/t_identify.x @@ -0,0 +1,108 @@ +include <mach.h> +include <pkg/gtools.h> +include "identify.h" + +# T_IDENTIFY -- Identify features and determine dispersion solutions + +procedure t_identify () + +begin + call identify (IDENTIFY) +end + + +# T_RVIDLINES -- Identify features and determine radial velocities + +procedure t_rvidlines () + +begin + call identify (RVIDLINES) +end + + +# IDENTIFY -- Initialize task + +procedure identify (taskid) + +int taskid #I Task ID + +int list, clscan(), clgeti(), clgwrd(), nscan(), imtopenp(), imtgetim() +real clgetr() +pointer sp, str, id, gt_init() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allocate the basic data structure. + call id_init (id, taskid) + + # Get task parameters. + list = imtopenp ("images") + if (clscan ("nsum") != EOF) { + call gargi (ID_NSUM(id,1)) + call gargi (ID_NSUM(id,2)) + if (nscan() == 0) + call error (1, "Error in 'nsum' parameter") + if (nscan() == 1) + ID_NSUM(id,2) = ID_NSUM(id,1) + ID_NSUM(id,1) = max (1, ID_NSUM(id,1)) + ID_NSUM(id,2) = max (1, ID_NSUM(id,2)) + } + ID_MAXFEATURES(id) = clgeti ("maxfeatures") + ID_MINSEP(id) = clgetr ("minsep") + ID_MATCH(id) = clgetr ("match") + ID_ZWIDTH(id) = clgetr ("zwidth") + ID_FTYPE(id) = clgwrd ("ftype", Memc[str], SZ_LINE, FTYPES) + ID_FWIDTH(id) = clgetr ("fwidth") + ID_CRADIUS(id) = clgetr ("cradius") + ID_THRESHOLD(id) = clgetr ("threshold") + call clgstr ("database", Memc[ID_DATABASE(id)], SZ_FNAME) + call clgstr ("coordlist", Memc[ID_COORDLIST(id)], SZ_FNAME) + ID_LABELS(id) = 1 + + # Initialize features data structure. + ID_GT(id) = gt_init() + call gt_sets (ID_GT(id), GTTYPE, "line") + ID_CV(id) = NULL + ID_CURRENT(id) = 0 + ID_SHIFT(id) = 0. + ID_REDSHIFT(id) = 0. + + # Initialize ICFIT + call ic_open (ID_IC(id)) + if (ID_TASK(id) == IDENTIFY) { + call clgstr ("function", Memc[str], SZ_LINE) + call ic_pstr (ID_IC(id), "function", Memc[str]) + call ic_puti (ID_IC(id), "order", clgeti ("order")) + call clgstr ("sample", Memc[str], SZ_LINE) + call ic_pstr (ID_IC(id), "sample", Memc[str]) + call ic_puti (ID_IC(id), "naverage", 1) + call ic_puti (ID_IC(id), "niterate", clgeti ("niterate")) + call ic_putr (ID_IC(id), "low", clgetr ("low_reject")) + call ic_putr (ID_IC(id), "high", clgetr ("high_reject")) + call ic_putr (ID_IC(id), "grow", clgetr ("grow")) + call ic_pstr (ID_IC(id), "xlabel", "Feature positions") + call ic_pstr (ID_IC(id), "xunits", "pixels") + call ic_pstr (ID_IC(id), "ylabel", "") + call ic_pkey (ID_IC(id), 1, 'y', 'x') + call ic_pkey (ID_IC(id), 2, 'y', 'v') + call ic_pkey (ID_IC(id), 3, 'y', 'r') + call ic_pkey (ID_IC(id), 4, 'y', 'd') + call ic_pkey (ID_IC(id), 5, 'y', 'n') + call ic_puti (ID_IC(id), "key", 3) + } + + # Get the line list. + call id_mapll (id) + + # Expand the image template and identify features in each image. + while (imtgetim (list, Memc[ID_IMAGE(id)], SZ_FNAME) != EOF) + call id_identify (id) + + # Finish up. + call smw_daxis (NULL, NULL, 0, 0, 0) + call id_free (id) + call imtclose (list) + call sfree (sp) +end diff --git a/noao/rv/rvidlines/t_reidentify.x b/noao/rv/rvidlines/t_reidentify.x new file mode 100644 index 00000000..5a724325 --- /dev/null +++ b/noao/rv/rvidlines/t_reidentify.x @@ -0,0 +1,1092 @@ +include <error.h> +include <fset.h> +include <gset.h> +include <pkg/gtools.h> +include <smw.h> +include "identify.h" + +define ICFITHELP "noao$lib/scr/idicgfit.key" +define VLIGHT 2.997925e5 # Speed of light, Km/sec + + +# T_REIDENTIFY -- Reidentify features starting from reference features. + +procedure t_reidentify () + +begin + call reiden (IDENTIFY) +end + + +# T_RVREIDLINES -- Reidentify lines for radial velocities + +procedure t_rvreidlines () + +begin + call reiden (RVIDLINES) +end + + +# REIDEN -- Reidentify features starting from reference features. +# A reference spectrum is specified and the same features are identified +# in other images. Some lines may be lost due to bad centering. Additional +# lines may be excluded from a new fit to the dispersion function. Instead +# of refitting the dispersion function the user may elect to determine only +# a shift in the reference dispersion function. Additional features may +# be added given a coordinate list. +# +# In 2D images a starting line or column is selected. A number of lines +# or columns may be averaged before identifying features. If a positive step +# size is given then additional lines or columns may be reidentified in +# the reference image. This may be done either by tracing or by reidentifying +# starting from the same reference features. Reidentification between images +# is done by taking the same line or column from the reference image. +# +# Multispec format images are matched by aperture number and the spectra +# need not be in the same order in each image. + +procedure reiden (taskid) + +int taskid #I Task ID + +pointer reference # Reference image +int list # List of images +char ans[3] # Interactive? + +int i, fd, nlogfd +pointer sp, logfile, str, id, logfd, pd + +int clscan(), clgeti(), clpopnu(), clgfil(), clgwrd(), btoi() +int nscan(), open(), nowhite(), imtopenp(), imtgetim() +bool clgetb() +real clgetr() +pointer gopen(), gt_init() + +begin + call smark (sp) + call salloc (reference, SZ_FNAME, TY_CHAR) + call salloc (logfile, SZ_FNAME, TY_CHAR) + call salloc (str, SZ_LINE, TY_CHAR) + + # Allocate the basic data structures. + call id_init (id, taskid) + call ic_open (ID_IC(id)) + + # Get task parameters. + call clgstr ("reference", Memc[reference], SZ_FNAME) + list = imtopenp ("images") + i = nowhite (Memc[reference], Memc[reference], SZ_FNAME) + + if (ID_TASK(id) == IDENTIFY) + ID_REFIT(id) = btoi (clgetb ("refit")) + else + ID_REFIT(id) = 3 + + if (clscan ("nsum") != EOF) { + call gargi (ID_NSUM(id,1)) + call gargi (ID_NSUM(id,2)) + if (nscan() == 0) + call error (1, "Error in 'nsum' parameter") + if (nscan() == 1) + ID_NSUM(id,2) = ID_NSUM(id,1) + ID_NSUM(id,1) = max (1, ID_NSUM(id,1)) + ID_NSUM(id,2) = max (1, ID_NSUM(id,2)) + } + ID_MAXFEATURES(id) = clgeti ("maxfeatures") + ID_MINSEP(id) = clgetr ("minsep") + ID_MATCH(id) = clgetr ("match") + if (ID_TASK(id) == IDENTIFY) { + ID_ZWIDTH(id) = clgetr ("identify.zwidth") + ID_FTYPE(id) = clgwrd ("identify.ftype", Memc[str], SZ_LINE, FTYPES) + ID_FWIDTH(id) = clgetr ("identify.fwidth") + } else { + ID_ZWIDTH(id) = clgetr ("rvidlines.zwidth") + ID_FTYPE(id) = clgwrd ("rvidlines.ftype", Memc[str], SZ_LINE,FTYPES) + ID_FWIDTH(id) = clgetr ("rvidlines.fwidth") + } + ID_CRADIUS(id) = clgetr ("cradius") + ID_THRESHOLD(id) = clgetr ("threshold") + call clgstr ("database", Memc[ID_DATABASE(id)], SZ_FNAME) + call clgstr ("coordlist", Memc[ID_COORDLIST(id)], SZ_FNAME) + ID_LABELS(id) = 1 + + call id_mapll (id) + ID_LOGFILES(id) = clpopnu ("logfiles") + + switch (clgwrd ("interactive", ans, SZ_FNAME, "|no|yes|NO|YES|")) { + case 1, 3: + call strcpy ("NO", ans, 3) + ID_GP(id) = NULL + case 2, 4: + # Open graphics + call clgstr ("graphics", Memc[logfile], SZ_FNAME) + ID_GP(id) = gopen (Memc[logfile], NEW_FILE+AW_DEFER, STDGRAPH) + if (ID_TASK(id) == IDENTIFY) { + call ic_pstr (ID_IC(id), "help", ICFITHELP) + call ic_pstr (ID_IC(id), "xlabel", "Feature positions") + call ic_pstr (ID_IC(id), "xunits", "pixels") + call ic_pstr (ID_IC(id), "ylabel", "") + call ic_pkey (ID_IC(id), 1, 'y', 'x') + call ic_pkey (ID_IC(id), 2, 'y', 'v') + call ic_pkey (ID_IC(id), 3, 'y', 'r') + call ic_pkey (ID_IC(id), 4, 'y', 'd') + call ic_pkey (ID_IC(id), 5, 'y', 'n') + call ic_puti (ID_IC(id), "key", 3) + } + } + + # Open log and plot files. + nlogfd = 0 + if (clgetb ("verbose")) { + nlogfd = 1 + call malloc (logfd, nlogfd, TY_INT) + Memi[logfd] = STDOUT + } + while (clgfil (ID_LOGFILES(id), Memc[logfile], SZ_FNAME) != EOF) { + fd = open (Memc[logfile], APPEND, TEXT_FILE) + call fseti (fd, F_FLUSHNL, YES) + nlogfd = nlogfd + 1 + if (nlogfd == 1) + call malloc (logfd, nlogfd, TY_INT) + else + call realloc (logfd, nlogfd, TY_INT) + Memi[logfd+nlogfd-1] = fd + } + call ri_loghdr (id, Memc[reference], Memi[logfd], nlogfd, 1) + + pd = NULL + if (ID_TASK(id) == IDENTIFY) { + call clgstr ("plotfile", Memc[logfile], SZ_FNAME) + if (nowhite (Memc[logfile], Memc[logfile], SZ_FNAME) > 0) { + fd = open (Memc[logfile], APPEND, BINARY_FILE) + pd = gopen ("stdvdm", NEW_FILE, fd) + } + } + + ID_GT(id) = gt_init() + call gt_sets (ID_GT(id), GTTYPE, "line") + + # Get and trace the reference solutions. + call ri_reference (id, Memc[reference], ans, Memi[logfd], nlogfd, pd) + + # Expand the image template and reidentify features. + while (imtgetim (list, Memc[ID_IMAGE(id)], SZ_FNAME) != EOF) + call ri_image (id, Memc[reference], Memc[ID_IMAGE(id)], ans, + Memi[logfd], nlogfd, pd) + + # Finish up. + if (nlogfd > 0) { + do i = 1, nlogfd + call close (Memi[logfd+i-1]) + call mfree (logfd, TY_INT) + } + + if (ID_GP(id) != NULL) + call gclose (ID_GP(id)) + if (pd != NULL) { + call gclose (pd) + call close (fd) + } + call clpcls (ID_LOGFILES(id)) + call imtclose (list) + call id_free (id) + call smw_daxis (NULL, NULL, 0, 0, 0) + call sfree (sp) +end + + +# RI_REFERENCE -- Set reference features. Trace if needed. + +procedure ri_reference (id, reference, ans, logfd, nlogfd, pd) + +pointer id # ID pointer +char reference[ARB] # Reference image +char ans[3] # Interactive? +int logfd[ARB] # Logfiles +int nlogfd # Number of logfiles +pointer pd # Plot file pointer + +int step[2] +double shift[2] +int nreid +bool override +bool trace + +int i, start[2], line[2], loghdr +double fit_shift[2] +pointer ic, ic1 +bool clgetb() +int clscan(), clgeti(), nscan(), id_gid(), id_dbcheck() +errchk id_dbread + +begin + # Open the image and return if there is an error. + call strcpy (reference, Memc[ID_IMAGE(id)], SZ_FNAME) + iferr (call id_map (id)) { + call erract (EA_WARN) + return + } + + # Set parameters + start[1] = ID_LINE(id,1) + start[2] = ID_LINE(id,2) + if (clscan ("step") != EOF) { + call gargi (step[1]) + call gargi (step[2]) + if (nscan() == 0) + call error (1, "Error in 'step' parameter") + if (nscan() == 1) + step[2] = step[1] + } + if (clscan ("shift") != EOF) { + call gargd (shift[1]) + call gargd (shift[2]) + if (nscan() == 0) + call error (1, "Error in 'shift' parameter") + if (nscan() == 1) + shift[2] = shift[1] + } + nreid = max (1, ID_NFEATURES(id) - clgeti ("nlost")) + override = clgetb ("override") + trace = clgetb ("trace") + + # Get and save the reference database entry. + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO, NO) + call id_saveid (id, ID_LINE(id,1)) + + # Get and save other entries. + if (!override) { + for (line[2]=start[2]; line[2]>0; line[2]=line[2]-step[2]) { + ID_LINE(id,2) = line[2] + ID_AP(id,2) = line[2] + for (line[1]=start[1]; line[1]>0; line[1]=line[1]-step[1]) { + if (line[1]==start[1] && line[2]==start[2]) + next + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + ifnoerr ( + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + NO, NO)) { + call id_saveid (id, ID_LINE(id,1)) + } + } + for (line[1]=start[1]+step[1]; line[1]<=ID_MAXLINE(id,1); + line[1]=line[1]+step[1]) { + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + ifnoerr (call id_dbread (id, Memc[ID_IMAGE(id)], + ID_AP(id,1), NO, NO)) { + call id_saveid (id, ID_LINE(id,1)) + } + } + } + for (line[2]=start[2]+step[2]; line[2]<=ID_MAXLINE(id,2); + line[2]=line[2]+step[2]) { + ID_LINE(id,2) = line[2] + ID_AP(id,2) = line[2] + for (line[1]=start[1]-step[1]; line[1]>0; + line[1]=line[1]-step[1]) { + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + ifnoerr ( + call id_dbread (id, Memc[ID_IMAGE(id)], ID_AP(id,1), + NO, NO)) { + call id_saveid (id, ID_LINE(id,1)) + } + } + for (line[1]=start[1]+step[1]; line[1]<=ID_MAXLINE(id,1); + line[1]=line[1]+step[1]) { + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + ifnoerr (call id_dbread (id, Memc[ID_IMAGE(id)], + ID_AP(id,1), NO, NO)) { + call id_saveid (id, ID_LINE(id,1)) + } + } + } + } + + # Reidentify. + loghdr = 2 + ic = ID_IC(id) + if (ans[1] == 'N') + ic1 = ic + else { + call ic_open (ic1) + call ic_copy (ic, ic1) + } + + fit_shift[2] = shift[2] + for (line[2]=start[2]; line[2]>0; line[2]=line[2]-step[2]) { + ID_LINE(id,2) = line[2] + ID_AP(id,2) = line[2] + ID_IC(id) = ic + + if (IS_INDEFD(shift[2])) + fit_shift[2] = INDEFD + else { + if (!trace) + fit_shift[2] = fit_shift[2] - shift[2] + else + fit_shift[2] = -shift[2] + } + + fit_shift[1] = fit_shift[2] + for (line[1]=start[1]; line[1]>0; line[1]=line[1]-step[1]) { + if (line[1]==start[1] && line[2]==start[2]) + next + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + ID_IC(id) = ic + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + if (!override) + if (id_dbcheck (id, Memc[ID_IMAGE(id)], ID_AP(id,1)) == YES) + next + + if (!trace) { + i = id_gid (id, start) + ID_LINE(id,1) = line[1] + ID_LINE(id,2) = line[2] + } + + if (IS_INDEFD(shift[1])) + fit_shift[1] = INDEFD + else { + if (!trace) + fit_shift[1] = fit_shift[1] - shift[1] + else + fit_shift[1] = -shift[1] + } + + ID_IC(id) = ic1 + call id_gdata (id) + iferr (call id_fitdata (id)) + ; + + call ri_loghdr (id, reference, logfd, nlogfd, loghdr) + loghdr = 0 + call ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + + if (ID_NFEATURES(id) < nreid && trace) { + call ri_loghdr (id, reference, logfd, nlogfd, 3) + break + } + + if (ID_NFEATURES(id) > 0) { + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + call id_saveid (id, line) + } + } + + ID_IC(id) = ic + i = id_gid (id, start) + fit_shift[1] = fit_shift[2] + for (line[1]=start[1]+step[1]; line[1]<=ID_MAXLINE(id,1); + line[1]=line[1]+step[1]) { + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + ID_IC(id) = ic + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + if (!override) + if (id_dbcheck (id, Memc[ID_IMAGE(id)], ID_AP(id,1)) == YES) + next + + if (!trace) { + i = id_gid (id, start) + ID_LINE(id,1) = line[1] + ID_LINE(id,2) = line[2] + } + + if (IS_INDEFD(shift[1])) + fit_shift[1] = INDEFD + else { + if (!trace) + fit_shift[1] = fit_shift[1] + shift[1] + else + fit_shift[1] = shift[1] + } + + ID_IC(id) = ic1 + call id_gdata (id) + iferr (call id_fitdata (id)) + ; + + call ri_loghdr (id, reference, logfd, nlogfd, loghdr) + loghdr = 0 + call ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + + if (ID_NFEATURES(id) < nreid && trace) { + call ri_loghdr (id, reference, logfd, nlogfd, 3) + break + } + + if (ID_NFEATURES(id) > 0) { + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + call id_saveid (id, line) + } + } + } + + + fit_shift[2] = 0. + for (line[2]=start[2]+step[2]; line[2]<=ID_MAXLINE(id,2); + line[2]=line[2]+step[2]) { + ID_LINE(id,2) = line[2] + ID_AP(id,2) = line[2] + ID_IC(id) = ic + + if (IS_INDEFD(shift[2])) + fit_shift[2] = INDEFD + else { + if (!trace) + fit_shift[2] = fit_shift[2] + shift[2] + else + fit_shift[2] = shift[2] + } + + fit_shift[1] = fit_shift[2] + for (line[1]=start[1]; line[1]>0; line[1]=line[1]-step[1]) { + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + ID_IC(id) = ic + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + if (!override) + if (id_dbcheck (id, Memc[ID_IMAGE(id)], ID_AP(id,1)) == YES) + next + + if (!trace) { + i = id_gid (id, start) + ID_LINE(id,1) = line[1] + ID_LINE(id,2) = line[2] + } + + if (IS_INDEFD(shift[1])) + fit_shift[1] = INDEFD + else { + if (!trace) + fit_shift[1] = fit_shift[1] - shift[1] + else + fit_shift[1] = -shift[1] + } + + ID_IC(id) = ic1 + call id_gdata (id) + iferr (call id_fitdata (id)) + ; + + call ri_loghdr (id, reference, logfd, nlogfd, loghdr) + loghdr = 0 + call ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + + if (ID_NFEATURES(id) < nreid && trace) { + call ri_loghdr (id, reference, logfd, nlogfd, 3) + break + } + + if (ID_NFEATURES(id) > 0) { + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + call id_saveid (id, line) + } + } + + ID_IC(id) = ic + i = id_gid (id, start) + fit_shift[1] = fit_shift[2] + for (line[1]=start[1]+step[1]; line[1]<=ID_MAXLINE(id,1); + line[1]=line[1]+step[1]) { + ID_LINE(id,1) = line[1] + ID_AP(id,1) = line[1] + ID_IC(id) = ic + if (ID_APS(id) != NULL) + ID_AP(id,1) = Memi[ID_APS(id)+line[1]-1] + if (!override) + if (id_dbcheck (id, Memc[ID_IMAGE(id)], ID_AP(id,1)) == YES) + next + + if (!trace) { + i = id_gid (id, start) + ID_LINE(id,1) = line[1] + ID_LINE(id,2) = line[2] + } + + if (IS_INDEFD(shift[1])) + fit_shift[1] = INDEFD + else { + if (!trace) + fit_shift[1] = fit_shift[1] + shift[1] + else + fit_shift[1] = shift[1] + } + + ID_IC(id) = ic1 + call id_gdata (id) + iferr (call id_fitdata (id)) + ; + + call ri_loghdr (id, reference, logfd, nlogfd, loghdr) + loghdr = 0 + call ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + + if (ID_NFEATURES(id) < nreid && trace) { + call ri_loghdr (id, reference, logfd, nlogfd, 3) + break + } + + if (ID_NFEATURES(id) > 0) { + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + call id_saveid (id, line) + } + } + } + + ID_IC(id) = ic + if (ic != ic1) + call ic_closed (ic1) + + call smw_close (MW(ID_SH(id))) + call imunmap (IM(ID_SH(id))) + call shdr_close (ID_SH(id)) +end + + +# RI_IMAGE -- Reidentify an image. + +procedure ri_image (id, reference, image, ans, logfd, nlogfd, pd) + +pointer id # ID pointer +char reference[ARB] # Reference image +char image[ARB] # Image to be reidentified +char ans[3] # Interactive? +int logfd[ARB] # Logfiles +int nlogfd # Number of logfiles +pointer pd # Plot file pointer + +bool newaps # Add new apertures not in reference? +bool override # Override previous identifications? +bool verbose # Verbose output? + +int i, j, ap, loghdr, id_getid(), id_dbcheck() +double shift, fit_shift, clgetd() +pointer ic, ic1 +bool clgetb() + +begin + # Open the image and return if there is an error. + call strcpy (image, Memc[ID_IMAGE(id)], SZ_FNAME) + iferr (call id_map (id)) { + call erract (EA_WARN) + return + } + call dtunmap (ID_DT(id)) + + newaps = clgetb ("newaps") + override = clgetb ("override") + verbose = clgetb ("verbose") + + ic = ID_IC(id) + if (ans[1] == 'N') + ic1 = ic + else + call ic_open (ic1) + + loghdr = 2 + shift = clgetd ("shift") + + # For MULTISPEC search the reference list of each aperture. If + # a reference of the same aperture is not found and the newaps + # flag is set use the initial reference and then add the + # reidentification to the reference list. + # For NDSPEC apply each reference to the image. + + if (SMW_FORMAT(MW(ID_SH(id))) == SMW_ES || + SMW_FORMAT(MW(ID_SH(id))) == SMW_MS) { + for (i=1; i<=ID_MAXLINE(id,1); i=i+1) { + ap = Memi[ID_APS(id)+i-1] + for (j=ID_NID(id); id_getid (id,j)!=EOF; j=j-1) + if (ap == ID_AP(id,1)) + break + + if (j == 0 && !newaps) { + if (verbose) { + call printf ( + "%s: Reference for aperture %d not found\n") + call pargstr (image) + call pargi (ap) + } + next + } + + ID_AP(id,1) = ap + ID_LINE(id,1) = i + + if (i == 1 && ic != ic1) + call ic_copy (ic, ic1) + + if (!override) + if (id_dbcheck (id, Memc[ID_IMAGE(id)], ID_AP(id,1)) == YES) + next + + ID_IC(id) = ic1 + call id_gdata (id) + iferr (call id_fitdata (id)) + ; + + call ri_loghdr (id, reference, logfd, nlogfd, loghdr) + loghdr = 0 + + fit_shift = shift + call ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + + if (ID_NFEATURES(id) > 0) { + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + if (j == 0 && newaps) { + call id_sid (id, ID_NID(id)+1) + if (verbose) { + call printf ( + "%s: New reference for aperture %d\n") + call pargstr (image) + call pargi (ap) + } + } + } + ID_IC(id) = ic + } + + } else { + for (i=1; id_getid (id,i)!=EOF; i=i+1) { + if (i == 1 && ic != ic1) + call ic_copy (ic, ic1) + + if (!override) + if (id_dbcheck (id, Memc[ID_IMAGE(id)], ID_AP(id,1)) == YES) + next + + ID_IC(id) = ic1 + call id_gdata (id) + iferr (call id_fitdata (id)) + ; + + call ri_loghdr (id, reference, logfd, nlogfd, loghdr) + loghdr = 0 + + fit_shift = shift + call ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + + if (ID_NFEATURES(id) > 0) + call id_dbwrite (id, Memc[ID_IMAGE(id)], ID_AP(id,1), NO) + ID_IC(id) = ic + } + } + + ID_IC(id) = ic + if (ic != ic1) + call ic_closed (ic1) + call smw_close (MW(ID_SH(id))) + call imunmap (IM(ID_SH(id))) + call shdr_close (ID_SH(id)) +end + + +# RI_REIDENTIFY -- Reidentify features using a reference image database entry. + +procedure ri_reidentify (id, fit_shift, ans, logfd, nlogfd, pd) + +pointer id # ID pointer +double fit_shift # Shift in fit coords (input and output) +char ans[3] # Interactive? +int logfd[ARB] # Logfiles +int nlogfd # Number of logfiles +pointer pd # Plot file pointer + +int i, j, nfeatures1, nfeatures2, nfit, iden, mono, clgwrd() +double shift, pix_shift, z_shift, v, vrms +double id_fitpt(), fit_to_pix(), id_shift(), id_center(), id_rms(), id_zval() +pointer sp, pix, fit +bool clgetb() + +begin + nfeatures1 = ID_NFEATURES(id) + call smark (sp) + call salloc (pix, nfeatures1, TY_DOUBLE) + call salloc (fit, nfeatures1, TY_DOUBLE) + call amovd (PIX(id,1), Memd[pix], nfeatures1) + call amovd (FIT(id,1), Memd[fit], nfeatures1) + + # If no initial shift is given then the procedure id_shift + # computes a shift between the reference features and the + # features in the image. The purpose of the shift is to get the + # reference feature positions close enough to those of the image + # being identified that the centering algorithm will determine + # the exact positions of the features. An initial shift of zero + # is used if the two images are very nearly aligned as in the + # case of tracing features in a two dimensional image or for a + # set of images taken with the same observing setup. + + if (IS_INDEFD(fit_shift)) { + ID_FWIDTH(id) = FWIDTH(id,1) + ID_FTYPE(id) = FTYPE(id,1) + shift = id_shift (id) + } else + shift = fit_shift + + # For each reference feature a shift is added to bring the pixel + # position near that for the image being identified and then the + # centering algorithm is used. If the centering algorithm fails + # the feature is discarded. A mean shift is computed for the + # features which have been reidentified. + + do i = 1, ID_NFEATURES(id) { + PIX(id,i) = fit_to_pix (id, FIT(id,i) + shift) + PIX(id,i) = id_center (id, PIX(id,i), 1, FWIDTH(id,i), FTYPE(id,i), + NO) + if (!IS_INDEFD(PIX(id,i))) + FIT(id,i) = id_fitpt (id, PIX(id,i)) + } + for (i=1; i<ID_NFEATURES(id); i=i+1) { + if (IS_INDEFD(PIX(id,i))) + next + for (j=i+1; j<=ID_NFEATURES(id); j=j+1) { + if (IS_INDEFD(PIX(id,j))) + next + if (abs (PIX(id,i)-PIX(id,j)) < ID_MINSEP(id)) { + if (abs (FIT(id,i)-USER(id,i)) < abs (FIT(id,j)-USER(id,j))) + PIX(id,j) = INDEFD + else { + PIX(id,i) = INDEFD + break + } + } + } + } + + pix_shift = 0. + fit_shift = 0. + z_shift = 0. + j = 0 + do i = 1, ID_NFEATURES(id) { + if (IS_INDEFD(PIX(id,i))) + next + + pix_shift = pix_shift + PIX(id,i) - Memd[pix+i-1] + fit_shift = fit_shift + FIT(id,i) - Memd[fit+i-1] + if (Memd[fit+i-1] != 0.) + z_shift = z_shift + id_zval (id, FIT(id,i), Memd[fit+i-1]) + + j = j + 1 + PIX(id,j) = PIX(id,i) + FIT(id,j) = FIT(id,i) + USER(id,j) = USER(id,i) + WTS(id,j) = WTS(id,i) + FWIDTH(id,j) = FWIDTH(id,i) + FTYPE(id,j) = FTYPE(id,i) + } + ID_NFEATURES(id) = j + + nfeatures2 = j + pix_shift = pix_shift / max (1, ID_NFEATURES(id)) + fit_shift = fit_shift / max (1, ID_NFEATURES(id)) + z_shift = z_shift / max (1, ID_NFEATURES(id)) + + # If refitting the coordinate function is requested and there is + # more than one feature and there is a previously defined + # coordinate function then refit. Otherwise compute a coordinate + # shift. + + mono = YES + switch (ID_REFIT(id)) { + case 1: + if (ID_CV(id) != NULL) { + if (ID_NFEATURES(id)>1) + call id_dofit (id, NO) + else + call id_doshift (id, NO) + } + case 2: + if (ID_CV(id) != NULL) + call id_doshift (id, NO) + case 3: + call id_velocity (id, NO) + v = ID_REDSHIFT(id) * VLIGHT + vrms = ID_RMSRED(id) * VLIGHT + } + if (ID_NEWCV(id) == YES) { + iferr (call id_fitdata (id)) + mono = NO + call id_fitfeatures (id) + } + + if (clgetb ("addfeatures")) { + ID_FWIDTH(id) = FWIDTH(id,1) + ID_FTYPE(id) = FTYPE(id,1) + call id_linelist (id) + if (ID_NEWFEATURES(id) == YES) { + switch (ID_REFIT(id)) { + case 1: + if (ID_NFEATURES(id)>1) + call id_dofit (id, NO) + else + call id_doshift (id, NO) + case 2: + call id_doshift (id, NO) + case 3: + call id_velocity (id, NO) + v = ID_REDSHIFT(id) * VLIGHT + vrms = ID_RMSRED(id) * VLIGHT + } + if (ID_NEWCV(id) == YES) { + iferr (call id_fitdata (id)) + mono = NO + call id_fitfeatures (id) + } + } + } + + # Enter fitting interactively. + iden = NO + if ((ID_NFEATURES(id)>1) && (ID_CV(id)!=NULL || ID_REFIT(id) == 3)) { + if (ans[1] != 'N') { + if (ans[1] != 'Y') { + nfit = 0 + for (j=1; j<=ID_NFEATURES(id); j=j+1) + if (WTS(id,j) > 0.) + nfit = nfit + 1 + call printf ( + "%s%s%23t%3d/%-3d %3d/%-3d %9.3g %10.3g %7.3g %7.3g\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargi (nfeatures2) + call pargi (nfeatures1) + call pargi (nfit) + call pargi (ID_NFEATURES(id)) + call pargd (pix_shift) + call pargd (fit_shift) + if (ID_REFIT(id) == 3) { + call pargd (v) + call pargd (vrms) + } else { + call pargd (z_shift) + call pargd (id_rms(id)) + } + call flush (STDOUT) + repeat { + ifnoerr (i = clgwrd ("answer", ans, SZ_FNAME, + "|no|yes|NO|YES|")) + break + } + call clpstr ("answer", ans) + } + switch (ans[1]) { + case 'y', 'Y': + mono = YES + i = ID_REFIT(id) + call reidentify (id) + ID_REFIT(id) = i + if (ID_REFIT(id) == 3) { + call id_velocity (id, NO) + v = ID_REDSHIFT(id) * VLIGHT + vrms = ID_RMSRED(id) * VLIGHT + } + iden = YES + } + if (ans[1] != 'Y') + call gdeactivate (ID_GP(id), 0) + } + } + + # Record log information if a log file descriptor is given. + for (i = 1; i <= nlogfd; i = i + 1) { + if (ans[1] == 'n' && logfd[i] == STDOUT) + next + nfit = 0 + for (j=1; j<=ID_NFEATURES(id); j=j+1) + if (WTS(id,j) > 0.) + nfit = nfit + 1 + call fprintf (logfd[i], + "%s%s%23t%3d/%-3d %3d/%-3d %9.3g %10.3g %7.3g %7.3g\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargi (nfeatures2) + call pargi (nfeatures1) + call pargi (nfit) + call pargi (ID_NFEATURES(id)) + call pargd (pix_shift) + call pargd (fit_shift) + if (ID_REFIT(id) == 3) { + call pargd (v) + call pargd (vrms) + } else { + call pargd (z_shift) + call pargd (id_rms(id)) + } + if (ID_REFIT(id) == 3 && logfd[i] != STDOUT) + call id_log (id, "", logfd[i]) + if (mono == NO) + call fprintf (logfd[i], "Non-monotonic dispersion function") + call flush (logfd[i]) + if (logfd[i] == STDOUT) + iden = NO + } + # Print log if STDOUT is not used but if the IDENTIFY is done. + if (iden == YES) { + call printf ( + "%s%s%23t%3d/%-3d %3d/%-3d %9.3g %10.3g %7.3g %7.3g\n") + call pargstr (Memc[ID_IMAGE(id)]) + call pargstr (Memc[ID_SECTION(id)]) + call pargi (nfeatures2) + call pargi (nfeatures1) + call pargi (nfit) + call pargi (ID_NFEATURES(id)) + call pargd (pix_shift) + call pargd (fit_shift) + if (ID_REFIT(id) == 3) { + call pargd (v) + call pargd (vrms) + } else { + call pargd (z_shift) + call pargd (id_rms(id)) + } + if (mono == NO) + call printf ("Non-monotonic dispersion function") + call flush (STDOUT) + } + + # Make log plot. + call ri_plot (id, pd) + + call sfree (sp) +end + + +# RI_LOGHDR -- Print a log header in the log files. + +procedure ri_loghdr (id, reference, logfd, nlogfd, flag) + +pointer id # Identify structure +char reference[ARB] # Reference image +int logfd[ARB] # Log file descriptors +int nlogfd # Number of log files +int flag # Header type flag (1=banner, 2=Column labels, 3=Error) + +int i +pointer str + +begin + for (i = 1; i <= nlogfd; i = i + 1) { + switch (flag) { + case 1: # Print ID + call malloc (str, SZ_LINE, TY_CHAR) + call sysid (Memc[str], SZ_LINE) + switch (ID_REFIT(id)) { + case 1, 2: + call fprintf (logfd[i], "\nREIDENTIFY: %s\n") + call pargstr (Memc[str]) + case 3: + call fprintf (logfd[i], "\nRVREIDLINES: %s\n") + call pargstr (Memc[str]) + } + call mfree (str, TY_CHAR) + case 2: # Print labels + switch (ID_REFIT(id)) { + case 1, 2: + call fprintf (logfd[i], + " Reference image = %s, New image = %s, Refit = %b\n") + call pargstr (reference) + call pargstr (Memc[ID_IMAGE(id)]) + call pargi (ID_REFIT(id)) + call fprintf (logfd[i], + "%20s %7s %7s %9s %10s %7s %7s\n") + call pargstr ("Image Data") + call pargstr ("Found") + call pargstr ("Fit") + call pargstr ("Pix Shift") + call pargstr ("User Shift") + call pargstr ("Z Shift") + call pargstr ("RMS") + case 3: + call fprintf (logfd[i], + " Reference image = %s, New image = %s\n") + call pargstr (reference) + call pargstr (Memc[ID_IMAGE(id)]) + call fprintf (logfd[i], + "%20s %7s %7s %9s %10s %8s %7s\n") + call pargstr ("Image Data") + call pargstr ("Found") + call pargstr ("Fit") + call pargstr ("Pix Shift") + call pargstr ("User Shift") + call pargstr ("Velocity") + call pargstr ("RMS") + } + case 3: # Error + call fprintf (logfd[i], " ** Too many features lost **\n") + } + } +end + + +# RI_PLOT -- Plot residual graph of reidentified lines. + +procedure ri_plot (id, pd) + +pointer id # ID pointer +pointer pd # GIO pointer + +int i, j +pointer sp, str, x, y, gt, gt_init() +double id_zshiftd() + +begin + # Check if there is anything to plot. + if (pd == NULL || ID_NFEATURES(id) == 0) + return + + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (x, ID_NFEATURES(id), TY_REAL) + call salloc (y, ID_NFEATURES(id), TY_REAL) + + # Set plot points. + j = 0 + do i = 1, ID_NFEATURES(id) { + if (IS_INDEFD(USER(id,i))) + break + + Memr[x+j] = USER(id,i) + Memr[y+j] = id_zshiftd (id, FIT(id,i), 0) + j = j + 1 + } + + if (j == 0) { + call sfree (sp) + return + } + + # Make the plot. + call sprintf (Memc[str], SZ_LINE, "Reidentify: %s") + call pargstr (Memc[ID_IMAGE(id)]) + gt = gt_init () + call gt_sets (gt, GTTYPE, "mark") + call gt_sets (gt, GTXLABEL, "user coordinates") + call gt_sets (gt, GTYLABEL, "residuals (fit - user)") + call gt_sets (gt, GTTITLE, Memc[str]) + call gclear (pd) + call gascale (pd, Memr[x], j, 1) + call gascale (pd, Memr[y], j, 2) + call gt_swind (pd, gt) + call gt_labax (pd, gt) + call gt_plot (pd, gt, Memr[x], Memr[y], j) + call gt_free (gt) + + call sfree (sp) +end diff --git a/noao/rv/rvimutil.x b/noao/rv/rvimutil.x new file mode 100644 index 00000000..31b39c5e --- /dev/null +++ b/noao/rv/rvimutil.x @@ -0,0 +1,457 @@ +include <imhdr.h> +include "rvpackage.h" +include "rvflags.h" +include "rvkeywords.h" + +# RVIMUTIL.X - Image utility routines for operations on image list pointers. +# Procedures to position pointers by reading next, previous, or random +# images. Also included are miscellaneous routines for getting image info +# from just a name. + + +# NEXT_SPEC - Get the next spectrum in the input file list. Updates the +# image number in the struct and returns an error code if something went wrong. + +int procedure next_spec (rv, infile, written) + +pointer rv #I RV struct pointer +pointer infile #I File list pointer +bool written #U Have results been written? + +char imname[SZ_FNAME] +#int get_spec(), rv_verify_aps(), imtrgetim(), imtlen() +int get_spec(), rv_apnum_range(), imtrgetim(), imtlen() +real clgetr() + +begin + if (RV_IMNUM(rv)+1 <= imtlen(infile)) { + RV_IMNUM(rv) = RV_IMNUM(rv) + 1 + #if (rv_verify_aps(rv,APPARAM(rv),APLIST(rv,1),NUMAPS(rv)) != OK) + if (rv_apnum_range(rv,APPARAM(rv)) != OK) + return (ERR_READ) + if (imtrgetim(infile,RV_IMNUM(rv),imname,SZ_FNAME) != EOF) { + if (get_spec(rv, imname, OBJECT_SPECTRUM) == ERR_READ) + return (ERR_READ) + written = false + + # Now update the data cache flags + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + RV_WINCENPAR(rv) = clgetr ("wincenter") + call amovkr (0.0, COEFF(rv,1), 4) + + } else + call rv_errmsg ("Error reading next image name from list.") + } else { + call rv_errmsg ("At end of input list.") + RV_NEWXCOR(rv) = NO + } + + return (OK) +end + + +# PREV_SPEC - Get the previous spectrum in the input file list. Updates the +# image number in the struct and returns an error code if something went wrong. + +int procedure prev_spec (rv, infile, written) + +pointer rv #I RV struct pointer +pointer infile #I File list pointer +bool written #U Have results been written? + +char imname[SZ_FNAME] +int get_spec(), imtrgetim(), rv_apnum_range() +real clgetr() + +begin + if (RV_IMNUM(rv)-1 >= 1) { + RV_IMNUM(rv) = RV_IMNUM(rv) - 1 + if (rv_apnum_range(rv,APPARAM(rv)) != OK) + return (ERR_READ) + if (imtrgetim(infile,RV_IMNUM(rv),imname,SZ_FNAME) != EOF) { + if (get_spec(rv, imname, OBJECT_SPECTRUM) == ERR_READ) + return (ERR_READ) + written = false + + # Now update the data cache flags + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + RV_WINCENPAR(rv) = clgetr ("wincenter") + call amovkr (0.0, COEFF(rv,1), 4) + + } else + call rv_errmsg ("Error reading previous image from list.") + } else { + call rv_errmsg ("At beginning of input list.") + RV_NEWXCOR(rv) = NO + } + + return (OK) +end + + +# NEXT_TEMP - Get the next spectrum in the template file list. Updates the +# template number in the struct and returns an error code if something went +# wrong. + +int procedure next_temp (rv, rinfile, written) + +pointer rv #I RV struct pointer +pointer rinfile #I Template list pointer +bool written #U Have results been written? + +int imtrgetim(), get_spec(), rv_verify_aps() +real clgetr() + +begin + if (RV_TEMPNUM(rv)+1 <= RV_NTEMPS(rv)) { + RV_TEMPNUM(rv) = RV_TEMPNUM(rv) + 1 + if (rv_verify_aps(rv,APPARAM(rv),APLIST(rv,1),NUMAPS(rv)) != OK) + return (ERR_READ) + if (imtrgetim(rinfile,RV_TEMPNUM(rv),RIMAGE(rv),SZ_FNAME) != EOF){ + if (get_spec(rv,RIMAGE(rv),REFER_SPECTRUM) == ERR_READ) + call error (0,"Error reading next template.") + call rv_imtitle (RIMAGE(rv), TEMPNAME(rv), SZ_FNAME) + written = false + RV_TEMPCODE(rv) = TEMPCODE(rv,RV_TEMPNUM(rv)) + call amovkr (0.0, COEFF(rv,1), 4) + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + RV_WINCENPAR(rv) = clgetr ("wincenter") + + } else + call rv_errmsg ("Error reading next image name from list.") + } else { + call rv_errmsg ("At end of template list.") + RV_NEWXCOR(rv) = NO + } + + return (OK) +end + + +# PREV_TEMP - Get the previous spectrum in the template file list. Updates the +# template number in the struct and returns an error code if something went +# wrong. + +int procedure prev_temp (rv, rinfile, written) + +pointer rv #I RV struct pointer +pointer rinfile #I File list pointer +bool written #U Have results been written? + +int imtrgetim(), get_spec(), rv_verify_aps() +real clgetr() + +begin + if (RV_TEMPNUM(rv)-1 >= 1) { + RV_TEMPNUM(rv) = RV_TEMPNUM(rv) - 1 + if (rv_verify_aps(rv,APPARAM(rv),APLIST(rv,1),NUMAPS(rv)) != OK) + return (ERR_READ) + if (imtrgetim(rinfile,RV_TEMPNUM(rv),RIMAGE(rv),SZ_FNAME) != EOF){ + if (get_spec(rv,RIMAGE(rv),REFER_SPECTRUM) == ERR_READ) + call error (0,"Error reading next template.") + call rv_imtitle (RIMAGE(rv), TEMPNAME(rv), SZ_FNAME) + written = false + RV_TEMPCODE(rv) = TEMPCODE(rv,RV_TEMPNUM(rv)) + call amovkr (0.0, COEFF(rv,1), 4) + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + RV_WINCENPAR(rv) = clgetr ("wincenter") + + } else + call rv_errmsg ("Error reading previous image from list.") + } else { + call rv_errmsg ("At beginning of template list.") + RV_NEWXCOR(rv) = NO + } + + return (OK) +end + + +# NEXT_AP - Get the next spectrum in the aperture data list. Updates the +# aperture number in the struct and returns an error code if something went +# wrong. + +int procedure next_ap (rv, written) + +pointer rv #I RV struct pointer +bool written #I Have results been written? + +int apnum +int rv_imdim(), rv_getim() +real clgetr() +bool silent + +begin + silent = false + if (CURAPNUM(rv) == 0) { + apnum = 1 + silent = TRUE + } else + apnum = CURAPNUM(rv) + + if (apnum+1 > NUMAPS(rv)) { + if (!silent) { + call rv_errmsg ("At end of object aperture list.") + RV_NEWXCOR(rv) = NO + } + return (OK) + } else { + # Get the next object aperture + CURAPNUM(rv) = CURAPNUM(rv) + 1 + RV_APNUM(rv) = APLIST(rv,CURAPNUM(rv)) + if (rv_getim(rv, IMAGE(rv), OBJECT_SPECTRUM, INDEF, INDEF, + INDEFI) == ERR_READ) { + RV_APNUM(rv) = APLIST(rv,apnum) + RV_OAPNUM(rv) = RV_APNUM(rv) + return (ERR_READ) + } + written = false + + # Now update the data cache flags + call amovkr (0.0, COEFF(rv,1), 4) + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + RV_WINCENPAR(rv) = clgetr ("wincenter") + } + + # Now try to get the next template aperture (may be one-dimensional) + if (rv_imdim(RIMAGE(rv),2) > 1) { + if (apnum+1 > NUMAPS(rv)) { + call rv_errmsg ("At end of template aperture list.") + RV_NEWXCOR(rv) = NO + } else { + if (rv_getim(rv,RIMAGE(rv), REFER_SPECTRUM, INDEF, INDEF, + INDEFI) == ERR_READ) + return (ERR_READ) + written = false + } + } + + return (OK) +end + + +# PREV_AP - Get the previous spectrum in the aperture data list. Updates the +# aperture number in the struct and returns an error code if something went +# wrong. Since all of the aperture have been read from disk, just decrement +# the aperture number and pull the data from the BIN cache. + +int procedure prev_ap (rv, written) + +pointer rv #I RV struct pointer +bool written #I Have results been written? + +int apnum +int rv_imdim(), rv_getim() +real clgetr() +bool silent + +begin + silent = false + if (apnum == (NUMAPS(rv) + 1)) { + apnum = NUMAPS(rv) + silent = TRUE + } else + apnum = CURAPNUM(rv) + + if (apnum-1 < 1) { + if (!silent) { + call rv_errmsg ("At beginning of object aperture list.") + RV_NEWXCOR(rv) = NO + } + return (OK) + } else { + # Get the next object aperture + CURAPNUM(rv) = CURAPNUM(rv) - 1 + RV_APNUM(rv) = APLIST(rv,CURAPNUM(rv)) + if (rv_getim(rv, IMAGE(rv), OBJECT_SPECTRUM, INDEF, INDEF, + INDEFI) == ERR_READ) { + RV_APNUM(rv) = APLIST(rv,apnum) + RV_OAPNUM(rv) = RV_APNUM(rv) + return (ERR_READ) + } + written = false + + # Now update the data cache flags + call amovkr (0.0, COEFF(rv,1), 4) + RV_FITDONE(rv) = NO + RV_NEWXCOR(rv) = YES + IS_DBLSTAR(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + RV_WINCENPAR(rv) = clgetr ("wincenter") + } + + # Now try to get the next previous aperture (may be one-dimensional) + if (rv_imdim(RIMAGE(rv),2) > 1) { + if (rv_getim(rv, RIMAGE(rv), REFER_SPECTRUM, INDEF, INDEF, + INDEFI) == ERR_READ) + return (ERR_READ) + written = false + } + + return (OK) +end + + +# GET_SPEC - Low level routine to do the common drudge work of reading the +# spectrum, plotting the new spec and displaying mask. + +int procedure get_spec (rv, imname, spec_type) + +pointer rv #I RV struct pointer +char imname[SZ_FNAME] #I Image name to read +int spec_type #I Type of spectrum to read + +int rv_getim() + +begin + # Try to read the data from the image + if (rv_getim(rv, imname, spec_type, INDEF, INDEF, INDEFI) == ERR_READ) { + RV_NEWXCOR(rv) = NO + return (ERR_READ) + } + RV_NEWXCOR(rv) = YES + return (OK) +end + + +# CONSTRUCT_FILE_NAMES - Construct the log file names from a root + +procedure cons_file_names (root, log, meta, verb, maxch) + +char root[maxch] #I Root file name +char log[maxch] #O Text log file name +char meta[maxch] #O Metacode file name +char verb[maxch] #O Verbose file name +int maxch #I Max chars + +begin + call sprintf (log, maxch, "%s.txt") + call pargstr (root) + call sprintf (meta, maxch, "%s.gki") + call pargstr (root) + call sprintf (verb, maxch, "%s.log") + call pargstr (root) +end + + +# RV_IMDIM - Utility to get simply a dimensionality of an image name. + +int procedure rv_imdim (image, dim) + +char image[SZ_FNAME] #I Image name +int dim #I Which dimension to get + +int dim_len +pointer im, sp, bp, immap() +errchk immap + +begin + call smark (sp) + call salloc (bp, SZ_FNAME, TY_CHAR) + + iferr (im = immap(image, READ_ONLY, 0)) { + call sprintf (Memc[bp], SZ_FNAME, + "rv_imdim: Error opening image `%s'.") + call pargstr (image) + call error (0, Memc[bp]) + } + + if (dim == 1) { + dim_len = IM_LEN(im,1) + } else if (dim == 2) { + if (IM_NDIM(im) == 1 || (IM_NDIM(im) == 2 && IM_LEN(im,2) == 1)) + dim_len = 1 + else + dim_len = IM_LEN(im,2) + } else + dim_len = IM_LEN(im,dim) + + call imunmap (im) + call sfree (sp) + return (dim_len) +end + + +# RV_IMTITLE - Procedure to get the IM_TITLE string given a file name + +procedure rv_imtitle (image, title, maxchar) + +char image[SZ_FNAME] #I Image name +char title[SZ_FNAME] #O Title +int maxchar #I Max chars + +pointer im, sp, bp, immap() +errchk immap + +begin + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + iferr (im = immap(image, READ_ONLY, 0)) { + call sprintf (Memc[bp], SZ_FNAME, + "rv_imtitle: Error opening image `%s'.") + call pargstr (image) + call error (0, Memc[bp]) + } + call rv_fill_blanks (IM_TITLE(im), title, maxchar) + + call imunmap (im) + call sfree (sp) +end + + +# RV_IMTEMPVEL - Procedure to get the VHELIO string given a file name. + +real procedure rv_imtempvel (rv, image) + +pointer rv #I RV struct pointer +char image[SZ_FNAME] #I Image name + +pointer im, sp, bp, immap() +real tvel, imgetr() +int imaccf() +errchk immap, imaccf, imgetr + +begin + call smark (sp) + call salloc (bp, SZ_FNAME, TY_CHAR) + + iferr (im = immap(image, READ_ONLY, 0)) { + call sprintf (Memc[bp], SZ_FNAME, + "rv_imtempvel: Error opening image `%s'.") + call pargstr (image) + call error (0, Memc[bp]) + } + + # Get the velocity from the reference star image header. Save the + # warning for outputting results. + if (imaccf(im, KW_VHELIO(rv)) == YES) + tvel = imgetr (im, KW_VHELIO(rv)) + else + tvel = INDEFR + + call imunmap (im) + call sfree (sp) + return (tvel) +end diff --git a/noao/rv/rvinit.x b/noao/rv/rvinit.x new file mode 100644 index 00000000..670304af --- /dev/null +++ b/noao/rv/rvinit.x @@ -0,0 +1,345 @@ +include <pkg/gtools.h> +include <error.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" +include "rvsample.h" + +# RV_OPEN -- Allocate structure and initialize + +pointer procedure rv_open (spool, device, interactive) + +char spool[SZ_FNAME] #I Output spool filename +char device[SZ_FNAME] #I Graphics output device name +bool interactive #I Interactive operation? + +pointer rv +pointer sp, ip + +real clgetr () +int clgeti(), btoi(), strdic() +bool streq() + +errchk init_ptrs, init_files +errchk filt_open, plot_open, cont_open, keyw_open + +begin + call smark (sp) + call salloc (ip, SZ_FNAME, TY_CHAR) + + # Allocate space for the structure + iferr (call calloc (rv, LEN_RVSTRUCT, TY_STRUCT)) + call error (0, "Error allocating RV structure pointers.") + + # Initlialize pointers + call init_ptrs (rv) + + # Open the file descriptors + call init_files (rv, device, spool, interactive) + + # Now allocate the sub-structures, although not all may be used. + iferr { + call filt_open (rv) # open 'filterpars' struct + call plot_open (rv) # open 'plotpars' struct + call cont_open (rv) # open 'continpars' struct + call keyw_open (rv) # open 'keywpars' struct + } then + call error (0, "Error opening sub-structures.") + + # Get any package parameters. + RV_ZTHRESH(rv) = clgetr ("z_threshold") + RV_TOLERANCE(rv) = clgetr ("tolerance") + RV_MAXITERS(rv) = clgeti ("maxiters") + RV_LINECOLOR(rv) = clgeti ("line_color") + RV_TXTCOLOR(rv) = clgeti ("text_color") + call clgstr ("interp", Memc[ip], SZ_LINE) + if (streq(Memc[ip],"") || streq(Memc[ip]," ")) + call error (0,"Rv.interp specified as empty string.") + RV_INTERP(rv) = strdic (Memc[ip], Memc[ip], SZ_LINE, IN_FUNCTIONS) + + RV_INTERACTIVE(rv) = btoi (interactive) + + call sfree (sp) + return (rv) # return the pointer +end + + +# RV_CLOSE -- Free the RV structure pointers. + +procedure rv_close (rv) + +pointer rv #I RV struct pointer + +include "rvsinc.com" + +begin + # MFREE call is ignored if pointers are NULL + call mfree (RV_OPIXX(rv), TY_REAL) # Free the data pointers + call mfree (RV_OPIXY(rv), TY_REAL) + call mfree (RV_RPIXX(rv), TY_REAL) + call mfree (RV_RPIXY(rv), TY_REAL) + call mfree (RV_WKPIXX(rv), TY_REAL) + call mfree (RV_WKPIXY(rv), TY_REAL) + call mfree (RV_OCONTP(rv), TY_REAL) + call mfree (RV_RCONTP(rv), TY_REAL) + call mfree (RV_COEFFS(rv), TY_REAL) + call mfree (RV_ECOEFFS(rv), TY_REAL) + call mfree (RV_ANTISYM(rv), TY_REAL) + call mfree (RV_TEMPVEL(rv), TY_REAL) + call mfree (RV_DBL_SHIFT(rv), TY_REAL) + + call mfree (RV_APNUMKWD(rv),TY_CHAR) + call mfree (RV_APPARAM(rv), TY_CHAR) + call mfree (RV_CCFFILE(rv), TY_CHAR) + call mfree (RV_IMAGE(rv), TY_CHAR) + call mfree (RV_RIMAGE(rv), TY_CHAR) + call mfree (RV_SPOOL(rv), TY_CHAR) + call mfree (RV_DEVICE(rv), TY_CHAR) + call mfree (RV_OBJNAME(rv), TY_CHAR) + call mfree (RV_TEMPNAME(rv), TY_CHAR) + call mfree (DBG_FNAME(rv), TY_CHAR) + + call mfree (RV_APLIST(rv), TY_INT) + call mfree (RV_TCODE(rv), TY_INT) + + call mfree (splx, TY_REAL) # free up the sinc pointers + call mfree (sply, TY_REAL) + call mfree (sx, TY_REAL) + call mfree (sy, TY_REAL) + + call samp_close (RV_OSAMPLE(rv)) # Free sample structure ptrs + call samp_close (RV_RSAMPLE(rv)) + + if (RV_GT(rv) != NULL) + call gt_free (RV_GT(rv)) + if (RV_GP(rv) != NULL) + call gclose (RV_GP(rv)) + if (RV_MGP(rv) != NULL) + call gclose (RV_MGP(rv)) + if (RV_GRFD(rv) != NULL) + call close (RV_GRFD(rv)) + if (RV_TXFD(rv) != NULL) + call close (RV_TXFD(rv)) + if (RV_ICFIT(rv) != NULL) + call ic_closer (RV_ICFIT(rv)) + + if (RV_CONT(rv) != NULL) + call cont_close (rv) + if (RV_FILTP(rv) != NULL) + call filt_close (rv) + if (RV_KEYW(rv) != NULL) + call keyw_close (rv) + if (RV_PLOTP(rv) != NULL) + call plot_close (rv) + if (RV_OBSPTR(rv) != NULL) + call obsclose (RV_OBSPTR(rv)) + + if (DBG_FD(rv) != NULL) + call close (DBG_FD(rv)) + + call mfree (rv, TY_STRUCT) # Dump the struct +end + + +# INIT_PTRS - Inilialize all of the RV struct pointers to NULL + +procedure init_ptrs (rv) + +pointer rv #I RV struct pointer + +begin + RV_NPTS(rv) = 0 + RV_RNPTS(rv) = 0 + RV_CCFNPTS(rv) = 0 + RV_ISHIFT(rv) = 0 + RV_IMNUM(rv) = 1 + RV_TEMPNUM(rv) = 1 + RV_BACKGROUND(rv) = 0.0 + RV_FWHM_Y(rv) = INDEF + RV_OFORMAT(rv) = NULL + RV_RFORMAT(rv) = NULL + RV_OW0(rv) = 0.0 + RV_OWPC(rv) = 0.0 + RV_RW0(rv) = 0.0 + RV_RWPC(rv) = 0.0 + RV_SPMKEY(rv) = 'n' + RV_SPMPLOT(rv) = NORM_PLOT + RV_MODES(rv) = 1 + RV_PRINTZ(rv) = -1 + RV_STATLINE(rv) = 0 + RV_TEMPCODE(rv) = 'A' + RV_FITDONE(rv) = NO + RV_RESDONE(rv) = NO + RV_WINDOW(rv) = 20 + RV_WINCENTER(rv) = INDEFI + RV_WINL(rv) = INDEFI + RV_WINR(rv) = INDEFI + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + + # Initialize the data vectors + RV_OPIXX(rv) = NULL + RV_OPIXY(rv) = NULL + RV_RPIXX(rv) = NULL + RV_RPIXY(rv) = NULL + RV_WKPIXX(rv) = NULL + RV_WKPIXY(rv) = NULL + RV_OCONTP(rv) = NULL + RV_RCONTP(rv) = NULL + RV_ANTISYM(rv) = NULL + RV_TCODE(rv) = NULL + RV_ERRCOMMENTS(rv) = NULL + RV_CCFFILE(rv) = NULL + + # Pointers for other packages + RV_GP(rv) = NULL + RV_MGP(rv) = NULL + RV_GT(rv) = NULL + RV_NLFIT(rv) = NULL + RV_ICFIT(rv) = NULL + RV_MWCSP(rv) = NULL + + # Debug pointers + DBG_DEBUG(rv) = NO + DBG_FNAME(rv) = NULL + DBG_FD(rv) = STDOUT + DBG_OTHER(rv) = 0 + DBG_LEVEL(rv) = 4 + + # Miscellaneous + RV_APLIST(rv) = NULL + RV_OBJECTS(rv) = NULL + RV_TEMPLATES(rv)= NULL + RV_CMD(rv) = NULL + RV_APNUMKWD(rv) = NULL + RV_APPARAM(rv) = NULL + RV_ERRCODE(rv) = OK + + # Allocate space for the data info pointers + iferr { + call calloc (RV_TEMPVEL(rv), MAXTEMPS, TY_REAL) + + call calloc (RV_COEFFS(rv), 6, TY_REAL) + call calloc (RV_ECOEFFS(rv), 6, TY_REAL) + call calloc (RV_DBL_SHIFT(rv), DBL_LEN, TY_REAL) + + call calloc (RV_IMAGE(rv), SZ_FNAME, TY_CHAR) + call calloc (RV_RIMAGE(rv), SZ_FNAME, TY_CHAR) + call calloc (RV_SPOOL(rv), SZ_FNAME, TY_CHAR) + call calloc (RV_DEVICE(rv), SZ_FNAME, TY_CHAR) + call calloc (RV_OBJNAME(rv), SZ_FNAME, TY_CHAR) + call calloc (RV_TEMPNAME(rv), SZ_FNAME, TY_CHAR) + } then + call error (0, "Error allocating structure pointers.") + + IS_DBLSTAR(rv) = NO +end + + +# INIT_FILES - Initialize the log and metacode output files + +procedure init_files (rv, device, spool, interactive) + +pointer rv #I RV struct pointer +char device[SZ_FNAME] #I Graphics output device +char spool[SZ_FNAME] #I Root spool name +bool interactive #I Interactive flag + +pointer sp, log, meta, verb, pverb +bool streq() +int verbose, cod_verbose() +pointer open() +errchk open + +begin + call smark (sp) + call salloc (log, SZ_FNAME, TY_CHAR) + call salloc (meta, SZ_FNAME, TY_CHAR) + call salloc (verb, SZ_FNAME, TY_CHAR) + call salloc (pverb, SZ_FNAME, TY_CHAR) + + # Open the graphics pointer and file descriptors + if (!streq("", device)) + call strcpy (device, DEVICE(rv), SZ_FNAME) + call strcpy (spool, SPOOL(rv), SZ_FNAME) + if (streq("", spool) || streq(" ", spool)) { + RV_TXFD(rv) = NULL + RV_GRFD(rv) = NULL + RV_VBFD(rv) = NULL + if (!interactive) + call rv_errmsg ("Warning: No spool file specified.") + } else if (streq("STDOUT", spool)) { + RV_TXFD(rv) = STDOUT + RV_GRFD(rv) = NULL + RV_VBFD(rv) = NULL + } else { + # Open the files + iferr { + call cons_file_names (spool, Memc[log], Memc[meta], + Memc[verb], SZ_FNAME) + RV_TXFD(rv) = open (Memc[log], APPEND, TEXT_FILE) + call clgstr ("verbose", Memc[pverb], SZ_FNAME) + verbose = cod_verbose (Memc[pverb]) + if (verbose != OF_SHORT && + verbose != OF_NOLOG && + verbose != OF_TXTONLY && + verbose != OF_STXTONLY) { + RV_VBFD(rv) = open (Memc[verb], APPEND, TEXT_FILE) + } else + RV_VBFD(rv) = NULL + if (verbose != OF_NOGKI && + verbose != OF_TXTONLY && + verbose != OF_STXTONLY) { + RV_GRFD(rv) = open (Memc[meta], APPEND, BINARY_FILE) + } else + RV_GRFD(rv) = NULL + } then { + call sfree (sp) + call error (0, "Error opening spool file.") + } + } + + call sfree (sp) +end + + +# INIT_GP - Initialize the graphics and gtools descriptors + +procedure init_gp (rv, interactive, device) + +pointer rv # RV struct pointer +bool interactive # Interactive operation flag +char device[SZ_FNAME] # Output device + +pointer gopen(), gt_init() +int open(), tmp_fd +bool streq() +errchk gopen, gt_init, open + +begin + if (interactive) { + iferr { + if (streq("stdgraph",device)) { + RV_GP(rv) = gopen ("stdgraph", NEW_FILE, STDGRAPH) + } else { + tmp_fd = open (device, APPEND, BINARY_FILE) + RV_GP(rv) = gopen (device, APPEND, tmp_fd) + } + RV_GT(rv) = gt_init () + call gt_sets (RV_GT(rv), GTTYPE, "line") + } then + call error (0, "Error opening `stdgraph'.") + if (RV_GRFD(rv) != NULL) { + iferr (RV_MGP(rv) = gopen ("stdvdm", APPEND, RV_GRFD(rv))) + call error (0, "Error opening `stdvdm'.") + } else + RV_MGP(rv) = NULL + } else if (RV_GRFD(rv) != NULL) { + RV_GP(rv) = NULL + iferr (RV_MGP(rv) = gopen ("stdvdm", APPEND, RV_GRFD(rv))) + call error (0, "Error opening `stdvdm'.") + } else if (RV_GRFD(rv) == NULL && !interactive) { + RV_GP(rv) = NULL + RV_MGP(rv) = NULL + } +end diff --git a/noao/rv/rvkeywords.h b/noao/rv/rvkeywords.h new file mode 100644 index 00000000..bc211260 --- /dev/null +++ b/noao/rv/rvkeywords.h @@ -0,0 +1,22 @@ +# This is the include file for the keyword translation structure. The +# pointer in the main package structure is allocated to a length of +# LEN_KEYWSTRUCT and each of the keywords is maintain as a string whose +# maximum length is LEN_KEYWEL (this is usually set by a FITS standard) + +define LEN_KEYWEL 10 # Length of keyword element +define LEN_KEYWSTRUCT (16*LEN_KEYWEL) # Length of structure + +define KW_RA Memc[RV_KEYW($1)] +define KW_DEC Memc[RV_KEYW($1)+ 1*LEN_KEYWEL+1] +define KW_UT Memc[RV_KEYW($1)+ 2*LEN_KEYWEL+1] +define KW_UTMID Memc[RV_KEYW($1)+ 3*LEN_KEYWEL+1] +define KW_EXPTIME Memc[RV_KEYW($1)+ 4*LEN_KEYWEL+1] +define KW_EPOCH Memc[RV_KEYW($1)+ 5*LEN_KEYWEL+1] +define KW_DATE_OBS Memc[RV_KEYW($1)+ 6*LEN_KEYWEL+1] +define KW_HJD Memc[RV_KEYW($1)+ 7*LEN_KEYWEL+1] +define KW_MJD_OBS Memc[RV_KEYW($1)+ 8*LEN_KEYWEL+1] +define KW_VOBS Memc[RV_KEYW($1)+ 9*LEN_KEYWEL+1] +define KW_VREL Memc[RV_KEYW($1)+10*LEN_KEYWEL+1] +define KW_VHELIO Memc[RV_KEYW($1)+11*LEN_KEYWEL+1] +define KW_VLSR Memc[RV_KEYW($1)+12*LEN_KEYWEL+1] +define KW_VSUN Memc[RV_KEYW($1)+13*LEN_KEYWEL+1] diff --git a/noao/rv/rvlinefit.x b/noao/rv/rvlinefit.x new file mode 100644 index 00000000..b80a4f95 --- /dev/null +++ b/noao/rv/rvlinefit.x @@ -0,0 +1,214 @@ +include <error.h> +include <mach.h> +include <gset.h> +include "rvflags.h" +include "rvpackage.h" + +define SQ2PI 2.5066283 + + +# RV_LINEFIT - Fit a gaussian to a line between two specified endpoints. + +procedure rv_linefit (rv, x1, x2, stdlam, which) + +pointer rv #I RV struct pointer +real x1 #I left edge of fit +real x2 #I right edge of fit +real stdlam #I standard wavelength +int which #I which spectrum to fit + +int ix1, ix2 + +begin + if (which == OBJECT_SPECTRUM) { # Fit at the top + if (RV_DCFLAG(rv) != -1) { + x1 = (log10(x1) - RV_OW0(rv)) / RV_OWPC(rv) + 1 + x2 = (log10(x2) - RV_OW0(rv)) / RV_OWPC(rv) + 1 + } + ix1 = int (x1 + 0.5) # round off + ix2 = int (x2 + 0.5) + if (OBJCONT(rv) == NO) { + call rv_gfit (rv, RV_GP(rv), RV_OW0(rv), RV_OWPC(rv), + ix1, ix2, OBJPIXX(rv,1), OBJPIXY(rv,1), + RV_NPTS(rv), stdlam, TOP) + } else { + call rv_gfit (rv, RV_GP(rv), RV_OW0(rv), RV_OWPC(rv), + ix1, ix2, OBJPIXX(rv,1), OCONT_DATA(rv,1), + RV_NPTS(rv), stdlam, TOP) + } + + } else { + if (RV_DCFLAG(rv) != -1) { + x1 = (log10(x1) - RV_RW0(rv)) / RV_RWPC(rv) + 1 + x2 = (log10(x2) - RV_RW0(rv)) / RV_RWPC(rv) + 1 + } + ix1 = int (x1 + 0.5) # round off + ix2 = int (x2 + 0.5) + if (REFCONT(rv) == NO) { + call rv_gfit (rv, RV_GP(rv), RV_RW0(rv), RV_RWPC(rv), + ix1, ix2, REFPIXX(rv,1), REFPIXY(rv,1), + RV_RNPTS(rv), stdlam, BOTTOM) + } else { + call rv_gfit (rv, RV_GP(rv), RV_RW0(rv), RV_RWPC(rv), + ix1, ix2, REFPIXX(rv,1), RCONT_DATA(rv,1), + RV_RNPTS(rv), stdlam, BOTTOM) + } + } +end + + +# RV_GFIT -- Fit a Gaussian to a spectral line and output it's velocity +# based on a standard wavelength. + +procedure rv_gfit (rv, gp, w0, wpc, left, right, pixx, pixy, ndata, lam, + where) + +pointer rv #I RV task structure +pointer gp #I GIO pointer +real w0, wpc #I Dispsersion params +int left, right #I Fitting region endpoints +real pixx[ARB] #I Spectrum data +real pixy[ARB] #I Spectrum data +int ndata #I Number of points +real lam #I standard line wavelength +int where #I where to plot the line + +int i, j, npts, nlines +real w, wyc, wx, wy, wx2, wy2, wx1, wy1, a[5] +real x1, x2, y1, y2, range, peakx, vel, shift +real slope, height, flux, cont, sigma, eqw, scale, chisq +bool fit +pointer sp, x, y, z + +double dex(), rv_shift2vel() +real model(), rv_maxpix(), rv_minpix() +bool fp_equalr() +errchk dofit + +define done_ 99 + +begin + # Determine number of points to fit. + npts = right - left + 1 + if (npts < 3) { + call eprintf ("At least 3 points are required\n") + return + } + + # Allocate space for the points to be fit. + call smark (sp) + call salloc (x, npts, TY_REAL) + call salloc (y, npts, TY_REAL) + call salloc (z, npts, TY_REAL) + + # Scale the data. + scale = 0. + do i = 1, npts { + Memr[x+i-1] = dex (pixx[left+i-1]) + Memr[y+i-1] = pixy[left+i-1] + scale = max (scale, abs (Memr[y+i-1])) + } + if (fp_equalr(scale,0.0)) + scale = 1.0 + call adivkr (Memr[y], scale, Memr[y], npts) + + # Setup initial estimates. + wx1 = dex (pixx[left]) + wx2 = dex (pixx[right]) + wy1 = pixy[left] + wy2 = pixy[right] + slope = (wy2-wy1) / (wx2-wx1) / scale + wyc = wy1 / scale - slope * wx1 + wx = 0 + do i = 0, npts-1 { + w = Memr[x+i] + wy = Memr[y+i] - wyc - slope * w + if (abs (wy) > wx) { + wx = abs (wy) + j = i + peakx = w + } + } + + w = Memr[x+j-1] + wy = min (0.99, max (0.01, abs (Memr[y+j-1] - wyc - slope * w) / wx)) + sigma = sqrt (-0.5 * (w-peakx)**2 / log (wy)) + w = Memr[x+j+1] + wy = min (0.99, max (0.01, abs (Memr[y+j+1] - wyc - slope * w) / wx)) + sigma = sigma + sqrt (-0.5 * (w-peakx)**2 / log (wy)) + + # Do fit. + a[1] = w # initial shift + #a[2] = 0.25 * abs (Memr[x+npts-1] - Memr[x]) + a[2] = sigma / 2 + call pixind (w0, wpc, log10(w), i) + a[3] = (pixy[i] - (wyc + slope * (w - pixy[left]))) / scale + a[4] = 0. + a[5] = 1. + nlines = 1 + iferr { + call dofit ('a', Memr[x], Memr[y], npts, a, nlines, chisq) + call dofit ('b', Memr[x], Memr[y], npts, a, nlines, chisq) + } then { + call erract (EA_WARN) + fit = false + goto done_ + } + a[3] = a[3] * scale + wyc = (wyc + slope * wx1) * scale + slope = slope * scale + + # Compute model spectrum with continuum and plot. + fit = true + do i = 1, npts { + w = Memr[x+i-1] + Memr[z+i-1] = model (w, a, 5) + wyc + slope * (w - wx1) + } + + y2 = rv_maxpix (pixy, ndata) + y1 = rv_minpix (pixy, ndata) + range = abs (y2 - y1) + y2 = y2 + (.15 * range) + y1 = y1 - (.12 * range) + x1 = dex (pixx[1]) + x2 = dex (pixx[ndata]) + call gswind (gp, x1, x2, y1, y2) + if (where == TOP) + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + else + call gsview (gp, 0.115, 0.95, 0.125, 0.50) + call gseti (gp, G_PLTYPE, GL_DASHED) + call gseti (gp, G_PLCOLOR, RV_LINECOLOR(rv)) + call gpline (gp, Memr[x], Memr[z], npts) + call gseti (gp, G_PLTYPE, GL_DOTTED) + call gseti (gp, G_PLCOLOR, C_GREEN) + call gline (gp, wx1, wyc, wx2, wyc + slope * (wx2 - wx1)) + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + call gflush (gp) + +done_ + # Log computed values + if (fit) { + w = a[1] + cont = wyc + slope * (w - wx1) + height = a[3] + sigma = a[2] + flux = sigma * height * SQ2PI + shift = (log10(w) - log10(lam)) / wpc + vel = real (rv_shift2vel (rv, shift)) + if (cont > 0.) + eqw = -flux / cont + else + eqw = INDEF + + call printf ( + "center = %8.6g, vel = %8.4g, eqw = %6.4g, fwhm = %6.4g") + call pargr (w) + call pargr (vel) + call pargr (eqw) + call pargr (2.355 * sigma) + } + + call sfree (sp) +end diff --git a/noao/rv/rvpackage.h b/noao/rv/rvpackage.h new file mode 100644 index 00000000..7b08b453 --- /dev/null +++ b/noao/rv/rvpackage.h @@ -0,0 +1,270 @@ +# Header file for the Radial Velocity/Cross Correlation Package + +define RV_VERSION "RV Level-0 Release V1.3: 1/6/92" + +define LEN_RVSTRUCT 200 # Length of main data structure +define MAXTEMPS 702 # Max templates allowed +define DBL_LEN 50 # Deblended struct len +define SZ_APNUM 80 # Size of the APNUM field +define SZ_APLIST 256 # Size of APNUM keyword range + +# Image data pointers (current working set) +define RV_OPIXX Memi[$1] # Object x-axis (ptr) +define RV_OPIXY Memi[$1+1] # Object y-axis (ptr) +define RV_RPIXX Memi[$1+2] # Template x-axis (ptr) +define RV_RPIXY Memi[$1+3] # Template y-axis (ptr) +define RV_WKPIXX Memi[$1+4] # Working array x-axis (ptr) +define RV_WKPIXY Memi[$1+5] # Working array y-axis (ptr) + +# Task Parameters +define RV_APODIZE Memr[P2R($1+10)] # Endmask percentage +define RV_AUTOWRITE Memi[$1+11] # Auto record results? +define RV_AUTODRAW Memi[$1+12] # Auto redraw fit results? +define RV_CONTINUUM Memi[$1+13] # Continuum subtract spectra? +define RV_FILTER Memi[$1+14] # Fourier filter data? +define RV_INTERACTIVE Memi[$1+15] # Interactive flag? +define RV_PIXCORR Memi[$1+16] # Do a pixel-only correlation? +define RV_INTERP Memi[$1+17] # Rebinning interpolator + +# Peak Fitting Misc. +define RV_BACKGROUND Memr[P2R($1+20)] # baseline for FWHM computation +define RV_FITDONE Memi[$1+21] # Has a fit been done? +define RV_FITFUNC Memi[$1+22] # Correlation fitting func +define RV_FITHGHT Memr[P2R($1+23)] # Height of peak to begin fit +define RV_FITWIDTH Memr[P2R($1+24)] # Width of fitting region +define RV_ISHIFT Memi[$1+25] # Initial shift of ccf +define RV_ISTART Memi[$1+26] # Start element of ccf fit +define RV_IEND Memi[$1+27] # Ending element of ccf fit +define RV_MINWIDTH Memr[P2R($1+28)] # Min Width of fitting region +define RV_MAXWIDTH Memr[P2R($1+29)] # Max Width of fitting region +define RV_MAXITERS Memi[$1+30] # Max number of iterations +define RV_PEAK Memi[$1+31] # Is fitheight relative to peak height? +define RV_TOLERANCE Memr[P2R($1+32)] # Fitting tolerance +define RV_WEIGHTS Memr[P2R($1+33)] # Weighting power +define RV_WINPAR Memr[P2R($1+34)] # Size of plot window +define RV_WINCENPAR Memr[P2R($1+35)] # Center of plot window +define RV_WINDOW Memi[$1+36] # Size of plot window (array index) +define RV_WINCENTER Memi[$1+37] # Center of plot window (array index) +define RV_WINL Memi[$1+38] # Left edge of window (array index) +define RV_WINR Memi[$1+39] # Right edge of window (array index) + +# Miscellaneous values +define RV_APNUM Memi[$1+40] # Aperture number +define RV_CCFNPTS Memi[$1+41] # No. points in CCF +define RV_CURAPNUM Memi[$1+42] # Current aperture +define RV_DI1 Memi[$1+43] # Deblend continuum start index +define RV_DSCALE Memr[P2R($1+44)] # Deblend continuum scale +define RV_DSLOPE Memr[P2R($1+45)] # Deblend continuum slope +define RV_DX1 Memr[P2R($1+46)] # Start of deblend region +define RV_DY1 Memr[P2R($1+47)] # End of deblend region +define RV_DX2 Memr[P2R($1+48)] # Start of deblend region +define RV_DY2 Memr[P2R($1+49)] # End of deblend region +define RV_FILL Memi[$1+50] # Sample region filling type +define RV_FFTNPTS Memi[$1+51] # Npts in FFT of spectrum +define RV_IMNUM Memi[$1+52] # Image no. in input list +define RV_IMUPDATE Memi[$1+53] # Update image headers? +define RV_IS_DOUBLE Memi[$1+54] # Update image headers? +define RV_MODES Memi[$1+55] # Command mode structure +define RV_NOBJS Memi[$1+56] # Number of object spectra +define RV_NTEMPS Memi[$1+57] # Number of template spectra +define RV_NFITP Memi[$1+58] # Number of peak points fit +define RV_NPTS Memi[$1+59] # No. points in object +define RV_NSHIFTS Memi[$1+60] # No. of shift in deblend +define RV_NUMAPS Memi[$1+61] # No. of apertures in image +define RV_OAPNUM Memi[$1+62] # Object aperture number +define RV_REBIN Memi[$1+63] # Which spectrum to rebin +define RV_RNPTS Memi[$1+64] # No. points in refrence +define RV_RAPNUM Memi[$1+65] # Template aperture number +define RV_TEMPNUM Memi[$1+66] # Template image number +define RV_UPDATE Memi[$1+67] # Update since write flag +define RV_VERBOSE Memi[$1+68] # Verbose output format types +define RV_ZTHRESH Memr[P2R($1+69)] # Output redshift threshold + +# Observatory values +define RV_OBSPTR Memi[$1+70] # Observation Location (ptr) +define RV_ALTITUDE Memr[P2R($1+71)] # Altitude of observation +define RV_LATITUDE Memr[P2R($1+72)] # Latitude of observation +define RV_LONGITUDE Memr[P2R($1+73)] # Logitude of observation + +# Output Miscellaneous values +define RV_NEWGRAPH Memi[$1+75] # GTOOLS newgraph flag +define RV_RECORD Memi[$1+76] # Output record being written +define RV_TXFD Memi[$1+77] # Text file FD +define RV_GRFD Memi[$1+78] # Metacode file FD +define RV_VBFD Memi[$1+79] # Verbose logfile FD +define RV_CCFFILE Memi[$1+80] # Output ccf File +define RV_CCFTYPE Memi[$1+81] # Output ccf Type (image|text) +define RV_STATLINE Memi[$1+82] # Status line output flag +define RV_TEMPCODE Memi[$1+83] # Template code on output +define RV_TCODE Memi[$1+84] # Template code array ptr +define RV_PRINTZ Memi[$1+85] # Output z values instead of velocities + +# Plotting Miscellaneous values +define RV_DTYPE Memi[$1+90] # Data type +define RV_GTYPE Memi[$1+91] # Graph type +define RV_RESDONE Memi[$1+92] # Residuals plotted? +define RV_SPMKEY Memi[$1+93] # Spec-mode plot switch +define RV_SPMPLOT Memi[$1+94] # Spec-mode plot switch +define RV_WHERE Memi[$1+95] # Where is data plotted on split screen +define RV_X1 Memr[P2R($1+96)] # Starting plot scale +define RV_X2 Memr[P2R($1+97)] # Ending plot scale +define RV_Y1 Memr[P2R($1+98)] # Bottom plot scale (ccf plot) +define RV_Y2 Memr[P2R($1+99)] # Top plot scale (ccf plot) + +# Dispersion Info and Misc. +define RV_APPARAM Memi[$1+100] # APNUM parameter string (ptr) +define RV_APLIST Memi[$1+101] # Aperture ranges list +define RV_CMD Memi[$1+102] # Current cursor keystroke command +define RV_DCBIAS Memr[P2R($1+103)] # DC BIAS of the object spectrum +define RV_DCFLAG Memi[$1+104] # Is data in log-lambda space? +define RV_DELTAV Memr[P2R($1+105)] # Velocity per pixel +define RV_DO_CORRECT Memi[$1+106] # Do the heliocentric correction? +define RV_OFORMAT Memi[$1+107] # Data format (1D, echelle, multispec) +define RV_RFORMAT Memi[$1+108] # Data format (1D, echelle, multispec) +define RV_FWHM_Y Memr[P2R($1+109)] # Correlation coeff for FWHM calc. +define RV_GLOB_W1 Memr[P2R($1+110)] # Global w1 +define RV_GLOB_W2 Memr[P2R($1+111)] # Global w2 +define RV_NEWXCOR Memi[$1+112] # Do a new correlation? +define RV_OW0 Memr[P2R($1+113)] # Object W0 +define RV_OW2 Memr[P2R($1+114)] # Object endpoint of dispersion +define RV_OWPC Memr[P2R($1+115)] # Object WPC +define RV_RW0 Memr[P2R($1+116)] # Reference W0 +define RV_RW2 Memr[P2R($1+117)] # Template endpoint of dispersion +define RV_RWPC Memr[P2R($1+118)] # Reference WPC +define RV_DO_REBIN Memi[$1+119] # Rebin the data? + +# The answers +define RV_VOBS Memd[P2D($1+120)] # Observed velocity (vel) +define RV_VCOR Memd[P2D($1+122)] # Corrected velocity (vel) +define RV_ERROR Memd[P2D($1+124)] # Obs. Velocity error (vel) +define RV_HJD Memd[P2D($1+126)] # Heliocentric JD of obs (days) +define RV_MJD_OBS Memd[P2D($1+128)] # Heliocentric JD of obs (days) +define RV_VREL Memr[P2R($1+131)] # Relative vel. from pix shift +define RV_R Memr[P2R($1+132)] # Tonry&Davis 'R' parameter (vel) +define RV_SHIFT Memr[P2R($1+133)] # Computed shift value (pix) +define RV_SIGMA Memr[P2R($1+134)] # Error of fit (pix) +define RV_FWHM Memr[P2R($1+135)] # FWHM of ccf peak +define RV_HEIGHT Memr[P2R($1+136)] # Height of ccf peak (fft only) +define RV_DISP Memr[P2R($1+137)] # Dispersion +define RV_ERRCODE Memi[$1+138] # Error code for comment +define RV_DBL_SHIFT Memi[$1+139] # Deblended velocity struct ptr + +# Pointers for other packages +define RV_GP Memi[$1+140] # GIO pointer +define RV_MGP Memi[$1+141] # Metacode GIO pointer +define RV_GT Memi[$1+142] # GTOOLS pointer +define RV_NLFIT Memi[$1+143] # NLFIT pointer +define RV_ICFIT Memi[$1+144] # ICFIT pointer +define RV_COEFFS Memi[$1+145] # Coefficients pointer +define RV_ECOEFFS Memi[$1+146] # Error coefficients pointer +define RV_CONT Memi[$1+147] # Continuum params pointer +define RV_FILTP Memi[$1+148] # Filter params pointer +define RV_KEYW Memi[$1+149] # Keyword table pointer +define RV_PLOTP Memi[$1+150] # Plotpars params pointer +define RV_MWCSP Memi[$1+151] # MWCS structure pointer + +# Sample correlation regions structure pointers +define RV_OSAMPLE Memi[$1+155] # Obj sample struct (ptr) +define RV_RSAMPLE Memi[$1+156] # Ref sample struct (ptr) + +# Working array pointers. Keep things in memory and reallocate space +# as needed. All indexing automatically done by macros below. +define RV_OBJECTS Memi[$1+160] # Object list ptr +define RV_TEMPLATES Memi[$1+161] # Template list ptr +define RV_OBJCONT Memi[$1+162] # Object normalized flag +define RV_REFCONT Memi[$1+163] # Reference normalized flag +define RV_OCONTP Memi[$1+164] # Object normalized data ptr +define RV_RCONTP Memi[$1+165] # Reference normalized data ptr +define RV_ANTISYM Memi[$1+166] # CCF Antisymmetric noise ptr +define RV_ERRCOMMENTS Memi[$1+167] # Error comments ptr +define RV_TEMPVEL Memi[$1+168] # All template velocities +define RV_APNUMKWD Memi[$1+169] # APNUM keyword strings (ptr) + +# File names and stuff. +define RV_IMAGE Memi[$1+170] # Object image name +define RV_RIMAGE Memi[$1+171] # Ref image name +define RV_SPOOL Memi[$1+172] # Root spool name +define RV_DEVICE Memi[$1+173] # Output device name +define RV_OBJNAME Memi[$1+174] # Object Name +define RV_TEMPNAME Memi[$1+175] # Template Name + +# Output color values. +define RV_TXTCOLOR Memi[$1+176] # Text color +define RV_LINECOLOR Memi[$1+177] # Overplot line colors + +# Package Debugging info. (To be deleted in installed software.) +define DBG_DEBUG Memi[$1+180] # Debug flag +define DBG_FNAME Memi[$1+181] # Debug filename (ptr) +define DBG_FD Memi[$1+182] # Debug file descriptor +define DBG_LEVEL Memi[$1+183] # Level of debugging info +define DBG_OTHER Memi[$1+184] # Compare algorithms? +define DBG_KEYSTROKE Memi[$1+185] # Intial keystroke command +define DBG_QUICK Memi[$1+186] # Speed up graphics? + + +################### End of structure definitions ############################## + + +# Useful Macro definitions. All indexing is done in the macros themselves +# and pointers are assumed to be allocated at process startup. + +# Current working data +define OBJPIXX Memr[RV_OPIXX($1)+$2-1] # Pixel data +define OBJPIXY Memr[RV_OPIXY($1)+$2-1] # Pixel data +define REFPIXX Memr[RV_RPIXX($1)+$2-1] # Comparison data +define REFPIXY Memr[RV_RPIXY($1)+$2-1] # Comparison data +define WRKPIXX Memr[RV_WKPIXX($1)+$2-1] # Working space +define WRKPIXY Memr[RV_WKPIXY($1)+$2-1] # Working space + +# File names and stuff. +define IMAGE Memc[RV_IMAGE($1)] # Object image name +define RIMAGE Memc[RV_RIMAGE($1)] # Ref image name +define SPOOL Memc[RV_SPOOL($1)] # Root spool name +define DEVICE Memc[RV_DEVICE($1)] # Output device name +define OBJNAME Memc[RV_OBJNAME($1)] # Object Name +define TEMPNAME Memc[RV_TEMPNAME($1)] # Template Name + +# Misc arrays. +define ANTISYM Memr[RV_ANTISYM($1)+$2-1] # Antisymmetric noise array +define ERRCOMMENTS Memc[RV_ERRCOMMENTS($1)] # Error comment strings + +# Deblending data struct. We are insured there is enough space and offsets +# are correct assuming only 4 Gaussians are fit. Length of the struct is 50. +define DBL_SHIFT Memr[RV_DBL_SHIFT($1)+$2-1] # Self-explanatory +define DBL_VOBS Memr[RV_DBL_SHIFT($1)+5+$2-1] +define DBL_VHELIO Memr[RV_DBL_SHIFT($1)+10+$2-1] +define DBL_VERR Memr[RV_DBL_SHIFT($1)+15+$2-1] +define DBL_R Memr[RV_DBL_SHIFT($1)+20+$2-1] +define DBL_FWHM Memr[RV_DBL_SHIFT($1)+25+$2-1] +define DBL_HEIGHT Memr[RV_DBL_SHIFT($1)+30+$2-1] +define DBL_COEFFS Memr[RV_DBL_SHIFT($1)+35+$2-1] +define DBL_NFITP RV_NFITP($1) # Npts fit in deblend +define DBL_I1 RV_DI1($1) # Index of start +define DBL_X1 RV_DX1($1) # Left WCS of fit +define DBL_Y1 RV_DY1($1) # Bottom WCS of fit +define DBL_X2 RV_DX2($1) # Right WCS of fit +define DBL_Y2 RV_DY2($1) # Top WCS of fit +define DBL_SCALE RV_DSCALE($1) # Amplitude scale factor +define DBL_SLOPE RV_DSLOPE($1) # Slope of continuum +define DBL_NSHIFTS RV_NSHIFTS($1) # No. of components +define IS_DBLSTAR RV_IS_DOUBLE($1) # Deblend fit flag + +# Aperture Dispersion information +define APLIST Memi[RV_APLIST($1)+$2-1] # List of apertures to be used +define APNUM Memc[RV_APNUMKWD($1)+(($2-1)*SZ_APNUM)] +define APPARAM Memc[RV_APPARAM($1)] # APNUM parameter string +define CURAPNUM RV_CURAPNUM($1) # Current number in list +define NUMAPS RV_NUMAPS($1) # Number of apertures in image +define OAPNUM RV_OAPNUM($1) # Object aperture number +define RAPNUM RV_RAPNUM($1) # Reference aperture number + +# Flags and miscellaneous +define TEMPVEL Memr[RV_TEMPVEL($1)+$2-1] # Template velocity array +define COEFF Memr[RV_COEFFS($1)+$2-1] # Coefficients array +define ECOEFF Memr[RV_ECOEFFS($1)+$2-1] # Coefficients array +define OCONT_DATA Memr[RV_OCONTP($1)+$2-1] # Obj contin norm data +define RCONT_DATA Memr[RV_RCONTP($1)+$2-1] # Ref contin norm data +define DEBUG_FNAME Memc[DBG_FNAME($1)] # Debugging info file name +define TEMPCODE Memi[RV_TCODE($1)+$2-1] # Output template code +define OBJCONT RV_OBJCONT($1) # Have objects been normalized +define REFCONT RV_REFCONT($1) # Have temps been normalized diff --git a/noao/rv/rvparam.x b/noao/rv/rvparam.x new file mode 100644 index 00000000..57c80e4c --- /dev/null +++ b/noao/rv/rvparam.x @@ -0,0 +1,334 @@ +include <gset.h> +include <gio.h> +include "rvpackage.h" +include "rvflags.h" +include "rvsample.h" + +# RV_PARAM - File containing procedures for updating, unlearning, and +# displaying the task or associated pset values. Currrently only the +# FILTERPARS, CONTINPARS, or RVKEYWORDS psets are supported, as is the +# parameter list for the FXCOR task. + + +# RV_SHOW -- Process the ":show" command. Optional arguments to +# this command include 'contin|filter|keywords' to show the pset +# parameters. The default is to show the current task parameters. + +procedure rv_show (rv, fd) + +pointer rv #I pointer to the RV structure +pointer fd #I File descriptor + +pointer sp, cmd + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Get the command. + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) { + call gdeactivate (RV_GP(rv), AW_CLEAR) + call rv_task_show (rv, fd) + call greactivate (RV_GP(rv), AW_PAUSE) + + } else { + # Process the command. + switch (Memc[cmd+1]) { + case 'f': # show 'filterpars' pset + call gdeactivate (RV_GP(rv), AW_CLEAR) + call filt_show (rv, fd) + call greactivate (RV_GP(rv), AW_PAUSE) + case 'k': # show 'rvkeywords' pset + call gdeactivate (RV_GP(rv), AW_CLEAR) + call keyw_show (rv, fd) + call greactivate (RV_GP(rv), AW_PAUSE) + case 'c': # show 'continpars' pset + call gdeactivate (RV_GP(rv), AW_CLEAR) + call cont_show (rv, fd) + call greactivate (RV_GP(rv), AW_PAUSE) + default: + call printf ( + "Choose one of 'contin|filter|keywords'.") + } + } + + call sfree (sp) +end + + +# RV_TASK_SHOW - Show the current state of all task parameters. + +procedure rv_task_show (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I output fd (usually STDOUT) + +pointer sp, str, str2 +bool itob() +errchk open + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (str2, SZ_LINE, TY_CHAR) + + call fprintf (fd, "%21tFXCOR Current Parameter Settings:\n\n") + + # Print the Current Image Names + call header_show (rv, fd) + + # Print some parameters + call fprintf (fd,"\n") + call fprintf (fd, "Apodize%20t= %f\n") + call pargr (RV_APODIZE(rv)) + call fprintf (fd, "Autowrite%20t= %b\n") + call pargb (itob(RV_AUTOWRITE(rv))) + call fprintf (fd, "Autodraw%20t= %b\n") + call pargb (itob(RV_AUTODRAW(rv))) + call fprintf (fd, "Background%20t= %f\n") + call pargr (RV_BACKGROUND(rv)) + call fprintf (fd, "Height%20t= %f\n") + call pargr (RV_FITHGHT(rv)) + call fprintf (fd, "Width%20t= %f\n") + call pargr (RV_FITWIDTH(rv)) + call fprintf (fd, "Imupdate%20t= %b\n") + call pargb (itob(RV_IMUPDATE(rv))) + call fprintf (fd, "Minwidth%20t= %f\n") + call pargr (RV_MINWIDTH(rv)) + call fprintf (fd, "Maxwidth%20t= %f\n") + call pargr (RV_MAXWIDTH(rv)) + call fprintf (fd, "Peak%20t= %b\n") + call pargb (itob(RV_PEAK(rv))) + call nam_verbose (rv, Memc[str2]) + call fprintf (fd, "Verbose%20t= `%s'\n") + call pargstr (Memc[str2]) + call fprintf (fd, "Weights%20t= %f\n") + call pargr (RV_WEIGHTS(rv)) + call fprintf (fd, "Window%20t= %f\n") + call pargr (RV_WINPAR(rv)) + call fprintf (fd, "Wincenter%20t= %f\n") + call pargr (RV_WINCENPAR(rv)) + + call fprintf (fd,"\n") + call rv_make_range_string (RV_OSAMPLE(rv), Memc[str]) + call fprintf (fd,"Object regions selected%25t= '%s'\n") + call pargstr (Memc[str]) + call rv_make_range_string (RV_RSAMPLE(rv), Memc[str]) + call fprintf (fd,"Temp. regions selected%25t= '%s'\n\n\n") + call pargstr (Memc[str]) + + call sfree (sp) +end + + +# RV_UNLEARN -- Process the ":unlearn" command. Optional arguments to +# this command include 'contin|filter|keywords' to reset the pset +# parameters. The default is to unlearn the current task parameters. + +procedure rv_unlearn (rv) + +pointer rv #I pointer to the RV structure + +pointer sp, cmd + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Get the command. + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) + call rv_task_unlearn (rv) + + else { + # Process the command. + switch (Memc[cmd+1]) { + case 'f': # unlearn 'filterpars' pset + call filt_unlearn (rv) + case 'k': # unlearn 'rvkeywords' pset + call keyw_unlearn (rv) + case 'c': # unlearn 'continpars' pset + call cont_unlearn (rv) + default: + call printf ( + "Choose one of 'contin|filter|keywords'.") + } + } + + call sfree (sp) +end + + +# RV_TASK_UNLEARN - Reset the parameter values to their defaults. + +procedure rv_task_unlearn (rv) + +pointer rv # RV struct pointer + +begin + RV_APODIZE(rv) = 0.2 + RV_AUTOWRITE(rv) = YES + RV_AUTODRAW(rv) = YES + RV_BACKGROUND(rv) = 0.0 + RV_CCFTYPE(rv) = OUTPUT_IMAGE + RV_CONTINUUM(rv) = BOTH + RV_FILTER(rv) = NONE + RV_FITFUNC(rv) = GAUSSIAN + RV_FITHGHT(rv) = 0.0 + RV_FITWIDTH(rv) = INDEF + RV_IMUPDATE(rv) = NO + RV_INTERACTIVE(rv) = YES + RV_MINWIDTH(rv) = 3. + RV_MAXWIDTH(rv) = 21. + RV_PEAK(rv) = NO + RV_REBIN(rv) = RB_SMALL + ORCOUNT(rv) = ALL_SPECTRUM + RRCOUNT(rv) = ALL_SPECTRUM + RV_VERBOSE(rv) = OF_LONG + RV_WEIGHTS(rv) = 1 + RV_WINDOW(rv) = 20 + RV_WINCENPAR(rv) = INDEFI +end + + +# RV_UPDATE -- Process the ":update" command. Optional arguments to +# this command include 'contin|filter|keywords' to reset the pset +# parameters. The default is to update the current task parameters. + +procedure rv_update (rv) + +pointer rv #I pointer to the RV structure + +pointer sp, cmd + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + # Get the command. + call gargstr (Memc[cmd], SZ_LINE) + if (Memc[cmd] == EOS) + call rv_task_parupdate (rv) + + else { + # Process the command. + switch (Memc[cmd+1]) { + case 'f': # update 'filterpars' pset + call filt_parupdate (rv) + case 'k': # update 'rvkeywords' pset + call keyw_parupdate (rv) + case 'c': # update 'continpars' pset + call cont_parupdate (rv) + default: + call printf ( + "Choose one of 'contin|filter|keywords'.") + } + } + + call sfree (sp) +end + + +# RV_TASK_PARUPDATE - Update the parameter file with the current values in the +# structure. + +procedure rv_task_parupdate (rv) + +pointer rv #I RV struct pointer + +pointer sp, str, func, vb, rb +pointer filt, cont, ap +bool itob() + +begin + call smark (sp) + call salloc (str, SZ_LINE, TY_CHAR) + call salloc (cont, SZ_FNAME, TY_CHAR) + call salloc (filt, SZ_FNAME, TY_CHAR) + call salloc (func, SZ_FNAME, TY_CHAR) + call salloc (ap, SZ_FNAME, TY_CHAR) + call salloc (vb, SZ_FNAME, TY_CHAR) + call salloc (rb, SZ_FNAME, TY_CHAR) + + iferr { + call clputr ("apodize", RV_APODIZE(rv)) + call clputb ("autowrite", itob(RV_AUTOWRITE(rv))) + call clputb ("autodraw", itob(RV_AUTODRAW(rv))) + call clputr ("background", RV_BACKGROUND(rv)) + call clputr ("height", RV_FITHGHT(rv)) + call clputr ("width", RV_FITWIDTH(rv)) + call clputb ("imupdate", itob(RV_IMUPDATE(rv))) + call clputr ("minwidth", RV_MINWIDTH(rv)) + call clputr ("maxwidth", RV_MAXWIDTH(rv)) + call clputb ("peak", itob(RV_PEAK(rv))) + call clputr ("weights", RV_WEIGHTS(rv)) + call clputr ("window", RV_WINPAR(rv)) + call clputr ("wincenter", RV_WINCENPAR(rv)) + + call rv_make_range_string (RV_OSAMPLE(rv), Memc[str]) + call clpstr ("osample", Memc[str]) + call rv_make_range_string (RV_RSAMPLE(rv), Memc[str]) + call clpstr ("rsample", Memc[str]) + + call nam_verbose (rv, Memc[vb]) + call clpstr ("verbose", Memc[vb]) + + call nam_fitfunc (rv, Memc[func]) + call clpstr ("function", "gaussian") + + call nam_which (RV_CONTINUUM(rv), Memc[cont]) + call clpstr ("continuum", Memc[cont]) + + call nam_rebin (rv, Memc[rb]) + call clpstr ("rebin", Memc[rb]) + + call nam_which (RV_FILTER(rv), Memc[filt]) + call clpstr ("filter", Memc[filt]) + + call nam_fitfunc (rv, Memc[func]) + call clpstr ("function", Memc[func]) + + if (RV_CCFTYPE(rv) == OUTPUT_IMAGE) + call clpstr ("ccftype", "image") + else + call clpstr ("ccftype", "text") + + } then { + call sfree (sp) + call error (0, "Error updating parameters.") + } + + call sfree (sp) +end + + +# HEADER_SHOW - show the current state of all parameters in the common +# header. + +procedure header_show (rv, fd) + +pointer rv #I RV struct pointer +int fd #I output file descriptor (usually STDOUT) + +bool streq() + +begin + # Print the Current Image Names + call fprintf (fd,"Current Object Image%25t= '%.10s'\n") + call pargstr (IMAGE(rv)) + call fprintf (fd,"Reference Image%25t= '%.10s'\n") + call pargstr (RIMAGE(rv)) + call fprintf (fd,"Spool root Name%25t= '%.10s'\n") + if (streq(SPOOL(rv),"")) + call pargstr (" ") + else + call pargstr (SPOOL(rv)) + call fprintf (fd,"Fitting Function%25t= %s\n") + if (RV_FITFUNC(rv) == GAUSSIAN) + call pargstr ("'gaussian'") + else if (RV_FITFUNC(rv) == LORENTZIAN) + call pargstr ("'lorentzian'") + else + call pargstr ("'parabola'") +end diff --git a/noao/rv/rvplot.x b/noao/rv/rvplot.x new file mode 100644 index 00000000..b3eff068 --- /dev/null +++ b/noao/rv/rvplot.x @@ -0,0 +1,438 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvplots.h" +include "rvsample.h" + +# RV_PLOT - Do the plotting for the task. Flags are passed in which tell the +# type of plot to draw + +procedure rv_plot (rv, flags) + +pointer rv #I RV struct pointer +int flags #I Type of plot to draw + +pointer gp, sp +pointer title +real y1, y2, statr +real rv_width() + +begin + if (RV_INTERACTIVE(rv) == YES) + gp = RV_GP(rv) + else + gp = RV_MGP(rv) + + # Get the graphics pointer and clear the workstation + if (gp == NULL) + return + + # Take care of the simple case first + switch (flags) { + case AMPLITUDE_PLOT, POWER_PLOT, PHASE_PLOT: + call gclear (gp) + call fft_plot (rv, flags) + RV_GTYPE(rv) = flags + return + } + + RV_GTYPE(rv) = flags # Update the current plot type + + call smark (sp) + call salloc (title, 4*SZ_LINE, TY_CHAR) + + # Do the silly title string + switch (flags) { + case SPECTRUM_PLOT, FILTER_PLOT, NORM_PLOT: + call get_plot_title (rv, title, RV_NPTS(rv)) + default: + call get_plot_title (rv, title, RV_CCFNPTS(rv)) + } + + if (flags!=SPECTRUM_PLOT && flags!=FILTER_PLOT && flags!=NORM_PLOT) { + RV_X1(rv) = WRKPIXX(rv,1) + RV_X2(rv) = WRKPIXX(rv,RV_CCFNPTS(rv)) + } + + # Call the plot primitives + switch (flags) { + case SPECTRUM_PLOT, FILTER_PLOT, NORM_PLOT: + call gclear (gp) + if (RV_GTYPE(rv) == NORM_PLOT) + call rv_nplot (rv, SPLIT_PLOT) + else + call rv_splot (rv, SPLIT_PLOT) + if (ORCOUNT(rv) != ALL_SPECTRUM) + call rv_mark_regions (RV_OSAMPLE(rv), gp) + if (RRCOUNT(rv) != ALL_SPECTRUM) + call rv_mark_regions (RV_RSAMPLE(rv), gp) + + case CORRELATION_PLOT: + call gclear (gp) + call split_plot (rv, gp, TOP, WRKPIXY(rv,1), + RV_CCFNPTS(rv), OBJECT_SPECTRUM, CORRELATION_PLOT) + call split_plot (rv, gp, BOTTOM, WRKPIXY(rv,1), + RV_CCFNPTS(rv), OBJECT_SPECTRUM, CORRELATION_PLOT) + if (RV_FITDONE(rv) == YES && IS_DBLSTAR(rv) == NO) + statr = rv_width (rv) # Redraw FWHM indicator + + case RESIDUAL_PLOT: + call rv_resid_plot (rv) + + default: + call error (0, "Invalid plot request in rv_plot().") + } + call gflush (gp) + call ggwind (gp, RV_X1(rv), RV_X2(rv), y1, y2) + + call sfree(sp) +end + + +# RV_NPLOT - Plot the (two) normalized spectra to the screen + +procedure rv_nplot (rv, flag) + +pointer rv #I RV struct pointer +int flag #I Type of flag to print (SINGLE/SPLIT) + +pointer gp # Graphics pointer +pointer sp, title, bp, xlbl, ylbl, sid +int npts +real x1, x2, y1, y2 + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + # Allocate working space + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + call salloc (title, 4*SZ_LINE, TY_CHAR) + + # Clear the screen + call gclear (gp) + + if (flag == SINGLE_PLOT || RV_CONTINUUM(rv) == OBJ_ONLY) { + + call salloc (xlbl, SZ_FNAME, TY_CHAR) + call salloc (ylbl, SZ_FNAME, TY_CHAR) + call salloc (sid, SZ_LINE, TY_CHAR) + call aclrc (Memc[title], 4*SZ_LINE) + call aclrc (Memc[xlbl], SZ_FNAME) + call aclrc (Memc[ylbl], SZ_FNAME) + call aclrc (Memc[sid], SZ_LINE) + + # Draw the plot to the screen + npts = RV_NPTS(rv) + call sysid (Memc[sid], SZ_LINE) + call sprintf (Memc[title], 4*SZ_LINE, + "%s\nObject='%s' Reference='%s'\nStar='%s' Temp='%s' npts=%d aperture=%d") + call pargstr (Memc[sid]) + call pargstr (IMAGE(rv)) + call pargstr (RIMAGE(rv)) + call pargstr (OBJNAME(rv)) + call pargstr (TEMPNAME(rv)) + call pargi (npts) + call pargi (RV_APNUM(rv)) + call strcpy ("Intensity", Memc[ylbl], SZ_FNAME) + call gascale (gp, OCONT_DATA(rv,1), npts, 2) + call ggwind (gp, x1, x2, y1, y2) + y1 = y1 - ((y2-y1)/10.0) + y2 = y2 + ((y2-y1)/10.0) + if (RV_DCFLAG(rv) == -1) { + call strcpy ("Pixel", Memc[xlbl], SZ_FNAME) + x1 = 1.0 + x2 = real (npts) + } else { + call strcpy ("Wavelength", Memc[xlbl], SZ_FNAME) + x1 = 10.0 ** (RV_OW0(rv)) + x2 = 10.0 ** (RV_OW2(rv)) + } + + # Draw the axis labels. + call gsview (gp, 0.115, 0.95, 0.125, 0.845) + call gswind (gp, x1, x2, y1, y2) + call glabax (gp, Memc[title], Memc[xlbl], Memc[ylbl]) + + # Draw the vector. + call gvline (gp, OCONT_DATA(rv,1), npts, x1, x2) + + # Lastly, annotate ther plot so we know what we're looking at. + call gctran (gp, 0.6, 0.23, x1, y1, 0, 1) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + call gtext (gp, x1, y1, "Normalized Spectrum", "") + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gseti (gp, G_XDRAWAXES, 3) # reset gio flags + + # Draw sample regions. + call rv_mark_regions (RV_OSAMPLE(rv), gp) + + call gflush (gp) + + } else if (flag == SPLIT_PLOT) { + if (RV_CONTINUUM(rv) == BOTH || RV_CONTINUUM(rv) == OBJ_ONLY) { + call split_plot (rv, gp, TOP, OCONT_DATA(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, NORM_PLOT) + } else { + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, SPECTRUM_PLOT) + } + call rv_mark_regions (RV_OSAMPLE(rv), gp) + if (RV_CONTINUUM(rv) == BOTH || RV_CONTINUUM(rv) == TEMP_ONLY) { + call split_plot (rv, gp, BOTTOM, RCONT_DATA(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, NORM_PLOT) + } else { + call split_plot (rv, gp, BOTTOM, REFPIXY(rv,1), + RV_RNPTS(rv), REFER_SPECTRUM, SPECTRUM_PLOT) + } + call rv_mark_regions (RV_RSAMPLE(rv), gp) + } + + call sfree (sp) +end + + +# RV_RESID_PLOT - Plot the residuals of the fit to the screen. + +procedure rv_resid_plot (rv) + +pointer rv #I RV struct pointer + +pointer sp, gp, resx, resy, buf +real x, y, sigma, mean, xp, yp +int npts, i + +int gstati() +real model() + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + if (RV_FITDONE(rv) == NO) { + call rv_errmsg ("Error: No fit yet done to the data.") + return + } else if (RV_FITFUNC(rv) == CENTER1D || RV_FITFUNC(rv) == SINC) { + call rv_errmsg ("Residual plot unavailable for `%s' fit.") + if (RV_FITFUNC(rv) == CENTER1D) + call pargstr ("center1d") + else + call pargstr ("sinc") + return + } + + if (IS_DBLSTAR(rv) == YES) + npts = DBL_NFITP(rv) + else + npts = RV_IEND(rv) - RV_ISTART(rv) + 1 + + call smark (sp) + call salloc (resx, npts, TY_REAL) + call salloc (resy, npts, TY_REAL) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Compute the residuals or ratio of the fit + if (IS_DBLSTAR(rv) == YES) + x = WRKPIXX(rv,DBL_I1(rv)) + else + x = WRKPIXX(rv,RV_ISTART(rv)) + do i = 1, npts { + Memr[resx+i-1] = x + if (IS_DBLSTAR(rv) == NO) { + switch (RV_FITFUNC(rv)) { + case GAUSSIAN: + call cgauss1d (x, 1, COEFF(rv,1), 4, y) + case LORENTZIAN: + call lorentz (x, 1, COEFF(rv,1), 4, y) + case PARABOLA: + call polyfit (x, 1, COEFF(rv,1), 3, y) + } + } else { + y = model (x, DBL_COEFFS(rv,1), 3*DBL_NSHIFTS(rv)+2) + y = DBL_SCALE(rv) * y + + (DBL_Y1(rv) + DBL_SLOPE(rv) * (x-DBL_X1(rv))) + } + + if (IS_DBLSTAR(rv) == YES) + Memr[resy+i-1] = WRKPIXY(rv,i+DBL_I1(rv)-1) - y + else + Memr[resy+i-1] = WRKPIXY(rv,i+RV_ISTART(rv)-1) - y + x = x + 1. + } + + # Add back in the background. + call aavgr (Memr[resy], npts, mean, sigma) # save residuals + if (IS_DBLSTAR(rv) == YES) { + do i = 0, npts-1 { + Memr[resy+i] = Memr[resy+i] + (DBL_Y1(rv) + DBL_SLOPE(rv) * + (Memr[resx+i]-DBL_X1(rv))) + } + } else if (!IS_INDEF(RV_BACKGROUND(rv))) { + call aaddkr (Memr[resy], RV_BACKGROUND(rv), Memr[resy], npts) + } else { + if (RV_FITFUNC(rv) != PARABOLA) { + call aaddkr (Memr[resy], COEFF(rv,4), Memr[resy], npts) + } else { + call aaddkr (Memr[resy], WRKPIXY(rv,RV_ISTART(rv)), + Memr[resy], npts) + } + } + + # Draw the label and vectors + if (gstati(gp,G_PLTYPE) != GL_CLEAR) + call gseti (gp, G_PLTYPE, GL_DOTTED) + call gline (gp, WRKPIXX(rv,RV_ISTART(rv)), WRKPIXY(rv,RV_ISTART(rv)), + Memr[resx], Memr[resy]) + call gpline (gp, Memr[resx], Memr[resy], npts) + call gline (gp, Memr[resx+npts-1], Memr[resy+npts-1], + WRKPIXX(rv,RV_IEND(rv)), WRKPIXY(rv,RV_IEND(rv))) + if (gstati(gp,G_PLTYPE) != GL_CLEAR) + call gseti (gp, G_PLTYPE, GL_SOLID) + + # Mark plot with sigma and mean of the residuals. + if (gstati(gp,G_PLTYPE) != GL_CLEAR) { + call aavgr (Memr[resy], npts, mean, sigma) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + call sprintf (Memc[buf], SZ_LINE, "Mean residual = %f") + call pargr (mean) + call gctran (gp, 0.15, 0.63, xp, yp, 0, 2) + call gtext (gp, xp, yp, Memc[buf], "") + call sprintf (Memc[buf], SZ_LINE, " sigma = %f") + call pargr (sigma) + call gctran (gp, 0.15, 0.58, xp, yp, 0, 2) + call gtext (gp, xp, yp, Memc[buf], "") + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + } + RV_RESDONE(rv) = YES + + call gflush (gp) + call sfree (sp) +end + + +# RV_SPLOT - Plot the two spectra to the screen + +procedure rv_splot (rv, flag) + +pointer rv #I RV struct pointer +int flag #I Type of flag to print (SINGLE/SPLIT) + +pointer gp # Graphics pointer +pointer sp, title, xlbl, ylbl, sid +int npts +real x1, x2, y1, y2 + +begin + gp = RV_GP(rv) + if (gp == NULL) + return + + # Clear the screen. + call gclear (gp) + + # Draw the plot to the screen. + if (flag == SINGLE_PLOT) { + + call smark (sp) + call salloc (title, 4*SZ_LINE, TY_CHAR) + call salloc (xlbl, SZ_FNAME, TY_CHAR) + call salloc (ylbl, SZ_FNAME, TY_CHAR) + call salloc (sid, SZ_LINE, TY_CHAR) + call aclrc (Memc[title], 4*SZ_LINE) + call aclrc (Memc[xlbl], SZ_FNAME) + call aclrc (Memc[ylbl], SZ_FNAME) + call aclrc (Memc[sid], SZ_LINE) + + # Draw the plot to the screen + npts = RV_NPTS(rv) + call sysid (Memc[sid], SZ_LINE) + call sprintf (Memc[title], 4*SZ_LINE, + "%s\nObject='%s' Reference='%s'\nStar='%s' Temp='%s' npts=%d aperture=%d") + call pargstr (Memc[sid]) + call pargstr (IMAGE(rv)) + call pargstr (RIMAGE(rv)) + call pargstr (OBJNAME(rv)) + call pargstr (TEMPNAME(rv)) + call pargi (npts) + call pargi (RV_APNUM(rv)) + call strcpy ("Intensity", Memc[ylbl], SZ_FNAME) + call gascale (gp, OBJPIXY(rv,1), npts, 2) + call ggwind (gp, x1, x2, y1, y2) + y1 = y1 - ((y2-y1)/10.0) + y2 = y2 + ((y2-y1)/10.0) + if (RV_DCFLAG(rv) == -1) { + call strcpy ("Pixel", Memc[xlbl], SZ_FNAME) + x1 = 1.0 + x2 = real (npts) + } else { + call strcpy ("Wavelength", Memc[xlbl], SZ_FNAME) + x1 = 10.0 ** (RV_OW0(rv)) + x2 = 10.0 ** (RV_OW2(rv)) + } + + # Draw the axis labels. + call gsview (gp, 0.115, 0.95, 0.125, 0.845) + call gswind (gp, x1, x2, y1, y2) + call glabax (gp, Memc[title], Memc[xlbl], Memc[ylbl]) + + # Draw the vector. + call gvline (gp, OBJPIXY(rv,1), npts, x1, x2) + + # Lastly, annotate ther plot so we know what we're looking at. + call gctran (gp, 0.63, 0.23, x1, y1, 0, 1) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + call gtext (gp, x1, y1, "Object Spectrum", "") + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gseti (gp, G_XDRAWAXES, 3) # reset gio flags + + call gflush (gp) + call sfree (sp) + + } else if (flag == SPLIT_PLOT) { + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), RV_NPTS(rv), + OBJECT_SPECTRUM, SPECTRUM_PLOT) + call rv_mark_regions (RV_OSAMPLE(rv), gp) + call split_plot (rv, gp, BOTTOM, REFPIXY(rv,1), RV_RNPTS(rv), + REFER_SPECTRUM, SPECTRUM_PLOT) + call rv_mark_regions (RV_RSAMPLE(rv), gp) + } + +end + + +# RV_ZPLOT - Zoom in on the current current cursor position + +procedure rv_zplot (rv, gp, x, y, wcs) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +real x #I X cursor position +real y #I Y cursor position +int wcs #I WCS of cursor position + +real x1, y1 +double rv_shift2vel() + +begin + # Check for boundary coordinates + call gctran (gp, x, y, x1, y1, wcs, 0) + if (y1 > 0.775 && y1 < 0.9 && x1 > 0.115 && x1 < 0.95) { + call gctran (gp, x, y, x, y, wcs, 3) + if (RV_DCFLAG(rv) == -1) + RV_WINCENPAR(rv) = x + else + RV_WINCENPAR(rv) = real (rv_shift2vel(rv,x)) + RV_WINCENTER(rv) = max (real(1), real(x+RV_CCFNPTS(rv)/2+1)) + RV_WINCENTER(rv) = min (real(RV_WINCENTER(rv)), + real(RV_CCFNPTS(rv)-1)) + IS_DBLSTAR(rv) = NO + RV_FITDONE(rv) = NO + RV_Y1(rv) = INDEF + RV_Y2(rv) = INDEF + call rv_batch_xcor (rv, RV_TEMPNUM(rv), RV_APNUM(rv), NO, YES, NO) + } else + call rv_errmsg ("You must point at the top plot to zoom.\n") +end diff --git a/noao/rv/rvplots.h b/noao/rv/rvplots.h new file mode 100644 index 00000000..daee7088 --- /dev/null +++ b/noao/rv/rvplots.h @@ -0,0 +1,25 @@ +# Include file for the FFT Plot structure. A pointer is allocated in +# the main RV structure into this one. This sub-structure contains the +# parameters used for data filter while in Fourier space as well as +# the option flags for filter function types + +define SZ_PLOTSTRUCT 10 + +define RVP_PLOT Memi[RV_PLOTP($1)] # Plot type +define RVP_OVERLAY Memi[RV_PLOTP($1)+1] # Overlay filter? +define RVP_SPLIT_PLOT Memi[RV_PLOTP($1)+2] # Make a split-plot? +define RVP_ONE_IMAGE Memi[RV_PLOTP($1)+3] # What's in one plot? +define RVP_WHEN Memi[RV_PLOTP($1)+4] # Before/after filtering? +define RVP_LOG_SCALE Memi[RV_PLOTP($1)+5] # Log scale it? +define RVP_FFT_ZOOM Memr[P2R(RV_PLOTP($1)+6)] # FFT Zoom factor + +###################### END OF STRUCTURE DEFINITIONS ###################### + +# Plot type flags +define RV_PTYPES "|amplitude|phase|power|" +define AMPLITUDE_PLOT 1 # Plot type +define PHASE_PLOT 2 # Plot type +define POWER_PLOT 3 # Plot type + +define BEFORE 1 # Plot before filtering +define AFTER 2 # Plot after filtering diff --git a/noao/rv/rvrebin.x b/noao/rv/rvrebin.x new file mode 100644 index 00000000..4c0710f7 --- /dev/null +++ b/noao/rv/rvrebin.x @@ -0,0 +1,155 @@ +include <error.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" + + +# FORCE_REBIN - Rebin the input spectrum in log space from a specified +# uniform log binning. This is to force both object and templates to the +# same dispersion if at all possible. + +int procedure force_rebin (rv) + +pointer rv #I RV struct pointer + +int npts, dcflag, which, status +int force_which(), rv_getim() +real w0, wpc, w2 +errchk realloc + +begin + # Skip this if not dispersion corrected. + if (RV_DCFLAG(rv) == -1) + return (OK) + + # First get the intermediate values to rebin the spectrum + dcflag = 1 # Rebinning to log dispersion. + if (force_which (rv, which, w0, wpc, npts) == NO) + return (OK) + + # Move the data before rebinning and increase the size of the data cache + if (which == OBJECT_SPECTRUM) { + call realloc (RV_OPIXX(rv), npts, TY_REAL) + call realloc (RV_OPIXY(rv), npts, TY_REAL) + call aclrr (OBJPIXX(rv,1), npts) + call aclrr (OBJPIXY(rv,1), npts) + } else { + call realloc (RV_RPIXX(rv), npts, TY_REAL) + call realloc (RV_RPIXY(rv), npts, TY_REAL) + call aclrr (REFPIXX(rv,1), npts) + call aclrr (REFPIXY(rv,1), npts) + } + + w2 = w0 + (npts - 1) * wpc + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv), "force_rebin:\n") + call d_printf (DBG_FD(rv), "\tw0,wpc,w2,npts = %g,%g,%g,%d - %d\n") + call pargr(w0);call pargr(wpc);call pargr(w2) + call pargi(npts);call pargi(which) + call d_printf (DBG_FD(rv), "\to_w0=%g o_wpc=%g o_w2=%g\n") + call pargr(RV_OW0(rv)) ; call pargr(RV_OWPC(rv)) + call pargr(RV_OW2(rv)) + call d_printf (DBG_FD(rv), "\tr_w0=%g r_wpc=%g r_w2=%g\n") + call pargr(RV_RW0(rv)) ; call pargr(RV_RWPC(rv)) + call pargr(RV_RW2(rv)) + } + + # Now rebin to the desired dispersion. + #wpc = (10.0 ** (w0 + (npts-1)*wpc) - 10.0 ** w0) / (npts - 1) + w2 = 10.0 ** w2 + w0 = 10.0 ** w0 + if (which == OBJECT_SPECTRUM) + status = rv_getim (rv, IMAGE(rv), OBJECT_SPECTRUM, w0, w2, npts) + else + status = rv_getim (rv, RIMAGE(rv), REFER_SPECTRUM, w0, w2, npts) + + if (DEBUG(rv)) { + call d_printf (DBG_FD(rv), "\tend: w0,wpc,w2,npts = %g,%g,%g,%d\n") + call pargr(w0);call pargr(wpc);call pargr(w2);call pargi(npts) + } + + # Re-calculate the velocity dispersion and global endpoints + RV_DELTAV(rv) = wpc * CLN10 + RV_GLOB_W1(rv) = min (RV_OW0(rv), RV_RW0(rv)) + RV_GLOB_W2(rv) = max (RV_OW2(rv), RV_RW2(rv)) + + return (OK) +end + + +# FORCE_WHICH - Determine if spectra have to be rebinned to have the same +# dispersion and same starting wavelengths to within an integer shift. + +int procedure force_which (rv, which, w0, wpc, npts) + +pointer rv #I RV struct pointer +int which #O Which spectrum? +real w0 #O Rebinned W0 +real wpc #O Rebinned WPC +int npts #O Rebinned number of pixels + +int i +int stat +bool fp_equalr() + +begin + # Check if the spectra have the same dispersion. + which = OBJECT_SPECTRUM + w0 = RV_RW0(rv) + wpc = RV_RWPC(rv) + npts = RV_RNPTS(rv) + stat = NO + if (fp_equalr (w0, RV_OW0(rv)) && fp_equalr (wpc, RV_OWPC(rv))) + return (stat) + + # Determine spectrum to rebin. + switch (RV_REBIN(rv)) { + case RB_OBJ: + which = REFER_SPECTRUM + case RB_TEMP: + which = OBJECT_SPECTRUM + case RB_SMALL: + if (abs (RV_OWPC(rv)) < abs (RV_RWPC(rv))) + which = REFER_SPECTRUM + else + which = OBJECT_SPECTRUM + case RB_BIG: + if (abs (RV_OWPC(rv)) > abs (RV_RWPC(rv))) + which = REFER_SPECTRUM + else + which = OBJECT_SPECTRUM + } + + # Set the new dispersion parameters. The dispersion is the same as + # the target spectrum and the starting wavelength is adjusted by a + # fractional pixel amount into the data so that the starting + # wavelengths of the two spectra are an integer number of pixels + # apart in the common dispersion. + + switch (which) { + case REFER_SPECTRUM: + w0 = RV_OW0(rv) + wpc = RV_OWPC(rv) + if (RV_RWPC(rv) / RV_OWPC(rv) > 0) + i = (RV_RW0(rv) - w0) / wpc + 0.999 + else + i = (RV_RW0(rv) - w0) / wpc + w0 = w0 + i * wpc + npts = (RV_RW2(rv) - w0) / wpc + 1 + if (!fp_equalr (w0, RV_RW0(rv)) || !fp_equalr (wpc, RV_RWPC(rv))) + stat = YES + case OBJECT_SPECTRUM: + w0 = RV_RW0(rv) + wpc = RV_RWPC(rv) + if (RV_RWPC(rv) / RV_OWPC(rv) > 0) + i = (RV_OW0(rv) - w0) / wpc + 0.999 + else + i = (RV_OW0(rv) - w0) / wpc + w0 = w0 + i * wpc + npts = (RV_OW2(rv) - w0) / wpc + 1 + if (!fp_equalr (w0, RV_OW0(rv)) || !fp_equalr (wpc, RV_OWPC(rv))) + stat = YES + } + + return (stat) +end diff --git a/noao/rv/rvreidlines.par b/noao/rv/rvreidlines.par new file mode 100644 index 00000000..9056d9aa --- /dev/null +++ b/noao/rv/rvreidlines.par @@ -0,0 +1,31 @@ +# Parameters for rvreidlines task. + +reference,s,a,,,,Reference image +images,s,a,,,,Images to be reidentified +interactive,s,h,"no","no|yes|NO|YES",,Interactive fitting? +section,s,h,"middle line",,,Section to apply to two dimensional images +newaps,b,h,yes,,,Reidentify apertures in images not in reference? +override,b,h,no,,,"Override previous solutions? + +" +trace,b,h,no,,,Trace reference image? +step,s,h,"10",,,Step in lines/columns/bands for tracing an image +nsum,s,h,"10",,,Number of lines/columns/bands to sum +shift,s,h,"0.",,,Shift to add to reference features +nlost,i,h,0,0,,"Maximum number of features which may be lost +" +cradius,r,h,5.,,,Centering radius +threshold,r,h,10.,0.,,Feature threshold for centering +addfeatures,b,h,no,,,Add features from a line list? +coordlist,f,h,,,,User coordinate list +match,r,h,10.,,,Coordinate list matching limit in user units +maxfeatures,i,h,50,,,Maximum number of features for automatic identification +minsep,r,h,2.,0.,,"Minimum pixel separation +" +database,f,h,database,,,Database +logfiles,s,h,"logfile",,,List of log files +verbose,b,h,no,,,Verbose output? +keywpars,pset,h,"",,,Header keyword translation pset +graphics,s,h,"stdgraph",,,Graphics output device +cursor,*gcur,h,"",,,Graphics cursor input +answer,s,q,"yes","no|yes|NO|YES",,Fit lines and velocity interactively? diff --git a/noao/rv/rvrvcor.x b/noao/rv/rvrvcor.x new file mode 100644 index 00000000..4adb4be0 --- /dev/null +++ b/noao/rv/rvrvcor.x @@ -0,0 +1,528 @@ +include <imio.h> +include <error.h> +include <time.h> +include "rvpackage.h" +include "rvflags.h" +include "rvkeywords.h" + +# RV_RVCORRECT - Given the shift compute the observed and corrected velocity + +int procedure rv_rvcorrect (rv, shift, sigma, vobs, vcor, verror) + +pointer rv #I RV struct pointer +real shift #I Computed pixel shift +real sigma #I Sigma of fit +double vobs #O Observed object velocity +double vcor #O Corrected object velocity +double verror #O Error of velocity + +double ra, dec, ep, ut +double jd, rhjd, hjd, vrot, vbary, vorb, vsol +double ref_rvobs, ref_rvcor, ref_rvknown +double delta_vel, dshift, deltav, dwpc +pointer imo, imr +int day, month, year, stat + +double rv_shift2vel() +pointer immap() +int rv_gposinfo() +errchk immap, imgetr + +begin + if (DBG_DEBUG(rv) == YES) + call d_printf(DBG_FD(rv), "rv_rvcorrect:\n") + + # Initialize some things. + dshift = double (shift) + deltav = double (RV_DELTAV(rv)) + dwpc = double (RV_RWPC(rv)) + + # Check for a legal operation. + if (RV_DCFLAG(rv) == -1 || RV_PIXCORR(rv) == YES) { + vobs = INDEFD + vcor = INDEFD + RV_VREL(rv) = INDEFR + RV_HJD(rv) = INDEFD + RV_MJD_OBS(rv) = INDEFD + return (OK) + } + + # Map the images. + imo = immap (IMAGE(rv), READ_ONLY, 0) + imr = immap (RIMAGE(rv), READ_ONLY, 0) + + # Get the velocity from the reference star image header. + if (IS_INDEF(TEMPVEL(rv,RV_TEMPNUM(rv)))) { + ref_rvknown = 0.0d0 + call rv_err_comment (rv, + "WARNING: Using template velocity of 0 km/s.", "") + } else + ref_rvknown = double (TEMPVEL(rv,RV_TEMPNUM(rv))) + + # Compute the heliocentric correction for the reference star + stat = rv_gposinfo (rv, imr, NO, ra, dec, ep, ut, day, month, year) + if (stat != OK) { # Error reading header + if (RV_DCFLAG(rv) == -1) { + RV_VREL(rv) = INDEFR + RV_PRINTZ(rv) = NO + } else { + RV_VREL(rv) = real (rv_shift2vel(rv,shift)) + if (abs(RV_VREL(rv)/C) >= RV_ZTHRESH(rv)) + RV_PRINTZ(rv) = YES + else + RV_PRINTZ(rv) = NO + } + vobs = INDEFD + vcor = INDEFD + RV_HJD(rv) = INDEFD + RV_MJD_OBS(rv) = INDEFD + call imunmap (imo); + call imunmap (imr); + return (ERR_RVCOR) + } + call rv_corr (rv, imr, ra, dec, ep, year, month, day, ut, jd, rhjd, + vrot, vbary, vorb, vsol) + ref_rvcor = vrot + vbary + vorb # Computed Helio RV correction + ref_rvobs = ref_rvknown - ref_rvcor # Observed RV of standard + + if (DBG_DEBUG(rv) == YES) { + call d_printf(DBG_FD(rv), "\tref:m/d/y,ra,dec,ut=%d/%d/%d,%h,%h,%h\n") + call pargi(month); call pargi(day); call pargi(year) + call pargd(ra); call pargd(dec); call pargd(ut) + call d_printf(DBG_FD(rv), "\t jd = %g r_hjd = %g\n") + call pargd (jd); call pargd (rhjd) + call d_printf(DBG_FD(rv), "\tref: vrot,vbary,vorb=%.4g,%.4g,%.4g\n") + call pargd (vrot); call pargd (vbary); call pargd (vorb) + } + + # Compute the wavelength/velocity shift + if (RV_DCFLAG(rv) == -1) + RV_VREL(rv) = INDEFR + else + RV_VREL(rv) = real (rv_shift2vel(rv,shift)) + vobs = ((1 + ref_rvobs/C) * (10**(dwpc * dshift)) - 1) * C + + # Set the output print format + if (RV_PRINTZ(rv) == -1) { + if (abs(RV_VREL(rv)/C) >= RV_ZTHRESH(rv) && !IS_INDEF(RV_VREL(rv))) + RV_PRINTZ(rv) = YES + else + RV_PRINTZ(rv) = NO + } + + # Now correct observed velocity + if (rv_gposinfo(rv,imo,YES,ra,dec,ep,ut,day,month,year)==ERR_RVCOR) { + call imunmap (imo); + call imunmap (imr); + return (ERR_RVCOR) + } + call rv_corr (rv, imo, ra, dec, ep, year, month, day, ut, jd, hjd, + vrot, vbary, vorb, vsol) + + # Apply the corrections (+ vsol for correction to LSR) + vcor = vobs + (vrot + vbary + vorb) + + # Error computations - Kludge until antisymmetric computation + #verror = double (sigma * deltav) + + if (DBG_DEBUG(rv) == YES) { + call d_printf(DBG_FD(rv), "\tobj:m/d/y,ra,dec,ut=%d/%d/%d,%h,%h,%h\n") + call pargi(month); call pargi(day); call pargi(year) + call pargd(ra); call pargd(dec); call pargd(ut) + call d_printf(DBG_FD(rv), "\t jd = %g hjd = %g\n") + call pargd (jd); call pargd (hjd) + call d_printf(DBG_FD(rv), "\tobj: vrot,vbary,vorb=%.4f,%.4f,%.4f\n") + call pargd (vrot); call pargd (vbary); call pargd (vorb) + call d_printf(DBG_FD(rv), "\tshift,w0,wpc=%.4g,%.6g,%.6g\n") + call pargr(shift); call pargr(RV_RW0(rv)) + call pargr(RV_RWPC(rv)) + call d_printf(DBG_FD(rv), "\tow0,rw0,dv=%.6g,%.6g,%.6g\n") + call pargr(RV_OW0(rv)); call pargr(RV_RW0(rv)); + call pargd(delta_vel) + call d_printf(DBG_FD(rv), + "\tvrel,ref_rvcor,ref_rvobs=%.4f,%.4f,%.4f\n") + call pargr (RV_VREL(rv)); call pargd (ref_rvcor) + call pargd (ref_rvobs) + call d_printf(DBG_FD(rv), "\tvobs,vcor,verror=%.4g,%.4f,%.4g\n") + call pargd (vobs); call pargd (vcor); call pargd (verror) + call d_flush (DBG_FD(rv)) + } + + # Miscellaneous info cleanup + RV_HJD(rv) = hjd # Object HJD + RV_MJD_OBS(rv) = jd - 2400000.5d0 # Object MJD-OBS + + call imunmap (imo) # Free image pointers + call imunmap (imr) + return (OK) +end + + +# RV_GPOSINFO - Get positional and time info about the observation from image +# header + +int procedure rv_gposinfo (rv, im, is_obj, ra, dec, ep, ut, day, month, year) + +pointer rv #I RV struct pointer +pointer im #I Image pointer +int is_obj #I Is image object image? +double ra, dec, ep #O position info +double ut #O UT of observation +int day, month, year #O Date of observation + +double ut_start, ut_mid, int_time, time, imgetd() +int code, flags, idx +char buf[SZ_LINE] + +int rv_parse_date(), rv_parse_timed(), imaccf(), stridx() +errchk imgetd() + +begin + code = OK + if (rv_parse_date (rv, im, KW_DATE_OBS(rv), is_obj, day, month, year, + time, flags) == ERR_RVCOR) { + code = ERR_RVCOR + } + if (rv_parse_timed (rv, im, is_obj, KW_RA(rv), ra) == ERR_RVCOR) + code = ERR_RVCOR + if (rv_parse_timed (rv, im, is_obj, KW_DEC(rv), dec) == ERR_RVCOR) + code = ERR_RVCOR + + iferr (ep = imgetd (im, KW_EPOCH(rv))) { + call rv_err_comment (rv, "ERROR: Missing EPOCH keyword.", "") + code = ERR_RVCOR + } + ut_start = time + + # If we have a UTMIDDLE keyword use that as the midpoint of the + # observation. + + if (imaccf(im,KW_UTMID(rv)) == YES) { + # If this is a DATE-OBS type of string, look for the time delimiter. + call aclrc (buf, SZ_LINE) + call imgstr (im, KW_UTMID(rv), buf, SZ_LINE) + idx = stridx("T", buf) + + if (idx > 0) { + if (rv_parse_date (rv, im, KW_UTMID(rv), is_obj, + day, month, year, time, flags) == ERR_RVCOR) { + code = ERR_RVCOR + } + ut = time + } + + if (idx == 0 || code == ERR_RVCOR) { + iferr (ut = imgetd (im, KW_UTMID(rv))) { + # Try to recover + if (rv_parse_timed (rv, im, is_obj, KW_UT(rv), ut_start) + == ERR_RVCOR) { + code = ERR_RVCOR + } + iferr (int_time = imgetd (im, KW_EXPTIME(rv))) { + call rv_err_comment (rv, + "ERROR: Missing exposure time keyword.", "") + code = ERR_RVCOR + } + ut = double (ut_start + (int_time/3600.0)/2.0) + } + ut_mid = ut + } + } else { + + # No UTMIDDLE keyword, so compute it from the UT and EXPTIME. + # Time specified in the DATE-OBS keyword, if present, takes + # precedence over UT keyword value. + + if (flags != TF_OLDFITS && !IS_INDEFD(time)) { + # Use the DATE-OBS time value as the UT. + ut_start = time + + } else if (imaccf(im,KW_UT(rv)) == YES) { + if (rv_parse_timed (rv, im, is_obj, KW_UT(rv), + ut_start) == ERR_RVCOR) { + code = ERR_RVCOR + ut_start = 0.0d0 + } + } + + iferr (int_time = imgetd (im, KW_EXPTIME(rv))) { + call rv_err_comment (rv, + "ERROR: Missing exposure time keyword.", "") + code = ERR_RVCOR + int_time = 0.0d0 + } + ut = double (ut_start + (int_time/3600.0)/2.0) + ut_mid = ut + } + + # Check for a rollover of the date. This can happen e.g. when + # UT observing starts before midnight but the midpoint of the + # exposure is after midnight, the date and time are then separated + # by 24 hr. Likewise, if the midpoint is less that the start + # time, we've rolled over midnight. + if (ut > 24.0) { + call rv_incr_date (day, month, year) + ut = ut - 24 + } + if (ut_mid < ut_start) + call rv_incr_date (day, month, year) + + return (code) +end + + +# RV_INCR_DATE - Increment the date by 1 day, taking into account month, +# year and leap-year rollovers. + +procedure rv_incr_date (day, month, year) + +int day, month, year #I Date of observation + +int days_per_month[12] # days per month +data days_per_month/31,28,31,30,31,30,31,31,30,31,30,31/ + +begin + if (mod (year, 4) == 0) # set the days/month for leap years + days_per_month[2] = 29 + + day = day + 1 # increment day + if (day > days_per_month[month]) { + day = 1 + month = month + 1 + } + if (month > 12) { + month = 1 + year = year + 1 + } +end + + +# RV_SHIFT2VEL - Compute a velocity from the given pixel shift. Application +# of the heliocentric corrections is handled above. + +double procedure rv_shift2vel (rv, shift) + +pointer rv #I RV struct pointer +real shift #I Pixel shift in ccf + +double lambda, delta_lambda +double dxp, vel + +double dex() + +begin + if (RV_DCFLAG(rv) == 0) { + # Compute the wavelength/velocity shift. (Use central wavelength) + delta_lambda = double (shift * RV_RWPC(rv)) + lambda = double (RV_RW0(rv) + RV_RWPC(rv) * real(RV_RNPTS(rv)-1)/2.) + vel = double (delta_lambda / lambda * SPEED_OF_LIGHT) + } else if (RV_DCFLAG(rv) == 1) { + # Below is the correct _relativistic_ redshift equation! + dxp = dex (RV_RWPC(rv) * shift) - 1.0d0 + vel = SPEED_OF_LIGHT * dxp + } else if (RV_DCFLAG(rv) == -1) + vel = INDEFD + + return (vel) +end + + +# RV_VEL2SHIFT - Compute a shift from the given velocity shift. + +real procedure rv_vel2shift (rv, vel) + +pointer rv #I RV struct pointer +real vel #I Pixel shift in ccf + +real lambda, shift + +begin + if (RV_DCFLAG(rv) == 0) { + lambda = double (RV_RW0(rv) + RV_RWPC(rv) * real(RV_RNPTS(rv)-1)/2.) + shift = double ((vel/C)*lambda) / double (RV_RWPC(rv)) + + } else if (RV_DCFLAG(rv) == 1) { + shift = log10 (vel / C + 1) / double (RV_RWPC(rv)) + + } else if (RV_DCFLAG(rv) == -1) + shift = INDEFR + + return (shift) +end + + +# RV_CORRECT - Compute the radial velocity corrections. + +procedure rv_corr (rv, im, ra, dec, ep, year, month, day, ut, jd, hjd, vrot, + vbary, vorb, vsol) + +pointer rv #I RV struct pointer +pointer im #I Image descriptor +double ra, dec, ep #I Positional info +int year, month, day #I Date of obs info +double ut #I Time of info +double jd #I JD of observation +double hjd #I Heliocentric Julian Date +double vrot #O Correction for E rotation +double vbary #O Correction for E-M barycentre +double vorb #O Correction for E orbital movement +double vsol #O Correction to LSR + +double epoch +double ra_obs, dec_obs, t +double lat, lon, alt +double ast_julday() +bool newobs, obshead +double obsgetd() +pointer obspars() + +begin + call obsimopen (RV_OBSPTR(rv), im, + Memc[P2C(obspars(RV_OBSPTR(rv), "observatory"))], + NO, newobs, obshead) + if (newobs || obshead) { + RV_LATITUDE(rv) = real (obsgetd (RV_OBSPTR(rv), "latitude")) + RV_LONGITUDE(rv) = real (obsgetd (RV_OBSPTR(rv), "longitude")) + RV_ALTITUDE(rv) = real (obsgetd (RV_OBSPTR(rv), "altitude")) + } + lat = double (RV_LATITUDE(rv)) + lon = double (RV_LONGITUDE(rv)) + alt = double (RV_ALTITUDE(rv)) + + # Determine epoch of observation and precess coordinates. + call ast_date_to_epoch (year, month, day, ut, epoch) + call ast_precess (ra, dec, ep, ra_obs, dec_obs, epoch) + call ast_hjd (ra_obs, dec_obs, epoch, t, hjd) + + # Determine velocity components. + call ast_vbary (ra_obs, dec_obs, epoch, vbary) + call ast_vrotate (ra_obs, dec_obs, epoch, lat, lon, alt, vrot) + call ast_vorbit (ra_obs, dec_obs, epoch, vorb) + + jd = ast_julday (epoch) + vsol = 0.0 + + if (DBG_DEBUG(rv) == YES) { + call d_printf(DBG_FD(rv), "\tlat=%.5f long=%.5f alt=%.5f\n") + call pargd(lat); call pargd(lon); call pargd(alt) + } +end + + +# RV_PARSE_DATE - Parse a date string and return components + +int procedure rv_parse_date (rv, im, param, is_obj, day, month, year, tm, flags) + +pointer rv #I rv struct pointer +pointer im #I image pointer +char param[SZ_LINE] #I image parameter to get +int is_obj #I is image object image? +int day, month, year #O date components +double tm #O time string +int flags #O flags + +char date[SZ_FNAME] + +int dtm_decode() +errchk imgstr() + +begin + iferr (call imgstr(im, param, date, SZ_LINE)) { + if (is_obj == YES) { + call rv_err_comment (rv, + "ERROR: Error getting '%s' from object image header.",param) + } else { + call rv_err_comment (rv, + "ERROR: Error getting '%s' from temp image header.",param) + } + call flush (STDERR) + return (ERR_RVCOR) + } + + # Decode the keyword. We ignore any time information since this + # is obtained from other keywords. + if (dtm_decode (date, year, month, day, tm, flags) == ERR) { + call rv_err_comment (rv, + "ERROR: Error parsing date keyword.", "") + return (ERR_RVCOR) + } + + return (OK) +end + + +# RV_PARSE_TIMED - Utility to read a sexigimal field and return the answer +# as decimal hours or degrees. The fields are decoded as follows: +# +# hh:mm:ss.ss -> hh + mm/60. + ss.ss / 3600. + +int procedure rv_parse_timed (rv, im, is_obj, param, dval) + +pointer rv #I RV struct pointer +pointer im #I Image pointer +int is_obj #I Is image object image? +char param[SZ_LINE] #I Image parameter to read +double dval #O Output answer + +pointer sp, buf +int res, flag, idx +int yr, mon, day, hr, min +double sec + +int dtm_decode_hms(), stridx() +errchk imgstr + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + dval = INDEFD + + + iferr (call imgstr(im, param, Memc[buf], SZ_FNAME)) { + if (is_obj == YES) { + call rv_err_comment (rv, + "ERROR: Error getting '%s' from object image header.",param) + } else { + call rv_err_comment (rv, + "ERROR: Error getting '%s' from temp image header.", param) + } + call sfree (sp) + call flush (STDERR) + return (ERR_RVCOR) + } + + + # If this is a DATE-OBS type of string, look for the time delimiter. + idx = stridx("T", Memc[buf]) + + # Allow only sexigesimal or decimal values. + if (stridx(":", Memc[buf]) == 0 && stridx (".", Memc[buf]) == 0) { + if (is_obj == YES) { + call rv_err_comment (rv, + "ERROR: Invalid time string '%s' from object header.",param) + } else { + call rv_err_comment (rv, + "ERROR: Invalid time string '%s' from temp header.", param) + } + call sfree (sp) + call flush (STDERR) + return (ERR_RVCOR) + } + + + if (idx > 0) { + # Decode the date-obs string for the time. + res = dtm_decode_hms (Memc[buf], yr, mon, day, hr, min, sec, flag) + dval = hr + double(min) / 60.0 + sec / 3600.0 + + } else { + # Let gargd() decode the sexigesimal field. + call sscan (Memc[buf]) + call gargd (dval) + } + + + call sfree (sp) + return (OK) +end diff --git a/noao/rv/rvsample.h b/noao/rv/rvsample.h new file mode 100644 index 00000000..e8e0b4bd --- /dev/null +++ b/noao/rv/rvsample.h @@ -0,0 +1,44 @@ +# Correlation sample regions data structure definition file. The pointers +# into this structure are pre-allocated and defined in "rvpackage.h". + +define SZ_SAMPSTRUCT 10 # Size of the sample structure +define MAX_SAMPLES 64 # Max number of samples + +# Sample regions structure definiton. +define SR_UNITS Memi[$1] # Range specifications units +define SR_COUNT Memi[$1+1] # No. of range sections +define SR_ERANGE Memi[$1+2] # Array of starting points (ptr) +define SR_SRANGE Memi[$1+3] # Array of ending points (ptr) +define SR_NPSAMP Memi[$1+4] # Npts in sample region (ptr) + +define SR_IMTYPE Memi[$1+5] # Image type for sample +define SR_MODIFY Memi[$1+6] # Sample was modified +define SR_PARENT Memi[$1+7] # Structure parent pointer +define SR_W0 Memr[P2R($1+8)] # Structure W0 value +define SR_WPC Memr[P2R($1+9)] # Structure WPC value + + +##################### END OF STRUCTURE DEFINITIONS ########################## + +# De-reference the structure elements into something readable. Sample +# regions are referenced as (e.g.) "OSRANGE(rv,i)" where 'i' is the sample +# of interest. We just want to pass a pointer into work routines but we +# also want to address object and template samples individually. + +# For these definitions the "$1" is the pointer to the sample struct. +define SRANGE Memr[SR_SRANGE($1)+$2-1] # Start of range +define ERANGE Memr[SR_ERANGE($1)+$2-1] # End of range +define NPSAMP Memi[SR_NPSAMP($1)+$2-1] # NPTS in range + +# For these definitions the "$1" is the main rv struct pointer. +define ORUNITS SR_UNITS(RV_OSAMPLE($1)) # Object sample units +define ORCOUNT SR_COUNT(RV_OSAMPLE($1)) # Object # of samples +define OSRANGE SRANGE(RV_OSAMPLE($1),$2) # Object start of range +define OERANGE ERANGE(RV_OSAMPLE($1),$2) # Object end of range +define ONPSAMP NPSAMP(RV_OSAMPLE($1),$2) # Object npts in sample + +define RRUNITS SR_UNITS(RV_RSAMPLE($1)) # Temp. sample units +define RRCOUNT SR_COUNT(RV_RSAMPLE($1)) # Temp. # of samples +define RSRANGE SRANGE(RV_RSAMPLE($1),$2) # Temp. start of range +define RERANGE ERANGE(RV_RSAMPLE($1),$2) # Temp. end of range +define RNPSAMP NPSAMP(RV_RSAMPLE($1),$2) # Temp. npts in sample diff --git a/noao/rv/rvsample.x b/noao/rv/rvsample.x new file mode 100644 index 00000000..750e9c96 --- /dev/null +++ b/noao/rv/rvsample.x @@ -0,0 +1,493 @@ +include <gset.h> +include <ctype.h> +include "rvpackage.h" +include "rvflags.h" +include "rvsample.h" + +# SAMP_OPEN - Open a Sample structure. + +procedure samp_open (ssp) + +pointer ssp #I Sample struct pointer + +errchk calloc + +begin + iferr (call calloc (ssp, SZ_SAMPSTRUCT, TY_STRUCT)) + call error (0, "Error opening sample structure.") + + iferr { + call calloc (SR_SRANGE(ssp), MAX_SAMPLES, TY_REAL) + call calloc (SR_ERANGE(ssp), MAX_SAMPLES, TY_REAL) + call calloc (SR_NPSAMP(ssp), MAX_SAMPLES, TY_INT) + } then + call error (0, "Error allocating sample structure.") +end + + +# SAMP_CLOSE - Close (free) a sample structure. + +procedure samp_close (ssp) + +pointer ssp #I Sample struct pointer + +begin + if (ssp == NULL) + return + + call mfree (SR_SRANGE(ssp), TY_REAL) + call mfree (SR_ERANGE(ssp), TY_REAL) + call mfree (SR_NPSAMP(ssp), TY_INT) + SR_COUNT(ssp) = 0 + + call mfree (ssp, TY_STRUCT) +end + + +# RV_LOAD_SAMPLE - Given a string in 'ranges' format, decode it and load +# the sample structure. Returns an ERR of OK. + +int procedure rv_load_sample (ssp, s) + +pointer ssp #I Sample struct pointer +char s[ARB] #I Range string to parse + +pointer sp, buf, rv +int ip, i, j, rcount, units +int sample_units() + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + rv = SR_PARENT(ssp) + ip = 1 + if (!IS_DIGIT(s[ip])) + ip = ip + 1 # Units specified + + rcount = 0 + while (s[ip] != EOS) { + rcount = rcount + 1 + for (j=1; j<=2; j=j+1) { # Collect the numbers + while (IS_WHITE(s[ip])) # Skip leading white space + ip = ip + 1; + + call aclrs (Memc[buf], SZ_LINE) + for (i=0; (s[ip]=='.'||IS_DIGIT(s[ip]))&&i<SZ_LINE; i=i+1) { + Memc[buf+i] = s[ip] + ip = ip + 1 + if (s[ip] == EOS) + break + } + + call sscan (Memc[buf]) + if (j == 1) { + call gargr (SRANGE(ssp,rcount)) + repeat { # skip ahead to next number + ip = ip + 1 + } until (IS_DIGIT(s[ip]) || s[ip] == EOS) + + } else if (j == 2) + call gargr (ERANGE(ssp,rcount)) + } + + if (s[ip] != EOS) { + repeat { # skip ahead to delimeter + ip = ip + 1 + } until (IS_DIGIT(s[ip]) || s[ip] == EOS) + } + if (s[ip] == EOS) + break + } + + SR_COUNT(ssp) = rcount + if (RV_DCFLAG(rv) == -1 || RV_PIXCORR(rv) == YES) { + SR_UNITS(ssp) = PIXELS + } else { + units = sample_units (s) + if (SR_UNITS(ssp) != NULL && SR_UNITS(ssp) != units) { + call rv_errmsg ("Range units are mixed from previous entry.") + call sfree (sp) + return (ERR) + } else + SR_UNITS(ssp) = units + } + + if (SR_UNITS(ssp) == ERR) { + call rv_errmsg ("Unable to determine range units in range string.") + call sfree (sp) + return (ERR) + } + + call sort_ranges (ssp) + call sfree (sp) + return (OK) +end + + +# RV_MAKE_RANGE_STRING - Given the struct pointer return a string in 'ranges' +# format describing the content of the range arrays. + +procedure rv_make_range_string (ssp, str) + +pointer ssp #I Sample struct pointer +char str[SZ_LINE] #O output range string + +pointer sp, buf +pointer rv +int i + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call aclrs (str, SZ_LINE) + + rv = SR_PARENT(ssp) + if (SR_COUNT(ssp) == ALL_SPECTRUM) { + call strcpy ("*", str, SZ_FNAME) + + } else { + if (SR_UNITS(ssp) == PIXELS || RV_DCFLAG(rv) == -1 || + RV_PIXCORR(rv) == YES) { + SR_UNITS(ssp) = PIXELS + call strcpy ("P", str, SZ_LINE) + } else + call strcpy ("A", str, SZ_LINE) + do i = 1, SR_COUNT(ssp) { + call aclrs (Memc[buf], SZ_LINE) + call sprintf (Memc[buf], SZ_LINE, "%-.2f-%-.2f") + call pargr (SRANGE(ssp,i)) + call pargr (ERANGE(ssp,i)) + call strcat (Memc[buf], str, SZ_LINE) + if (i != SR_COUNT(ssp)) # No ',' after last range + call strcat (",", str, SZ_LINE) + } + } + + call sfree (sp) +end + + +# RV_MARK_REGIONS - Cycle through the range list and mark each region. + +procedure rv_mark_regions (ssp, gp) + +pointer ssp #I Sample struct pointer +pointer gp #I GIO pointer + +pointer rv +real left, right +int i + +double dex() +int gstati() + +begin + if (SR_COUNT(ssp) == ALL_SPECTRUM || gp == NULL) + return + + rv = SR_PARENT(ssp) + if (gstati(gp, G_PLTYPE) != GL_CLEAR) + call gseti (gp, G_PLCOLOR, C_GREEN) + do i = 1, SR_COUNT(ssp) { + left = SRANGE(ssp,i) + right = ERANGE(ssp,i) + if (RV_PIXCORR(rv) == NO && RV_DCFLAG(rv) != -1 && + SR_UNITS(ssp) == PIXELS) { + left = real (dex(SR_W0(ssp)+(left-1)*SR_WPC(ssp))) + right = real (dex(SR_W0(ssp)+(right-1)*SR_WPC(ssp))) + } + + call gseti (gp, G_WCS, 1) + if (SR_IMTYPE(ssp) == REFER_SPECTRUM) + call gsview (gp, 0.115, 0.95, 0.125, 0.5) + else + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + call mark_range (gp, left, right) + } + if (gstati(gp, G_PLTYPE) != GL_CLEAR) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) +end + + +# RV_ERASE_REGIONS - Erase the regions drawn to the screen. + +procedure rv_erase_regions (ssp, gp) + +pointer ssp #I Sample struct pointer +pointer gp #I GIO pointer + +begin + if (gp == NULL) + return + + call gseti (gp, G_PLTYPE, GL_CLEAR) + call gseti (gp, G_PLCOLOR, C_BACKGROUND) + call rv_mark_regions (ssp, gp) + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) +end + + +# APPEND_RANGE - Append another region to the range string + +procedure append_range (rv, ssp, left, right) + +pointer rv #I RV struct pointer +pointer ssp #I Sample struct pointer +real left, right #I WCS of region endpoints + +pointer gp +int i, j, k + +define add_samp_ 99 + +begin + gp = RV_GP(rv) # intializations + + # Check if we have enough room for it. + if(SR_COUNT(ssp)+1 > MAX_SAMPLES) { + call rv_errmsg ("Cannot add another sample (max_samples=%d).") + call pargi (MAX_SAMPLES) + return + } + + # Convert a wavelength range to pixels if necessary. + if (SR_UNITS(ssp) == PIXELS && RV_DCFLAG(SR_PARENT(ssp)) != -1) { + left = (log10(left) - SR_W0(ssp)) / SR_WPC(ssp) + 1 + right = (log10(right) - SR_W0(ssp)) / SR_WPC(ssp) + 1 + } + + # Now figure out what to do with it. Here we edit the existing + # sample so they make more sense or else just add the range and + # sort it. + if (SR_COUNT(ssp) == ALL_SPECTRUM) { # special case + SR_COUNT(ssp) = 1 + SRANGE(ssp,1) = left + ERANGE(ssp,1) = right + if (RV_DCFLAG(rv) == -1 || RV_PIXCORR(rv) == YES) + SR_UNITS(ssp) = PIXELS + else + SR_UNITS(ssp) = LAMBDA + call rv_mark_regions (ssp, gp) + return + } + do i = 1, SR_COUNT(ssp) { + if (left >= SRANGE(ssp,i) && left <= ERANGE(ssp,i)) { + j = 1 # Find the right side. + while (j <= SR_COUNT(ssp)) { + if (right >= SRANGE(ssp,j) && right <= ERANGE(ssp,j)) { + if ((j-i) == 0) # within the same sample + return + else if ((j-i) == 1) { # in the next sample + right = ERANGE(ssp,j) + call rv_erase_regions (ssp, gp) + call delete_samp (rv, ssp, SRANGE(ssp,j)) + ERANGE(ssp,i) = right + call sort_ranges (ssp) + call rv_mark_regions (ssp, gp) + return + } else if ((j-i) > 1) { # skipped a few samples + right = ERANGE(ssp,j) + call rv_erase_regions (ssp, gp) + do k = i+1, j-1 + call delete_samp (rv, ssp, SRANGE(ssp,k)) + ERANGE(ssp,i) = right + call sort_ranges (ssp) + call rv_mark_regions (ssp, gp) + return + } + + } + j = j + 1 + } + if (j == SR_COUNT(ssp)+1) { # right is between samples + call rv_erase_regions (ssp, gp) + ERANGE(ssp,i) = right + call rv_mark_regions (ssp, gp) + return + } + } + if (right >= SRANGE(ssp,i) && right <= ERANGE(ssp,i)) { + call rv_erase_regions (ssp, gp) + SRANGE(ssp,i) = left + call rv_mark_regions (ssp, gp) + return + } + } + + # The endpoints aren't included within another region. Let's see if + # they then enclose one.... + do i = 1, SR_COUNT(ssp) { + if (SRANGE(ssp,i) >= left && SRANGE(ssp,i) <= right) { + j = 1 + while (j<SR_COUNT(ssp) && right>=ERANGE(ssp,j)) { + j = j + 1 + } + if (j == i) { # in the next sample + call delete_samp (rv, ssp, SRANGE(ssp,j)) + } else if ((j-i) >= 1) { # skipped a few samples + do k = i, j + call delete_samp (rv, ssp, SRANGE(ssp,k)) + } + break + } + } + + # Just add it to the list. + SR_COUNT(ssp) = SR_COUNT(ssp) + 1 + SRANGE(ssp,SR_COUNT(ssp)) = left + ERANGE(ssp,SR_COUNT(ssp)) = right + call rv_mark_regions (ssp, gp) + call sort_ranges (ssp) +end + + +# DELETE_SAMP - Delte a sample range from the list. + +procedure delete_samp (rv, ssp, x) + +pointer rv #I RV struct pointer +pointer ssp #I Sample struct pointer +real x #I WCS value of region to delete + +double dex() +real l, r +pointer gp +int i, j + +begin + gp = RV_GP(rv) + if (SR_COUNT(ssp) == 1) { # special case + call rv_erase_regions (ssp, RV_GP(rv)) + SR_COUNT(ssp) = ALL_SPECTRUM + return + } + + # Find the sample to delete. + if (SR_UNITS(ssp) == PIXELS && RV_DCFLAG(rv) != -1) + x = (log10(x) - SR_W0(ssp)) / SR_WPC(ssp) + 1 + + do i = 1, SR_COUNT(ssp) { + if (x >= SRANGE(ssp,i) && x <= ERANGE(ssp,i)) { + if (SR_IMTYPE(ssp) == OBJECT_SPECTRUM) + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + else if (SR_IMTYPE(ssp) == REFER_SPECTRUM) + call gsview (gp, 0.115, 0.95, 0.125, 0.5) + if (RV_PIXCORR(rv) == NO && RV_DCFLAG(rv) != -1 && + SR_UNITS(ssp) == PIXELS) { + l = real (dex(SR_W0(ssp)+(SRANGE(ssp,i)-1)*SR_WPC(ssp))) + r = real (dex(SR_W0(ssp)+(ERANGE(ssp,i)-1)*SR_WPC(ssp))) + } else { + l = SRANGE(ssp,i) + r = ERANGE(ssp,i) + } + call erase_range (gp, l, r) + if (i == SR_COUNT(ssp)) { + SR_COUNT(ssp) = SR_COUNT(ssp) - 1 + } else { + do j = i, SR_COUNT(ssp)-1 { + SRANGE(ssp,j) = SRANGE(ssp,j+1) + ERANGE(ssp,j) = ERANGE(ssp,j+1) + } + SR_COUNT(ssp) = SR_COUNT(ssp) - 1 + } + return + } + } +end + + +# MARK_RANGE - Mark the region selected on the screen with a bar. + +procedure mark_range (gp, left, right) + +pointer gp #I GIO pointer +real left, right #I WCS of boundaries of region + +real x1, x2, y1, y2, y + +begin + if (gp == NULL) + return + + call ggwind (gp, x1, x2, y1, y2) + y = y1 + (y2-y1)/20.0 # Put it near bottom 5% + + call gamove (gp, left, y) # Draw the horizontal bar + call gadraw (gp, right, y) + + call gamove (gp, left, y1) # draw the cross bars at ends + call gadraw (gp, left, y1+(2*(y-y1))) + call gamove (gp, right, y1) + call gadraw (gp, right, y1+(2*(y-y1))) + call gflush (gp) +end + + +# ERASE_RANGE - Erase the range drawn to the screen. + +procedure erase_range (gp, left, right) + +pointer gp #I GIO pointer +real left, right #I Range endpoints + +begin + if (gp == NULL) + return + + call gseti (gp, G_PLCOLOR, C_BACKGROUND) + call mark_range (gp, left, right) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) +end + + +# SAMPLE_UNITS - Figure out what units the regions string is used in + +int procedure sample_units (str) + +char str[ARB] #I range specification string + +begin + if (str[1] == 'a' || str[1] == 'A' || IS_DIGIT(str[1])) + return (LAMBDA) + else if (str[1] == 'p' || str[1] == 'P') + return (PIXELS) + else { + return (ERR) + } +end + + +# SORT_RANGES - Sort the ranges structure from left to right in terms of +# regions to simplify masking process + +procedure sort_ranges (ssp) + +pointer ssp #I Sample struct pointer + +int i, j, npts +real temp + +begin + if (SR_COUNT(ssp) == 1 || SR_COUNT(ssp) == ALL_SPECTRUM) + return + + # Now do a simple insertion sort of the ranges + npts = SR_COUNT(ssp) + do i = 2, npts { + j = i + while (SRANGE(ssp,j) < SRANGE(ssp,j-1)) { + # Swap 'em + temp = SRANGE(ssp,j-1) + SRANGE(ssp,j-1) = SRANGE(ssp,j) + SRANGE(ssp,j) = temp + + temp = ERANGE(ssp,j-1) + ERANGE(ssp,j-1) = ERANGE(ssp,j) + ERANGE(ssp,j) = temp + + j = j - 1 + } + } +end diff --git a/noao/rv/rvsinc.com b/noao/rv/rvsinc.com new file mode 100644 index 00000000..c93ec8aa --- /dev/null +++ b/noao/rv/rvsinc.com @@ -0,0 +1,8 @@ +# Common values for the sinc interpolation. +pointer sx # Pointer to X array (real) +pointer sy # Pointer to Y array (real) +pointer splx # Pointer to X plot array (real) +pointer sply # Pointer to Y plot array (real) +int snfit # Number of points being fit + +common /sinccom/ sx, sy, splx, sply, snfit diff --git a/noao/rv/rvsinc.x b/noao/rv/rvsinc.x new file mode 100644 index 00000000..07816a23 --- /dev/null +++ b/noao/rv/rvsinc.x @@ -0,0 +1,243 @@ +include <mach.h> +include <math.h> +include "rvpackage.h" +include "rvflags.h" + +# RV_SINC - Do the Fourier (sinc) interpolation to determine the peak center +# and FWHM values. Height of the ccf at the peak is also returned. + +procedure rv_sinc (rv, shift, fwhm, height) + +pointer rv #I RV struct pointer +real shift #O Shift of the peak +real fwhm #O FWHM of the peak +real height #O Height of peak at center + +int i, j, k, il, ir +real x, y, back, lhp, rhp, hpower, ipeak +real brent(), sinc_interp(), rv_maxpix() + +errchk realloc, mfree + +include "rvsinc.com" + +begin + # Initialize. + il = RV_ISTART(rv) + ir = RV_IEND(rv) + ipeak = WRKPIXX(rv,RV_ISHIFT(rv)) + snfit = ir - il + 1 + + # Allocate the pointers in the common + call realloc (sx, snfit, TY_REAL) + call realloc (sy, snfit, TY_REAL) + call realloc (splx, snfit*10, TY_REAL) + call realloc (sply, snfit*10, TY_REAL) + + # Now move the part of the ccf we're fitting into the arrays, but + # change the sign of the ccf because we're finding a minimum with + # the algorithm used + call amovr (WRKPIXX(rv,il), Memr[sx], snfit) + call amulkr (WRKPIXY(rv,il), -1.0, Memr[sy], snfit) + + # Now find the peak center and height. + height = brent (ipeak-1., ipeak, ipeak+1., RV_TOLERANCE(rv), + RV_MAXITERS(rv), shift) + height = - height + + # Compute the sinc interpolant over the ccf to see how close we came. + # It will be plotted later so we don't free the pointers right away. + do i = 1, snfit-1 { + do j = 1, 10 { + k = ((i-1)*10+j) + Memr[splx+k-1] = Memr[sx+i-1] + ((j-1)/10.) + Memr[sply+k-1] = - sinc_interp (Memr[splx+k-1]) + } + } + height = rv_maxpix (Memr[sply], snfit*10) + + # Compute the FWHM through some rather brute force methods. + back = RV_BACKGROUND(rv) + hpower = back + (height - back) / 2. + if (IS_INDEF(RV_BACKGROUND(rv))) { + fwhm = INDEF # don't compute a fwhm + RV_FWHM_Y(rv) = INDEF + } else if (WRKPIXY(rv,RV_ISTART(rv)) > hpower || + WRKPIXY(rv,RV_IEND(rv)) > hpower) { + fwhm = INDEF # don't compute a fwhm + RV_FWHM_Y(rv) = INDEF + } else { + RV_FWHM_Y(rv) = hpower + for (i=RV_ISHIFT(rv); WRKPIXY(rv,i)>hpower&&i>=1; i=i-1) + x = WRKPIXX(rv,i) + for (y=-sinc_interp(x); abs(y-hpower)>0.005; x=x-0.005) + y = - sinc_interp (x-0.005); + lhp = x - 0.005 + for (i=RV_ISHIFT(rv); WRKPIXY(rv,i)>hpower && i<=RV_CCFNPTS(rv); + i=i+1) + x = WRKPIXX(rv,i) + for (y=-sinc_interp(x); abs(y-hpower)>0.005; x=x+0.005) + y = - sinc_interp (x+0.005); + rhp = x + 0.005 + fwhm = abs (rhp - lhp) + } + + # Clean up a little + call mfree (sx, TY_REAL) + call mfree (sy, TY_REAL) +end + + +# SINC_INTERP - Function subroutine to do the sine (fourier) interpolation and +# return the value of the correlation function for any x value. +# +# h(t) = Sum(all n) [ h_n * sin(pi*(t-n)) /(pi*(t-n))] +# +# The interval between samples is assumed to be unity. + +real procedure sinc_interp (x) + +real x #I Point to be evaluated + +real sval, tmp +int i + +include "rvsinc.com" + +begin + # Check for an integer x. If present, return the ccf value and don't + # interpolate. + tmp = abs (float(nint(x)) - x) + if (tmp < EPSILON && x >= Memr[sx] && x <= Memr[sx+snfit-1]) { + do i = 1, snfit { + if (abs(Memr[sx+i-1]-x) < EPSILON) # find the y point + sval = Memr[sy+i-1] + } + return (sval) + } + + # Do the evaluation. + tmp = sin (PI*(x-Memr[sx])) + sval = Memr[sy] * tmp / (PI * (x - Memr[sx])) + do i = 1, snfit-1 { + tmp = -tmp + sval = sval + Memr[sy+i] * tmp / (PI * (x - Memr[sx+i])) + } + + return (sval) +end + + +# BRENT - Given a function F(), and given a bracketing triplet of abscissas +# AX, BX, CX (such that BX is between AX and CX, and F(bx) is less than both +# F(AX) and F(BX)), this routine isolates the minimum to a fractional precision +# of about TOL using Brent's Method. The abscissa of the minimum is returned +# as XMIN, and the minimum function value is the function return value. + +real procedure brent (ax, bx, cx, tol, itmax, xmin) + +real ax, bx, cx #I Interp. bracketing points +real tol #I Tolerance +int itmax #I Max no. of iterations +real xmin #O Minimum point + +real a, b, d, etemp, fu, fv, fw, fx # local variables +real p, q, r, tol1, tol2, u, v, w, x, xm +real e +int iter + +real sinc_interp() + +define CGOLD .3819660 # golden ration +define ZEPS 1.0e-10 # a small number +define SHIFT {$1=$2;$2=$3;$3=$4} + +begin + a = min (ax, cx) # initialize + b = max (ax, cx) + v = bx + w = v + x = v + e = 0. + fx = sinc_interp (x) + fv = fx + fw = fx + e = 0.0 + + do iter = 1, itmax { + xm = 0.5 * (a + b) + tol1 = tol * abs (x) + ZEPS + tol2 = 2. * tol1 + if (abs(x-xm) <= (tol2-0.5*(b-a))) { # test for convergence + xmin = x + return (fx) + } + if (abs(e) > tol1) { # construct a trial + r = (x-w) * (fx-fv) # parabolic fit + q = (x-v) * (fx-fw) + p = (x-v) * q - (x-w) * r + q = 2. * (q-r) + if (q > 0.) + p = -p + q = abs(q) + etemp = e + e = d + + # Determine the acceptability of the parabolic fit. Here we + # take the golden section step into the larger of the two + # segments. + + if (abs(p) >= abs(.5*q*etemp) || p <= q*(a-x) || p >= q*(b-x)) { + if (x >= xm) + e = a - x + else + e = b - x + d = CGOLD * e + } else { + d = p/q # take parabolic step + u = x+d + if (u-a < tol2 || b-u < tol2) + d = sign (tol1, xm-x) + } + } else { + if (x >= xm) + e = a - x + else + e = b - x + d = CGOLD * e + } + + if (abs(d) >= tol1) + u = x + d + else + u = x + sign (tol1,d) + + fu = sinc_interp (u) + if (fu <= fx) { + if (u >= x) + a = x + else + b = x + SHIFT(v,w,x,u) + SHIFT(fv,fw,fx,fu) + } else { + if (u < x) + a = u + else + b = u + if (fu <= fw || w == x) { + v = w + fv = fw + w = u + fw = fu + } else if (fu <= fv || v == x || v == w) { + v = u + fv = fu + } + } + } + + call rv_errmsg ("BRENT: Exceeded maximum number of iterations.\n") + xmin = x + return (fx) +end diff --git a/noao/rv/rvstrings.x b/noao/rv/rvstrings.x new file mode 100644 index 00000000..9029b006 --- /dev/null +++ b/noao/rv/rvstrings.x @@ -0,0 +1,330 @@ +include "rvpackage.h" +include "rvflags.h" +include "rvfilter.h" +include "rvcont.h" +include "rvplots.h" + +# RVSTRINGS - A file containing utility routines to convert between the +# strdic() strings and their integer code equivalents. + +# CODES - A series of routines to get the correlation function, +# fitting function, or filter function given the string name of that +# function. Returns the integer code used by the tasks. + +int procedure cod_aptype (ap) + +char ap[SZ_FNAME] +bool streq() + +begin + if (streq(ap, "echelle")) + return (ECHELLE) + else if (streq(ap,"multispec")) + return (MULTISPEC) + else if (streq(ap, "twodspec")) + return (TWODSPEC) + else if (streq(ap, "onedspec") || + streq(ap, "sum") || + streq(ap, "average") || + streq(ap, "maximum")) + return (ONEDSPEC) +end + + +int procedure cod_cninterp (mode) + +char mode[SZ_FNAME] +int strdic() + +begin + return (strdic(mode, mode, SZ_FNAME, CN_INTERP_MODE)) +end + + +int procedure cod_color (color) + +char color[SZ_FNAME] +int strdic() + +begin + return (strdic(color, color, SZ_FNAME, C_COLOR_NAMES)) +end + + +int procedure cod_ccftype (ccf) + +char ccf[SZ_FNAME] +int strdic() + +begin + return (strdic(ccf, ccf, SZ_FNAME, CCF_TYPES)) +end + + +int procedure cod_filttype (filt) + +char filt[SZ_FNAME] #I Function name +int strdic() + +begin + return (strdic(filt, filt, SZ_FNAME, RV_FTYPES)) +end + + +int procedure cod_fitfunc (func) + +char func[SZ_FNAME] #I Function name +int strdic() + +begin + return (strdic(func, func, SZ_FNAME, RV_CFTYPES)) +end + + +int procedure cod_plotype (plot) + +char plot[SZ_FNAME] +int strdic() + +begin + return (strdic(plot, plot, SZ_FNAME, RV_PTYPES)) +end + + +int procedure cod_rebin (rebin) + +char rebin[SZ_FNAME] +int strdic() + +begin + return (strdic(rebin, rebin, SZ_FNAME, RB_WHICH)) +end + + +int procedure cod_verbose (str) + +char str[SZ_FNAME] #I Parameter string +int strdic() + +begin + return (strdic(str, str, SZ_FNAME, RV_OFTYPES)) +end + + +int procedure cod_which (which) + +char which[SZ_FNAME] +int strdic() + +begin + return (strdic(which, which, SZ_FNAME, RV_SPTODO)) +end + + +# NAMES - A series of routines to get the correlation function, +# fitting function, or filter function given the string name of that +# function. + +procedure nam_cninterp (rv, mode) + +pointer rv #I RV struct pointer +char mode[SZ_FNAME] #O Function name + +begin + switch (CON_CNFUNC(rv)) { + case CN_SPLINE3: + call strcpy ("spline3", mode, SZ_FNAME) + case CN_LEGENDRE: + call strcpy ("legendre", mode, SZ_FNAME) + case CN_CHEBYSHEV: + call strcpy ("chebyshev", mode, SZ_FNAME) + case CN_SPLINE1: + call strcpy ("spline1", mode, SZ_FNAME) + default: + call strcpy ("", mode, SZ_FNAME) + } +end + + +procedure nam_color (code, name) + +int code #I Color code +char name[SZ_FNAME] #O Color name + +begin + switch (code) { + case C_BACKGROUND: + call strcpy ("background", name, SZ_FNAME) + case C_FOREGROUND: + call strcpy ("foreground", name, SZ_FNAME) + case C_RED: + call strcpy ("red", name, SZ_FNAME) + case C_GREEN: + call strcpy ("green", name, SZ_FNAME) + case C_BLUE: + call strcpy ("blue", name, SZ_FNAME) + case C_CYAN: + call strcpy ("cyan", name, SZ_FNAME) + case C_YELLOW: + call strcpy ("yellow", name, SZ_FNAME) + case C_MAGENTA: + call strcpy ("magenta", name, SZ_FNAME) + case C_PUPLE: + call strcpy ("purple", name, SZ_FNAME) + case C_DARKSLATEGREY: + call strcpy ("slategrey", name, SZ_FNAME) + default: + call strcpy ("", name, SZ_FNAME) + } +end + + +procedure nam_fitfunc (rv, func) + +pointer rv #I RV struct pointer +char func[SZ_FNAME] #O Function name + +begin + if (IS_DBLSTAR(rv) == YES) { + call strcpy ("deblend", func, SZ_FNAME) + } else { + switch (RV_FITFUNC(rv)) { + case GAUSSIAN: + call strcpy ("gaussian", func, SZ_FNAME) + case PARABOLA: + call strcpy ("parabola", func, SZ_FNAME) + case LORENTZIAN: + call strcpy ("lorentzian", func, SZ_FNAME) + case CENTER1D: + call strcpy ("center1d", func, SZ_FNAME) + case SINC: + call strcpy ("sinc", func, SZ_FNAME) + default: + call strcpy ("", func, SZ_FNAME) + } + } +end + + +procedure nam_filttype (rv, filt) + +pointer rv #I RV struct pointer +char filt[SZ_FNAME] #O Function name + +begin + switch (RVF_FILTTYPE(rv)) { + case SQUARE: + call strcpy ("square", filt, SZ_FNAME) + case RAMP: + call strcpy ("ramp", filt, SZ_FNAME) + case HANNING: + call strcpy ("hanning", filt, SZ_FNAME) + case WELCH: + call strcpy ("welch", filt, SZ_FNAME) + default: + call strcpy ("", filt, SZ_FNAME) + } +end + + +procedure nam_plotype (rv, plot) + +pointer rv #I RV struct pointer +char plot[SZ_FNAME] #O Plot type + +begin + switch (RVP_PLOT(rv)) { + case AMPLITUDE_PLOT: + call strcpy ("amplitude", plot, SZ_FNAME) + case PHASE_PLOT: + call strcpy ("phase", plot, SZ_FNAME) + case POWER_PLOT: + call strcpy ("power", plot, SZ_FNAME) + default: + call strcpy ("", plot, SZ_FNAME) + } +end + + +procedure nam_rebin (rv, rebin) + +pointer rv #I RV struct pointer +char rebin[SZ_FNAME] #O Plot type + +begin + switch (RV_REBIN(rv)) { + case RB_OBJ: + call strcpy ("object", rebin, SZ_FNAME) + case RB_TEMP: + call strcpy ("template", rebin, SZ_FNAME) + case RB_SMALL: + call strcpy ("smallest", rebin, SZ_FNAME) + case RB_BIG: + call strcpy ("largest", rebin, SZ_FNAME) + default: + call strcpy ("", rebin, SZ_FNAME) + } +end + + +procedure nam_tempcode (tnum, cod) + +int tnum #I Template number +char cod[SZ_FNAME] #O Template code string + +begin + if (tnum <= 26) { # Get the simple case first. + cod[1] = ' ' + cod[2] = 'A' + tnum - 1 + } else { + cod[1] = 'A' + int ((tnum-1)/26) - 1 + cod[2] = 'A' + mod (tnum-1,26) + } + cod[3] = '\0' +end + + +procedure nam_verbose (rv, str) + +pointer rv #I RV struct pointer +char str[SZ_FNAME] #O Output string + +begin + switch (RV_VERBOSE(rv)) { + case OF_SHORT: + call strcpy ("short", str, SZ_FNAME) + case OF_LONG: + call strcpy ("long", str, SZ_FNAME) + case OF_NOLOG: + call strcpy ("nolog", str, SZ_FNAME) + case OF_NOGKI: + call strcpy ("nogki", str, SZ_FNAME) + case OF_TXTONLY: + call strcpy ("txtonly", str, SZ_FNAME) + case OF_STXTONLY: + call strcpy ("stxtonly", str, SZ_FNAME) + default: + call strcpy ("", str, SZ_FNAME) + } +end + + +procedure nam_which (param, str) + +int param #I Param to be tested +char str[SZ_FNAME] #O Param string type + +begin + switch (param) { + case OBJ_ONLY: + call strcpy ("object", str, SZ_FNAME) + case TEMP_ONLY: + call strcpy ("template", str, SZ_FNAME) + case BOTH: + call strcpy ("both", str, SZ_FNAME) + case NONE: + call strcpy ("none", str, SZ_FNAME) + default: + call strcpy ("", str, SZ_FNAME) + } +end diff --git a/noao/rv/rvsumplot.x b/noao/rv/rvsumplot.x new file mode 100644 index 00000000..7a5f97e6 --- /dev/null +++ b/noao/rv/rvsumplot.x @@ -0,0 +1,229 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" + +# RV_BPLOT - Write the split-plot of the spectrum and correlation function +# to the metacode file, or screen. This routine is called when multiple +# Gaussians have been fit. + +procedure rv_bplot (rv, gp) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer + +pointer sp, fmt, vel, shift +int i +real x, y, mx, my, gap, tick +real x1, y1, y2, xp, yp + +real model() +double rv_shift2vel() + +define GAP .015 # Gap size in NDC +define TICK .025 # Gap size in NDC + +begin + if (gp == NULL) + return # No-op + + call smark (sp) # Allocate some space + call salloc (fmt, SZ_LINE, TY_CHAR) + call salloc (vel, SZ_LINE, TY_CHAR) + call salloc (shift, SZ_LINE, TY_CHAR) + + # Clear the screen + call gclear (gp) + + # Draw the three plots to the screen + if (OBJCONT(rv) == YES) { + call split_plot (rv, gp, TOP, OCONT_DATA(rv,1), RV_NPTS(rv), + SUMMARY_PLOT, SPECTRUM_PLOT) + } else { + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), RV_NPTS(rv), + SUMMARY_PLOT, SPECTRUM_PLOT) + } + call split_plot (rv, gp, BOTTOM, WRKPIXY(rv,1), RV_CCFNPTS(rv), + BINARY_PLOT, VCORRELATION_PLOT) + + # Label the velocities + call strcpy ("u=180;h=c;v=b;s=0.5;q=h", Memc[fmt], SZ_LINE) + call gseti (gp, G_WCS, 1) + gap = GAP + tick = TICK + do i = 1, DBL_NSHIFTS(rv) { + call sprintf (Memc[shift], SZ_FNAME, "%d\0") + call pargi (i) + if (RV_DCFLAG(rv) != -1) + x = real (rv_shift2vel(rv,DBL_SHIFT(rv,i))) + else + x = DBL_SHIFT(rv,i) + y = model (DBL_SHIFT(rv,i), DBL_COEFFS(rv,1), 3*DBL_NSHIFTS(rv)+2) + y = DBL_SCALE(rv) * y + (DBL_Y1(rv) + DBL_SLOPE(rv) * + (DBL_SHIFT(rv,i) - DBL_X1(rv))) + + # Draw the tick line + call gctran (gp, x, y, mx, my, 1, 0) + call gctran (gp, mx, my + gap, x1, y1, 0, 1) + call gctran (gp, mx, my + gap + tick, x1, y2, 0, 1) + call gline (gp, x1, y1, x1, y2) + + # Mark the shift number + call gctran (gp, mx, my + gap + tick + gap, x1, y2, 0, 1) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + call gtext (gp, x1, y2, Memc[shift], Memc[fmt]) + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + + # Now print the velocity + call gctran (gp, 0.14, (0.58-(i-1)*0.04), xp, yp, 0, 1) + if (RV_DCFLAG(rv) != -1) { + call sprintf (Memc[vel], SZ_LINE, "Vh[%d] = %.3f +- %.3f\0") + call pargi (i) + call pargr (DBL_VHELIO(rv,i)) + call pargr (DBL_VERR(rv,i)) + } else { + call sprintf (Memc[vel], SZ_LINE, "Shift[%d] = %.3f\0") + call pargi (i) + call pargr (DBL_SHIFT(rv,i)) + } + call gtext (gp, xp, yp, Memc[vel], "s=0.75") + call gflush (gp) + } + + call gflush (gp) + call sfree (sp) +end + + +# RV_EPLOT - Write the split-plot of the spectrum and correlation function +# to the metacode file, or screen. The procedure name is derived from the +# keystroke to call the plot from cursor mode. + +procedure rv_eplot (rv, gp) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer + +int i +real h, xp, yp, step, shift +real x1, x2, y1, y2 + +begin + if (gp == NULL) + return # No-op + + # Do a double star? + if (IS_DBLSTAR(rv) == YES) { + call rv_bplot (rv, gp) + return + } + + # Clear the screen + call gclear (gp) + + # Draw the three plots to the screen + if (OBJCONT(rv) == YES) { + call split_plot (rv, gp, TOP, OCONT_DATA(rv,1), RV_NPTS(rv), + SUMMARY_PLOT, SPECTRUM_PLOT) + } else { + call split_plot (rv, gp, TOP, OBJPIXY(rv,1), RV_NPTS(rv), + SUMMARY_PLOT, SPECTRUM_PLOT) + } + call split_plot (rv, gp, MIDDLE, WRKPIXY(rv,1), + RV_CCFNPTS(rv), SUMMARY_PLOT, CORRELATION_PLOT) + call split_plot (rv, gp, BOTTOM, WRKPIXY(rv,1), + RV_CCFNPTS(rv), SUMMARY_PLOT, VCORRELATION_PLOT) + + # Now get the coords to draw the text + call gseti (gp, G_WCS, 2) + call ggwind (gp, x1, x2, y1, y2) + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + if (RV_ERRCODE(rv) == ERR_FIT) { + call gctran (gp, 0.14, 0.4, xp, yp, 0, 2) + call gtext (gp, xp, yp, "Fit did not converge.", "") + call gflush (gp) + return + } else { + step = (y2 - y1) / 9.0 # For pretty spacings (empirical) + yp = y2 - (step / 2.) + call gctran (gp, 0.14, yp, xp, y2, 0, 2) + do i = 1, 5 { + yp = yp - step + call wpl_text (rv, gp, xp, yp, i) + } + } + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gflush (gp) + + # Lastly, write out the indicator for the FWHM calculation + call gseti (gp, G_PLCOLOR, RV_LINECOLOR(rv)) + if (RV_FITFUNC(rv) != CENTER1D) { + h = RV_FWHM_Y(rv) + if (RV_DCFLAG(rv) == -1) { + if (RV_FITFUNC(rv) != PARABOLA) { + call gline (gp, (COEFF(rv,2)-(0.5*RV_FWHM(rv))), h, + (COEFF(rv,2)+(0.5*RV_FWHM(rv))), h) + } else { + shift = -COEFF(rv,2) / (2.*COEFF(rv,3)) + call gline (gp, (shift-(0.5*RV_FWHM(rv))), h, + (shift+(0.5*RV_FWHM(rv))), h) + } + } else { + call gline (gp, real(RV_VREL(rv)-(0.5*RV_DISP(rv))), h, + real(RV_VREL(rv)+(0.5*RV_DISP(rv))), h) + } + } + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + call gflush (gp) +end + + +# WPL_TEXT - Write the text string to the screen at the specified point. + +procedure wpl_text (rv, gp, xp, yp, lnum) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +real xp, yp #I Position +int lnum #I Line to write + +pointer sp, bp + +begin + # Allocate working space + call smark (sp) + call salloc (bp, SZ_LINE, TY_CHAR) + + switch (lnum) { + case 1: + call sprintf (Memc[bp], SZ_LINE, "Shift = %-.3f") + call pargr (RV_SHIFT(rv)) + case 2: + call sprintf (Memc[bp], SZ_LINE, "Height = %-.3f") + call pargr (RV_HEIGHT(rv)) + case 3: + if (RV_DCFLAG(rv) != -1) { + call sprintf (Memc[bp], SZ_LINE, "VHelio = %-.3f +- %-.3f") + call pargd (RV_VCOR(rv)) + call pargd (RV_ERROR(rv)) + } else { + call sprintf (Memc[bp], SZ_LINE, "VHelio = INDEF") + } + case 4: + call sprintf (Memc[bp], SZ_LINE, "Width = %-.3f %s") + if (RV_DCFLAG(rv) != -1) { + call pargr (RV_DISP(rv)) + call pargstr ("") + } else { + call pargr (RV_FWHM(rv)) + call pargstr ("pix") + } + case 5: + call sprintf (Memc[bp], SZ_LINE, "R = %-.3f") + call pargr (RV_R(rv)) + } + + # Write the text + call gtext (gp, xp, yp, Memc[bp], "") + + call sfree (sp) +end diff --git a/noao/rv/rvutil.x b/noao/rv/rvutil.x new file mode 100644 index 00000000..c36097b8 --- /dev/null +++ b/noao/rv/rvutil.x @@ -0,0 +1,274 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" +include "rvkeywords.h" +include "rvsample.h" + +# RVUTIL.X -- Catch-all file that contains various and sundry utility routines +# used throughout the package. + + +# DEX - Raise 'cv' to a power of ten (10) + +double procedure dex (cv) + +real cv + +double ln10, dx + +begin + ln10 = 2.30258509299404d0 + if ((cv*ln10) > 512) { + call rv_errmsg ("dex(): cv = %f") + call pargr (cv) + call flush (STDERR) + call error (0, "Floating overflow would have been tripped.") + } + dx = exp (cv * ln10) + + return (dx) +end + + +# RV_AVGPIX - Find average pixel value in an array + +real procedure rv_avgpix (data, npts) + +real data[npts] #I data array +int npts #I No. points in array + +real avg +double sum +int i + +begin + sum = 0.0 + do i = 1, npts + sum = sum + double (data[i]) + + avg = real (sum / double (npts)) + + return ( avg ) +end + + +# RV_CUT - Mark a regions of the spectrum to be used in the correlation. +# Appends to the current regions string + +procedure rv_cut (rv, x, sx, ex) + +pointer rv #I RV struct pointer +real x #I Current cursor x position +real sx #O Start x position +real ex #O End x position + +double dex() +real sregion, eregion, yp + +begin + sregion = x # get endpoints + call rv_getpts (rv, eregion, yp, 1) + if (RV_PIXCORR(rv) == NO && RV_DCFLAG(rv) != -1) { + call rv_fixx (sregion, eregion, real(dex(RV_GLOB_W1(rv))), + real(dex(RV_GLOB_W2(rv)))) + } else { + call rv_fixx (sregion, eregion, RV_GLOB_W1(rv), RV_GLOB_W2(rv)) + } + + sx = sregion + ex = eregion +end + + +# RV_FILL_BLANKS - Given an input string, substitue blanks with an underscore. + +procedure rv_fill_blanks (in, out, maxch) + +char in[maxch], out[maxch] +int maxch +int i + +begin + i = 1 + while (in[i] != EOS && i != maxch) { + if (in[i] == ' ') + out[i] = '_' + else + out[i] = in[i] + i = i + 1 + } + out[i] = EOS +end + + +# RV_FIXX - Check for bounds on x's. + +procedure rv_fixx (x1, x2, lx1, rx2) + +real x1 #U 'left' x cursor +real x2 #U 'right' x cursor +real lx1 #I min allowed x point +real rx2 #I max allowed x point + +real temp + +begin + if (x2 < x1) { # Swap 'em + temp = min (x2, rx2) + x2 = max (x1, lx1) + x1 = temp + } +end + + +# RV_GETPTS - Read cursor to get another point. + +procedure rv_getpts (rv, x, y, owcs) + +pointer rv #I RV struct pointer +real x, y #I Cursor coords +int owcs #I Output wcs of coords + +int wcs, key, stat +char command[SZ_FNAME] +int clgcur() + +begin + call printf ("again: ") + stat = clgcur ("cursor", x, y, wcs, key, command, SZ_LINE) + if (owcs != wcs) + call gctran (RV_GP(rv), x, y, x, y, wcs, owcs) + call printf (" \n") + +end + + +# RV_GETSHIFT - Find an extreme in the data array of type indicated and +# return the index in the array. + +int procedure rv_getshift (data, npts, type) + +real data[npts] #I data array +int npts #I No. points in array +int type #I type of extreme to find + +int i, imax, imin +real max, min + +begin + if (type == MAXIMUM) { + max = data[1] + imax = 1 + do i = 2,npts { + if (data[i] > max) { + max = data[i] + imax = i + } + } + return (imax) + + } else { + min = data[1] + imin = 1 + do i = 2,npts { + if (data[i] < min) { + min = data[i] + imin = i + } + } + return (imin) + } +end + + +# RV_MAXPIX - Find maximum pixel value in an array + +real procedure rv_maxpix (data, npts) + +real data[npts] #I data array +int npts #I No. points in array + +real max +int i + +begin + max = data[1] + do i = 2,npts + if (data[i] > max) + max = data[i] + + return (max) +end + + +# RV_MINPIX - Find minimum pixel value in an array + +real procedure rv_minpix (data, npts) + +real data[npts] #I data array +int npts #I No. points in array + +real min +int i + +begin + min = data[1] + do i = 2,npts + if (data[i] < min) + min = data[i] + + return (min) +end + + +# RV_PAUSE - Print a string and await any key for an action. + +procedure rv_pause (str) +char str[ARB] + +real x, y +int wcs, key, stat +char command[SZ_FNAME] +int clgcur() + +begin + call printf ("%s") + call pargstr (str) + call flush (STDOUT) + stat = clgcur ("cursor", x, y, wcs, key, command, SZ_FNAME) + + if ('I' == key) + call error (0, "Quitting") + + return +end + + +# RV_PRSHIFT - Use the cursor to print the difference in pixels. + +procedure rv_prshift (rv, xpos) + +pointer rv #I RV struct pointer +real xpos #I 1st x position + +real xpos2, y, shift, pix_shift +double rv_shift2vel() + +begin + call rv_getpts(rv, xpos2, y, 1) + + shift = xpos2 - xpos + pix_shift = (log10(xpos2) - log10(xpos)) / RV_OWPC(rv) + call rv_mode_prompt (rv) + if (RV_DCFLAG(rv) != -1) { + call printf (" Difference = %.2f Km/sec (~%d pix) (~%.3f A)\n") + call pargd (rv_shift2vel(rv,pix_shift)) + call pargi (int(pix_shift)) + call pargr (shift) + + } else { + call printf (" Difference = %.2f pixels.\n") + call pargr (pix_shift) + } +end diff --git a/noao/rv/rvvfit.x b/noao/rv/rvvfit.x new file mode 100644 index 00000000..d900d9b3 --- /dev/null +++ b/noao/rv/rvvfit.x @@ -0,0 +1,408 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" + +# RV_VERBOSE_FIT - Write a verbose description of the fit and correlation. + +procedure rv_verbose_fit (rv, ofd) + +pointer rv #I RV struct pointer +int ofd #I Output file descriptor + +pointer sp, fname +int fd +int open() + +errchk mktemp, open + +begin + if (ofd != STDOUT) { + if (RV_VERBOSE(rv) == OF_TXTONLY || + RV_VERBOSE(rv) == OF_NOLOG || + RV_VERBOSE(rv) == OF_STXTONLY) { + return + } + } + + # Allocate some space + call smark (sp) + call salloc (fname, SZ_PATHNAME, TY_CHAR) + + # Make a temporary file name and open it up + if (ofd == STDOUT) { + call mktemp ("uparm$tmp", Memc[fname], SZ_PATHNAME) + iferr (fd = open (Memc[fname], NEW_FILE, TEXT_FILE)) + call error (0, "Error opening temp file.") + + call wrt_fit (rv, fd) # Start printing it out + call close (fd) # Close the file + + # Page the file + call gpagefile (RV_GP(rv), Memc[fname], "") + call delete (Memc[fname]) # Clean up + + } else if (ofd != NULL) { + call wrt_fit (rv, ofd) + call fprintf (ofd, "\f") + } + + call sfree (sp) +end + + +# RV_MEAN_RESID - Compute the median and sigma of the residuals of the fit. + +procedure rv_mean_resid (rv, mean, sigma) + +pointer rv #I RV struct pointer +real mean #O Mean of residuals +real sigma #O Sigma of residuals + +pointer sp, resx, resy +real x, y +int npts, i + +real model() + +begin + if (RV_FITDONE(rv) == NO) { + if (RV_INTERACTIVE(rv) == YES) + call rv_errmsg ("Error: No fit yet done to the data.") + return + } + if (RV_FITFUNC(rv) == SINC) { + mean = 0.0 + sigma = 0.0 + return + } + npts = RV_IEND(rv) - RV_ISTART(rv) + 1 + + call smark (sp) + call salloc (resx, npts, TY_REAL) + call salloc (resy, npts, TY_REAL) + + # Compute the residuals or ratio of the fit + x = WRKPIXX(rv,RV_ISTART(rv)) + do i = 1, npts { + Memr[resx+i-1] = x + if (IS_DBLSTAR(rv) == NO) { + switch (RV_FITFUNC(rv)) { + case GAUSSIAN: + call cgauss1d (x, 1, COEFF(rv,1), 4, y) + case LORENTZIAN: + call lorentz (x, 1, COEFF(rv,1), 4, y) + case PARABOLA: + call polyfit (x, 1, COEFF(rv,1), 3, y) + } + } else { + y = model (x, DBL_COEFFS(rv,1), 3*DBL_NSHIFTS(rv)+2) + y = DBL_SCALE(rv) * y + + (DBL_Y1(rv)+DBL_SLOPE(rv)*(x-DBL_X1(rv))) + } + + Memr[resy+i-1] = WRKPIXY(rv,i+RV_ISTART(rv)-1) - y + x = x + 1. + } + call aavgr (Memr[resy], npts, mean, sigma) + + call sfree (sp) +end + + +# WRT_FIT - Write a verbose description of the fit and correlation + +procedure wrt_fit (rv, fd) + +pointer rv #I RV struct pointer +int fd #I Tmp file descriptor + +pointer sp, ffunc, orange, rrange, system_id, title +bool itob() + +include "fitcom.com" + +begin + # Allocate some space + call smark (sp) + call salloc (ffunc, SZ_FNAME, TY_CHAR) + call salloc (orange, SZ_LINE, TY_CHAR) + call salloc (rrange, SZ_LINE, TY_CHAR) + call salloc (system_id, SZ_LINE, TY_CHAR) + call salloc (title, 2*SZ_LINE, TY_CHAR) + + # Get those string valued parameters + call rv_make_range_string (RV_OSAMPLE(rv), Memc[orange]) + call rv_make_range_string (RV_RSAMPLE(rv), Memc[rrange]) + if (IS_DBLSTAR(rv) == NO) + call nam_fitfunc (rv, Memc[ffunc]) + else + call strcpy ("deblend", Memc[ffunc], SZ_FNAME) + call sysid (Memc[system_id], SZ_LINE) + + call sprintf (Memc[title], 2*SZ_LINE, "\n%14t%s\n\t %s\n\n") + call pargstr ( + "Description of Fit to CCF Peak and Cross-Correlation") + call pargstr (Memc[system_id]) + call fprintf (fd, Memc[title]) + + # Write out the image stuff + #call fprintf (fd, "Obj = `%.24s[%.4d]'%40tstar = `%.24s'\n") + call fprintf (fd, "Obj = `%24s[%.4d]'%40tstar = `%.24s'\n") + call pargstr (IMAGE(rv)) + call pargi (RV_APNUM(rv)) + call pargstr (OBJNAME(rv)) + #call fprintf (fd, "Temp = `%.24s[%.4d]'%40tstar = `%.24s'\n") + call fprintf (fd, "Temp = `%24s[%.4d]'%40tstar = `%.24s'\n") + call pargstr (RIMAGE(rv)) + call pargi (RV_APNUM(rv)) + call pargstr (TEMPNAME(rv)) + call fprintf (fd, "Deltav = %.3f Km/sec%40tTempvel = %.3f Km/sec\n\n") + call pargr (RV_DELTAV(rv)) + call pargr (TEMPVEL(rv,RV_TEMPNUM(rv))) + + # Now do the fitting parameters + call fprintf (fd, "Fit Parameters:\n") + call fprintf (fd, "%10tFunction = `%s'%46tWidth = %g\n") + call pargstr (Memc[ffunc]) + call pargr (RV_FITWIDTH(rv)) + call fprintf (fd, "%12tHeight = %g%43tMinwidth = %g\n") + call pargr (RV_FITHGHT(rv)) + call pargr (RV_MINWIDTH(rv)) + call fprintf (fd, "%14tPeak = %g%43tMaxwidth = %g\n") + call pargb (itob(RV_PEAK(rv))) + call pargr (RV_MAXWIDTH(rv)) + call fprintf (fd, "%11tWeights = %b%41tBackground = %g\n") + call pargr (RV_WEIGHTS(rv)) + call pargr (RV_BACKGROUND(rv)) + call fprintf (fd, "%9tWincenter = %g%45tWindow = %d\n") + call pargr (RV_WINCENPAR(rv)) + call pargr (RV_WINPAR(rv)) + + # Write out some more fitting information + call fprintf (fd, "\n\tNumber of points fit = %d\n") + call pargi (nfit) + if (RV_FITFUNC(rv) != SINC && RV_FITFUNC(rv) != CENTER1D) { + call fprintf (fd, "\tNumber of iterations = %d\n") + call pargi (niter) + call fprintf (fd, "\tNumber of coeffs fit = 1 - %d\n") + call pargi (nfitpars) + call fprintf (fd, "\tChi Squared of fit = %.4g\n") + call pargr (chisqr) + call fprintf (fd, "\tFit Coefficients:\n") + call wrt_coeffs (rv, fd) + } + + call rv_mean_resid (rv, mresid, sresid) + call fprintf (fd, "\n\tMean Residual = %f\n\tSigma of Residuals = %f\n") + call pargr (mresid) + call pargr (sresid) + call fprintf (fd, "\tMaximum of cross-correlation is in bin = %d.\n") + call pargi (binshift) + call fprintf (fd, "\tVariance of cross-correlation = %g\n") + call pargr (ccfvar) + call fprintf (fd, "\tHJD of observation = %.5f %50tMJD = %.5f\n") + if (RV_DCFLAG(rv) == -1) { + call pargd (INDEFD) + call pargd (INDEFD) + } else { + call pargd (RV_HJD(rv)) + call pargd (RV_MJD_OBS(rv)) + } + call fprintf (fd, "\tObject sample used in correlation = `%s'\n") + call pargstr (Memc[orange]) + call fprintf (fd, "\tTemplate sample used in correlation = `%s'\n") + call pargstr (Memc[rrange]) + call fprintf (fd, "\tTonry&Davis R value = %g\n\n") + call pargr (RV_R(rv)) + + # Now print out some velocity information + call fprintf (fd, "Velocity Results:\n") + call wrt_velocity (rv, fd) + + # Lastly print out any error comments + call fprintf (fd, "\nComments:\n") + if (RV_ERRCOMMENTS(rv) != NULL) { + call fprintf (fd, "%s\n") + call pargstr (ERRCOMMENTS(rv)) + } + call fprintf (fd, "\n") + + # Clean up + call flush (fd) + call sfree (sp) +end + + +# WRT_VELOCITY - Write out the velocity information. + +procedure wrt_velocity (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I Output file descriptor + +int i +double rv_shift2vel() + +begin + if (IS_DBLSTAR(rv) == NO) { + call fprintf (fd, "\tShift of peak = %.4f pixels\n") + call pargr (RV_SHIFT(rv)) + call fprintf (fd, "\tCorrelation height = %.3f\n") + call pargr (RV_HEIGHT(rv)) + call fprintf (fd, "\tFWHM of peak = %g Km/sec\t(=%g pixels)\n\n") + if (RV_DCFLAG(rv) == -1 || IS_INDEF(RV_FWHM(rv))) + call pargr (INDEF) + else + call pargr (RV_FWHM(rv)*RV_DELTAV(rv)) + call pargr (RV_FWHM(rv)) + call fprintf (fd, "\tVelocity computed from shift = %.4f Km/sec\n") + call pargr (RV_VREL(rv)) + call fprintf (fd, "\tObserved velocity = %.4f Km/sec\n") + call pargd (RV_VOBS(rv)) + call fprintf (fd,"\tHeliocentric velocity = %.4f +/- %.3f Km/sec\n") + call pargd (RV_VCOR(rv)) + if (RV_DCFLAG(rv) != -1) + call pargd (RV_ERROR(rv)) + else + call pargd (INDEFD) + } else { + call fprintf (fd, "\tShift of peak[1] = %.4f pixels\n") + call pargr (DBL_SHIFT(rv,1)) + do i = 2, DBL_NSHIFTS(rv) { + call fprintf (fd, "%22t[%d] = %.4f pixels\n") + call pargi (i) + call pargr (DBL_SHIFT(rv,i)) + } + call fprintf (fd, "\tCorrelation height[1] = %.3f\n") + call pargr (DBL_HEIGHT(rv,1)) + do i = 2, DBL_NSHIFTS(rv) { + call fprintf (fd, "%27t[%d] = %.3f\n") + call pargi (i) + call pargr (DBL_HEIGHT(rv,i)) + } + call fprintf (fd, "\tFWHM of peak[1] = %f Km/s\n") + call pargr (DBL_FWHM(rv,1)) + do i = 2, DBL_NSHIFTS(rv) { + call fprintf (fd, "%21t[%d] = %f Km/s\n") + call pargi (i) + call pargr (DBL_FWHM(rv,i)) + } + + call fprintf (fd, + "\n\tVelocity computed from shift[1] = %.4f Km/s\n") + call pargd (rv_shift2vel(rv,DBL_SHIFT(rv,1))) + do i = 2, DBL_NSHIFTS(rv) { + call fprintf (fd, "%37t[%d] = %.4f Km/s\n") + call pargi (i) + call pargd (rv_shift2vel(rv,DBL_SHIFT(rv,i))) + } + call fprintf (fd, "\tObserved velocity[1] = %.4f Km/s\n") + call pargr (DBL_VOBS(rv,1)) + do i = 2, DBL_NSHIFTS(rv) { + call fprintf (fd, "%26t[%d] = %.4f Km/s\n") + call pargi (i) + call pargr (DBL_VOBS(rv,i)) + } + call fprintf(fd,"\tHeliocentric velocity[1] = %.4f +/- %.3f Km/s\n") + call pargr (DBL_VHELIO(rv,1)) + call pargr (DBL_VERR(rv,1)) + do i = 2, DBL_NSHIFTS(rv) { + call fprintf (fd, "%30t[%d] = %.4f +/- %.3f Km/s\n") + call pargi (i) + call pargr (DBL_VHELIO(rv,i)) + call pargr (DBL_VERR(rv,i)) + } + } + call flush (fd) +end + + +# WRT_COEFFS - Write the fit coefficients and errors + +procedure wrt_coeffs (rv, fd) + +pointer rv #I RV struct pointer +int fd #I File descriptor + +begin + if (fd == NULL) + return + + if (IS_DBLSTAR(rv) == YES) { + call wrt_debl_coeffs (rv, fd) + + } else if (RV_FITFUNC(rv) == GAUSSIAN || RV_FITFUNC(rv) == LORENTZIAN) { + call fprintf (fd, "\t\tc[1] = %8.4f +/- %6.4f%65t# Amplitude\n") + call pargr (COEFF(rv,1)) + call pargr (ECOEFF(rv,1)) + call fprintf (fd, "\t\tc[2] = %8.4f +/- %6.4f%65t# Center\n") + call pargr (COEFF(rv,2)) + call pargr (ECOEFF(rv,2)) + if (RV_FITFUNC(rv) == GAUSSIAN) + call fprintf (fd, "\t\tc[3] = %8.4f +/- %6.4f%65t# Sigma^2\n") + else + call fprintf (fd, "\t\tc[3] = %8.4f +/- %6.4f%65t# FWHM\n") + call pargr (COEFF(rv,3)) + call pargr (ECOEFF(rv,3)) + if (IS_INDEF(RV_BACKGROUND(rv))) { + call fprintf (fd, + "\t\tc[4] = %8.4f +/- %6.4f%65t# Background\n") + call pargr (COEFF(rv,4)) + call pargr (ECOEFF(rv,4)) + } else { + call fprintf (fd, + "\t\tc[4] = %8.4f (fixed)%65t# Background\n") + call pargr (RV_BACKGROUND(rv)) + } + + } else if (RV_FITFUNC(rv) == PARABOLA) { + call fprintf (fd, "\t\tc[1] = %8.4f +/- %6.4f\n") + call pargr (COEFF(rv,1)) + call pargr (ECOEFF(rv,1)) + call fprintf (fd, "\t\tc[2] = %8.4f +/- %6.4f\n") + call pargr (COEFF(rv,2)) + call pargr (ECOEFF(rv,2)) + call fprintf (fd, "\t\tc[3] = %8.4f +/- %6.4f\n") + call pargr (COEFF(rv,3)) + call pargr (ECOEFF(rv,3)) + } + call flush (fd) +end + + +# WRT_DEBL_COEFFS - Write the fit coefficients and errors for a deblended fit. + +procedure wrt_debl_coeffs (rv, fd) + +pointer rv #I RV struct pointer +int fd #I File descriptor + +int i + +begin + if (fd == NULL) + return + + call fprintf (fd, "\t\tc[1] = %8.4f %45t# First line position\n") + call pargr (DBL_COEFFS(rv,1)) + call fprintf (fd, "\t\tc[2] = %8.4f %45t# First line sigma\n") + call pargr (DBL_COEFFS(rv,2)) + do i = 1, DBL_NSHIFTS(rv) { + call fprintf (fd, "\t\tc[%d] = %8.4f %45t# Line #%d Amplitude\n") + call pargi (3*i) + call pargr (DBL_COEFFS(rv,3*i)) + call pargi (i) + call fprintf (fd, + "\t\tc[%d] = %8.4f %45t# Line #%d Center (relative)\n") + call pargi (3*i+1) + call pargr (DBL_COEFFS(rv,3*i+1)) + call pargi (i) + call fprintf (fd, + "\t\tc[%d] = %8.4f %45t# Line #%d Sigma (relative)\n") + call pargi (3*i+2) + call pargr (DBL_COEFFS(rv,3*i+2)) + call pargi (i) + } + call flush (fd) +end diff --git a/noao/rv/rvwparam.x b/noao/rv/rvwparam.x new file mode 100644 index 00000000..15b1f85d --- /dev/null +++ b/noao/rv/rvwparam.x @@ -0,0 +1,127 @@ +include <time.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" +include "rvcomdef.h" + +define SZ_DATEBUF 16 + +# RV_PARAM -- Procedure to write the rv parameters to a text file. + +procedure rv_param (rv, out, task) + +pointer rv # RV struct pointer +pointer out # database descriptor +char task[ARB] # task name + +int nchars +pointer sp, outstr, date, time +int envfind(), gstrcpy() + +begin + if (out == NULL) + return + + # Allocate working space. + call smark (sp) + call salloc (outstr, SZ_LINE, TY_CHAR) + call salloc (date, SZ_DATEBUF, TY_CHAR) + call salloc (time, SZ_DATEBUF, TY_CHAR) + + # Write the id. + nchars = envfind ("version", Memc[outstr], SZ_LINE) + if (nchars <= 0) + nchars = gstrcpy ("NOAO/IRAF", Memc[outstr], SZ_LINE) + call rv_sparam (out, "IRAF", Memc[outstr], "version", + "current version of IRAF") + nchars = envfind ("userid", Memc[outstr], SZ_LINE) + call rv_sparam (out, "USER", Memc[outstr], "name", "user id") + call gethost (Memc[outstr], SZ_LINE) + call rv_sparam (out, "HOST", Memc[outstr], "computer", + "IRAF host machine") + call rv_date (Memc[date], Memc[time], SZ_DATEBUF) + call rv_sparam (out, "DATE", Memc[date], "yyyy-mm-dd", "date") + call rv_sparam (out, "TIME", Memc[time], "hh:mm:ss", "time") + call rv_sparam (out, "PACKAGE", "rv", "name", + "name of IRAF package") + call rv_sparam (out, "TASK", task, "name", "name of rv task") + + call sfree (sp) +end + + +# RV_DATE -- Procedure to produce the date and time strings for RV output files. + +procedure rv_date (date, time, maxch) + +char date[SZ_LINE] # the date string +char time[SZ_LINE] # the time string +int maxch # the maximum number of character in the string + +int tm[LEN_TMSTRUCT] +long clktime() + +begin + call brktime (clktime (long(0)), tm) + call sprintf (date, maxch, "%04d-%02d-%02d") + call pargi (TM_YEAR(tm)) + call pargi (TM_MONTH(tm)) + call pargi (TM_MDAY(tm)) + call sprintf (time, maxch, "%02d:%02d:%02d") + call pargi (TM_HOUR(tm)) + call pargi (TM_MIN(tm)) + call pargi (TM_SEC(tm)) +end + + +# RV_IPARAM -- Procedure to encode an rv integer parameter. + +procedure rv_iparam (out, keyword, value, units, comments) + +pointer out # output file descriptor +char keyword[ARB] # keyword string +int value # parameter value +char units[ARB] # units string +char comments[ARB] # comment string + +begin + if (out == NULL) + return + + call strupr (keyword) + call fprintf (out, "#K%4t%-10.10s%14t = %17t%-15d\n") + call pargstr (keyword) + call pargi (value) + call pargstr (units) +end + + +# RV_SPARAM -- Procedure to encode an rv string parameter. + +procedure rv_sparam (out, keyword, value, units, comments) + +pointer out # output file descriptor +char keyword[ARB] # keyword string +char value[ARB] # parameter value +char units[ARB] # units string +char comments[ARB] # comment string + +bool streq() + +begin + if (out == NULL) + return + + call strupr (keyword) + if (streq(keyword,"REGIONS") || + streq(keyword,"APNUM")) { + call fprintf (out, "#K%4t%-10.10s%14t = %17t%-s\n") + call pargstr (keyword) + call pargstr (value) + } else { + call fprintf (out, "#K%4t%-10.10s%14t = %17t%-30.30s%48t%-10.10s\n") + call pargstr (keyword) + call pargstr (value) + call pargstr (units) + } +end diff --git a/noao/rv/rvwrite.x b/noao/rv/rvwrite.x new file mode 100644 index 00000000..4d07af4f --- /dev/null +++ b/noao/rv/rvwrite.x @@ -0,0 +1,632 @@ +include <imhdr.h> +include "rvpackage.h" +include "rvflags.h" +include "rvkeywords.h" +include "rvsample.h" +include "rvcont.h" + +# RV_WRITE - Write results to logfile and/or header. + +procedure rv_write (rv, record) + +pointer rv #I RV struct pointer +int record #I Record number being written + +pointer sp, fd, tasknm, buf + +begin + fd = RV_TXFD(rv) + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + call salloc (tasknm, SZ_FNAME, TY_CHAR) + + # Update the image header if set + if (RV_IMUPDATE(rv) == YES) + call rv_imupdate (rv) + + # write long explanatory header + if (record <= 0) { + call rv_param (rv, fd, "fxcor") + call rv_tempcodes (rv, fd) + call rv_prdeltav (rv, fd) + call fprintf (fd, "# \n") + call rv_hdr (rv, fd) + } + + # Update dispersion and the sample regions if they were modified. + if (SR_MODIFY(RV_OSAMPLE(rv)) == YES) { + call rv_make_range_string (RV_OSAMPLE(rv), Memc[buf]) + call rv_sparam (RV_TXFD(rv), "osample", Memc[buf], "", "") + SR_MODIFY(RV_OSAMPLE(rv)) = NO + } + if (SR_MODIFY(RV_RSAMPLE(rv)) == YES) { + call rv_make_range_string (RV_RSAMPLE(rv), Memc[buf]) + call rv_sparam (RV_TXFD(rv), "rsample", Memc[buf], "", "") + SR_MODIFY(RV_RSAMPLE(rv)) = NO + } + + if (RV_VERBOSE(rv) == OF_SHORT || RV_VERBOSE(rv) == OF_STXTONLY) + call rv_write_short (rv, fd) + else + call rv_write_long (rv, fd) + + call sfree (sp) +end + +# Define the parameter keyword strings in Km/s units. + +define RV_NSTR1S "#N OBJECT%13tIMAGE%24tREF%29tHJD%40tAP%44tSHIFT%53tFWHM%62tVHELIO%72tVERR\n" +define RV_USTR1S "#U name%13timage%29tdays%44tpixel%53t %62tkm/s%72tkm/s\n" +define RV_WSTR1S "%-11.11s%13t%-10.10s%24t%.2s%29t%-10.5f%40t%-3d%44t%-7.3f%53t%-7.2f%62t%-9.4f%72t%-7.3f\n" + +define RV_NSTR1V "#N%4tOBJECT%18tIMAGE%28tREF%34tHJD%44tAP%50tCODES%60tSHIFT%68tHGHT%73tFWHM%81tTDR%88tVOBS%98tVREL%109tVHELIO%120tVERR\n" +define RV_USTR1V "#U%4tname%18timage%34tdays%50tcfr/fun%60tpixel%73t %88tkm/s%98tkm/s%109tkm/s%120tkm/s\n" +define RV_WSTR1V "%-15.15s %-10s %.2s %-11.5f %-3d %-7.7s %-7.3f %-4.2f %-7.2f %-6.2f %-9.4f %-9.4f %-9.4f %-7.3f\n" + +# Now define the parameter keyword strings in terms of redshift Z values. + +define RV_NSTR1SZ "#N OBJECT%13tIMAGE%24tREF%28tHJD%40tAP%44tSHIFT%53tFWHM%62tZHELIO%72tVERR\n" +define RV_USTR1SZ "#U name%13timage%28tdays%44tpixel%53t %62tz%72tkm/s\n" +define RV_WSTR1SZ "%-11.11s%13t%-10.10s%24t%.2s%28t%-10.5f%40t%-3d%44t%-7.3f%53t%-7.2f%62t%-7.6f%72t%-7.3f\n" + +define RV_NSTR1VZ "#N%4tOBJECT%18tIMAGE%28tREF%34tHJD%44tAP%50tCODES%60tSHIFT%68tHGHT%73tFWHM%81tTDR%88tZOBS%98tZREL%109tZHELIO%120tVERR\n" +define RV_USTR1VZ "#U%4tname%18timage%34tdays%50tcfr/fun%60tpixel%73t %88tz%98tz%109tz%120tkm/s\n" +define RV_WSTR1VZ "%-15.15s %-10s %.2s %-11.5f %-3d %-7.7s %-7.3f %-4.2f %-7.2f %-6.2f %-7.6f %-7.6f %-7.6f %-7.3f\n" + + + +# RV_WRITELN - Write out a line to the status line. + +procedure rv_writeln (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I File descriptor + +begin + if (fd == NULL) + return + + # Check error conditions + if (RV_ERRCODE(rv) == ERR_FIT) { + call fprintf (fd, "Fit did not converge.\n") + return + } + + if (RV_PRINTZ(rv) == ERR) # bad velocity computation + RV_PRINTZ(rv) = NO + + # Write the status line output + if ((mod(RV_STATLINE(rv),2) == 0 || RV_NEWXCOR(rv) == YES) && + RV_DCFLAG(rv) != -1) { + if (RV_PRINTZ(rv) == NO) { + call fprintf (fd, + "HJD=%9.4f FWHM=%.2f Vr=%.3f Vo=%.3f Vh=%.3f +/- %.3f\n") + } else { + call fprintf (fd, + "HJD=%9.4f FWHM=%.2f Zr=%.5f Zo=%.5f Zh=%.5f +/- %.3f\n") + } + if (RV_HJD(rv) > 0.0) + call pargd (mod(RV_HJD(rv),double(10000.0))) + else + call pargr (INDEF) + call pargr (RV_DISP(rv)) + if (RV_PRINTZ(rv) == NO) { + call pargr (RV_VREL(rv)) + call pargd (RV_VOBS(rv)) + call pargd (RV_VCOR(rv)) + } else { + if (IS_INDEFD(RV_VREL(rv))) + call pargd (INDEFD) + else + call pargd (RV_VREL(rv)/C) + if (IS_INDEFD(RV_VOBS(rv))) + call pargd (INDEFD) + else + call pargd (RV_VOBS(rv)/C) + if (IS_INDEFD(RV_VCOR(rv))) + call pargd (INDEFD) + else + call pargd (RV_VCOR(rv)/C) + } + call pargd (RV_ERROR(rv)) + } else { + call fprintf (fd, + "Shift=%.5g +/- %.3g pixels CCF Height=%.3g FWHM = %.3g") + call pargr (RV_SHIFT(rv)) + call pargr (RV_SIGMA(rv)) + call pargr (RV_HEIGHT(rv)) + call pargr (RV_FWHM(rv)) + } + + call flush (fd) + RV_ERRCODE(rv) = OK +end + + +# RV_WRITE_SHORT - Write out a line to the logfile or the screen. + +procedure rv_write_short (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I File descriptor + +int i, nshifts +real wpc +char tc[3] + +data wpc /INDEF/ + +begin + if (fd == NULL) + return + if (RV_PRINTZ(rv) == ERR) # bad velocity computation + RV_PRINTZ(rv) = NO + + if (IS_INDEF(wpc)) # update dispersion + wpc = RV_OWPC(rv) + else if (wpc != RV_OWPC(rv)) { + call rv_prdeltav (rv, fd) + wpc = RV_OWPC(rv) + } else + wpc = RV_OWPC(rv) + + if (IS_DBLSTAR(rv) == YES) { + nshifts = DBL_NSHIFTS(rv) + do i = 1, nshifts { + call nam_tempcode (RV_TEMPNUM(rv), tc) + if (RV_PRINTZ(rv) == NO) + call fprintf (fd, RV_WSTR1S) + else + call fprintf (fd, RV_WSTR1SZ) + call pargstr (OBJNAME(rv)) + call pargstr (IMAGE(rv)) + #call pargi (RV_TEMPCODE(rv)) + call pargstr (tc) + if (!IS_INDEF(DBL_VHELIO(rv,i)) && RV_HJD(rv) > 0) + call pargd (mod(RV_HJD(rv),double(10000.0))) + else + call pargr (INDEF) + call pargi (RV_APNUM(rv)) + call pargr (DBL_SHIFT(rv,i)) + call pargr (DBL_FWHM(rv,i)) + if (RV_DCFLAG(rv) != -1) { + if (RV_PRINTZ(rv) == NO) + call pargr (DBL_VHELIO(rv,i)) + else { + if (IS_INDEFD(DBL_VHELIO(rv,i))) + call pargd (INDEFD) + else + call pargd (DBL_VHELIO(rv,i)/C) + } + } else + call pargr (INDEFR) + call pargr (DBL_VERR(rv,i)) + } + } else { + call nam_tempcode (RV_TEMPNUM(rv), tc) + if (RV_PRINTZ(rv) == NO) + call fprintf (fd, RV_WSTR1S) + else + call fprintf (fd, RV_WSTR1SZ) + call pargstr (OBJNAME(rv)) + call pargstr (IMAGE(rv)) + #call pargi (RV_TEMPCODE(rv)) + call pargstr (tc) + if (!IS_INDEFD(RV_VCOR(rv)) && RV_ERRCODE(rv) == OK && + RV_HJD(rv) > 0.) + call pargd (mod(RV_HJD(rv),double(10000.0))) + else + call pargr (INDEF) + call pargi (RV_APNUM(rv)) + if (RV_ERRCODE(rv) == OK) { + call pargr (RV_SHIFT(rv)) + if (!IS_INDEFR(RV_DISP(rv))) + call pargr (RV_DISP(rv)) + else + call pargr (RV_FWHM(rv)) + if (RV_PRINTZ(rv) == NO) + call pargd (RV_VCOR(rv)) + else { + if (IS_INDEFD(RV_VCOR(rv))) + call pargd (INDEFD) + else + call pargd (RV_VCOR(rv)/C) + } + call pargd (RV_ERROR(rv)) + } else { + call pargr (INDEF) + call pargr (INDEF) + call pargr (INDEF) + call pargr (INDEF) + } + } + + call flush (fd) +end + + +# RV_WRITE_LONG - Write the verbose output line + +procedure rv_write_long (rv, fd) + +pointer rv #I RV struct pointer +int fd #I File descriptor + +pointer sp, cp +int i, nshifts +double vrel, rv_shift2vel() +real wpc +char tc[3] + +data wpc /INDEF/ + +begin + if (fd == NULL) + return + if (RV_PRINTZ(rv) == ERR) # bad velocity computation + RV_PRINTZ(rv) = NO + + call smark (sp) + call salloc (cp, SZ_FNAME, TY_CHAR) + + # First encode some stuff for output + call rv_codes (rv, Memc[cp], SZ_FNAME) + + if (IS_INDEF(wpc)) # update dispersion + wpc = RV_OWPC(rv) + else if (wpc != RV_OWPC(rv)) { + call rv_prdeltav (rv, fd) + wpc = RV_OWPC(rv) + } else + wpc = RV_OWPC(rv) + + if (IS_DBLSTAR(rv) == YES) { + nshifts = DBL_NSHIFTS(rv) + do i = 1, nshifts { + call nam_tempcode (RV_TEMPNUM(rv), tc) + if (RV_PRINTZ(rv) == NO) + call fprintf (fd, RV_WSTR1V) + else + call fprintf (fd, RV_WSTR1VZ) + call pargstr (OBJNAME(rv)) + call pargstr (IMAGE(rv)) + call pargstr (tc) + if (!IS_INDEF(DBL_VHELIO(rv,i)) && RV_HJD(rv) > 0.0) + call pargd (mod(RV_HJD(rv),double(10000.0))) + else + call pargr (INDEF) + call pargi (RV_APNUM(rv)) + call pargstr (Memc[cp]) + call pargr (DBL_SHIFT(rv,i)) + call pargr (DBL_HEIGHT(rv,i)) + call pargr (DBL_FWHM(rv,i)) + call pargr (DBL_R(rv,i)) + if (RV_DCFLAG(rv) != -1) { + if (RV_PRINTZ(rv) == NO) { + call pargr (DBL_VOBS(rv,i)) + call pargd (rv_shift2vel(rv,DBL_SHIFT(rv,i))) + call pargr (DBL_VHELIO(rv,i)) + } else { + if (IS_INDEFD(DBL_VOBS(rv,i))) + call pargd (INDEFD) + else + call pargd (DBL_VOBS(rv,i)/C) + vrel = rv_shift2vel (rv,DBL_SHIFT(rv,i)) / C + if (IS_INDEFD(vrel)) + call pargd (INDEFD) + else + call pargd (vrel) + if (IS_INDEFD(DBL_VHELIO(rv,i))) + call pargd (INDEFD) + else + call pargd (DBL_VHELIO(rv,i)/C) + } + } else { + call pargr (INDEFR) + call pargr (INDEFR) + call pargr (INDEFR) + } + call pargr (DBL_VERR(rv,i)) + } + } else { + call nam_tempcode (RV_TEMPNUM(rv), tc) + if (RV_PRINTZ(rv) == NO) + call fprintf (fd, RV_WSTR1V) + else + call fprintf (fd, RV_WSTR1VZ) + call pargstr (OBJNAME(rv)) + call pargstr (IMAGE(rv)) + #call pargi (RV_TEMPCODE(rv)) + call pargstr (tc) + if (!IS_INDEFD(RV_VCOR(rv)) && RV_ERRCODE(rv) == OK && + RV_HJD(rv) > 0.0) + call pargd (mod(RV_HJD(rv),double(10000.0))) + else + call pargr (INDEF) + call pargi (RV_APNUM(rv)) + call pargstr (Memc[cp]) + if (RV_ERRCODE(rv) == OK) { + call pargr (RV_SHIFT(rv)) + call pargr (RV_HEIGHT(rv)) + if (!IS_INDEFR(RV_DISP(rv))) + call pargr (RV_DISP(rv)) + else + call pargr (RV_FWHM(rv)) + call pargr (RV_R(rv)) + if (RV_PRINTZ(rv) == NO) { + call pargd (RV_VOBS(rv)) + call pargr (RV_VREL(rv)) + call pargd (RV_VCOR(rv)) + } else { + if (IS_INDEFD(RV_VOBS(rv))) + call pargd (INDEFD) + else + call pargd (RV_VOBS(rv)/C) + if (IS_INDEFD(RV_VREL(rv))) + call pargd (INDEFD) + else + call pargd (RV_VREL(rv)/C) + if (IS_INDEFD(RV_VCOR(rv))) + call pargd (INDEFD) + else + call pargd (RV_VCOR(rv)/C) + } + call pargd (RV_ERROR(rv)) + } else { + call pargr (INDEF) + call pargr (INDEF) + call pargr (INDEF) + call pargr (INDEF) + call pargd (INDEFD) + call pargr (INDEF) + call pargd (INDEFD) + call pargd (INDEFD) + } + } + + call flush (fd) + call sfree (sp) +end + + +# RV_SHORT_HDR - Write out a line to the logfile or the screen. + +procedure rv_short_hdr (rv, fd) + +pointer rv #I RV struct pointer +pointer fd #I File descriptor + +begin + if (fd == NULL) + return + if (RV_PRINTZ(rv) == ERR) # bad velocity computation + RV_PRINTZ(rv) = NO + + if (RV_PRINTZ(rv) == NO) { + call fprintf (fd, RV_NSTR1S) + call fprintf (fd, RV_USTR1S) + } else { + call fprintf (fd, RV_NSTR1SZ) + call fprintf (fd, RV_USTR1SZ) + } + call fprintf (fd, "# \n") + + call flush (fd) +end + + +# RV_HDR - Procedure to write the banner for the RVXCOR task. + +procedure rv_hdr (rv, fd) + +pointer rv #I RV struct pointer +int fd #I File descriptor + +begin + if (fd == NULL) + return + if (RV_PRINTZ(rv) == ERR) # bad velocity computation + RV_PRINTZ(rv) = NO + + call flush (fd) + if (RV_VERBOSE(rv) == OF_SHORT || RV_VERBOSE(rv) == OF_STXTONLY) { + call rv_short_hdr (rv, fd) # write short header + return + } + + if (RV_PRINTZ(rv) == NO) { + call fprintf (fd, RV_NSTR1V) + call fprintf (fd, RV_USTR1V) + } else { + call fprintf (fd, RV_NSTR1VZ) + call fprintf (fd, RV_USTR1VZ) + } + call fprintf (fd, "#\n") + + call flush (fd) +end + + +# RV_CODES - Encode certain parameters into a string for output + +procedure rv_codes (rv, out, maxch) + +pointer rv #I RV struct pointer +char out[maxch] #O Output code string +int maxch + +pointer sp, func + +begin + call smark (sp) + call salloc (func, SZ_FNAME, TY_CHAR) + call nam_fitfunc (rv, Memc[func]) + + call sprintf (out, maxch, "%c%c%c/%-3.3s") + switch (RV_CONTINUUM(rv)) { + case OBJ_ONLY: + call pargi ('O') + case TEMP_ONLY: + call pargi ('T') + case BOTH: + call pargi ('B') + case NONE: + call pargi ('N') + } + switch (RV_FILTER(rv)) { + case OBJ_ONLY: + call pargi ('O') + case TEMP_ONLY: + call pargi ('T') + case BOTH: + call pargi ('B') + case NONE: + call pargi ('N') + } + switch (RV_REBIN(rv)) { + case RB_OBJ: + call pargi ('O') + case RB_TEMP: + call pargi ('T') + case RB_SMALL: + call pargi ('S') + case RB_BIG: + call pargi ('L') + } + call pargstr (Memc[func]) + + call sfree (sp) +end + + +# RV_TEMPCODES - Output the template codes and information + +procedure rv_tempcodes (rv, fd) + +pointer rv #I RV struct pointer +int fd #i Output file descriptor + +pointer sp, buf, im, title +int i, imtrgetim(), strlen() +char tc[3] + +begin + if (fd == NULL) + return + + call smark (sp) + call salloc (buf, 4*SZ_LINE, TY_CHAR) + call salloc (im, SZ_LINE, TY_CHAR) + call salloc (title, SZ_LINE, TY_CHAR) + + call fprintf (fd, "# \n") + do i = 1, RV_NTEMPS(rv) { + + if (imtrgetim(RV_TEMPLATES(rv), i, Memc[im], SZ_FNAME) != EOF) + call rv_imtitle (Memc[im], Memc[title], SZ_FNAME) + + # Truncate the leading path if needed. + if (strlen(Memc[im]) > 30) + call rv_strip_path (Memc[im], 30) + + call nam_tempcode (i, tc) + call sprintf (Memc[buf], SZ_LINE, + "#T %s '%.2s' -- %s = '%.40s'%78t\*\n#%21t%s = '%.30s'%64t%s = %.2f") + call pargstr ("Template") + call pargstr (tc) + call pargstr ("Object") + call pargstr (Memc[title]) + call pargstr ("Image ") + call pargstr (Memc[im]) + call pargstr ("Vhelio") + call pargr (TEMPVEL(rv,i)) + call fprintf (fd, "%s\n") + call pargstr (Memc[buf]) + } + call fprintf (fd, "# \n") + + call sfree (sp) +end + + +# RV_PRDELTAV - Output the velocity per pixel dispersion of the image. + +procedure rv_prdeltav (rv, fd) + +pointer rv #I RV struct pointer +int fd #I Output file descriptor + +begin + if (fd == NULL) + return + + call fprintf (fd, "# Velocity Dispersion = %-.2f Km/sec/pixel ") + call pargr (RV_DELTAV(rv)) + call fprintf (fd, "Rebinned WPC = %-.6g\n") + if (RV_DCFLAG(rv) != -1) + call pargr (RV_OWPC(rv)) + else + call pargr (INDEFR) + call flush (fd) +end + + +# RV_IMUPDATE - Update the image header with requested information + +procedure rv_imupdate (rv) + +pointer rv #I RV struct pointer + +pointer im, immap() +int imaccf() +errchk immap, imaccf, imaddr + +begin + im = immap (IMAGE(rv), READ_WRITE, 0) + if (IM_LEN(im,2) > 1 && IM_NDIM(im) > 1) { + call rv_err_comment (rv, + "WARNING: Cannot currently update a two-dimensional image.", + "") + + } else { + # Write observed & corrected velocity to image header + iferr { + if (imaccf(im,KW_HJD(rv)) == NO) + call imaddd (im, KW_HJD(rv), RV_HJD(rv)) + else + call imputd (im, KW_HJD(rv), RV_HJD(rv)) + if (imaccf(im,KW_MJD_OBS(rv)) == NO) + call imaddd (im, KW_MJD_OBS(rv), RV_MJD_OBS(rv)) + else + call imputd (im, KW_MJD_OBS(rv), RV_MJD_OBS(rv)) + if (imaccf(im,KW_VOBS(rv)) == NO) + call imaddd (im, KW_VOBS(rv), RV_VOBS(rv)) + else + call imputd (im, KW_VOBS(rv), RV_VOBS(rv)) + if (imaccf(im,KW_VHELIO(rv)) == NO) + call imaddd (im, KW_VHELIO(rv), RV_VCOR(rv)) + else + call imputd (im, KW_VHELIO(rv), RV_VCOR(rv)) + } then + call rv_err_comment (rv, + " ERROR: Error updating image header.", "") + } + call imunmap (im) +end + + +# RV_STRIP_PATH - Truncate a string to the rightmost number of characters +# specified. + +procedure rv_strip_path (str, maxch) + +char str[ARB] #I Input string +int maxch #I Maxchars + +int ip, strlen() + +begin + ip = max (1, strlen (str) - maxch + 1) + call amovc (str[ip], str, maxch) + str[31] = '\0' +end diff --git a/noao/rv/specmode.x b/noao/rv/specmode.x new file mode 100644 index 00000000..629370d4 --- /dev/null +++ b/noao/rv/specmode.x @@ -0,0 +1,266 @@ +include <gset.h> +include "rvpackage.h" +include "rvcomdef.h" +include "rvflags.h" +include "rvsample.h" + +# SPEC_COLON - Procedure to process the colon commands defined below. Most +# commands are for interactive editing of parameters to the task. + +int procedure spc_colon (rv, cmdstr) + +pointer rv #I RV struct pointer +char cmdstr[SZ_LINE] #I Command + +pointer sp, cmd +int cmd_regions(), strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + + if (strdic(Memc[cmd], Memc[cmd], SZ_LINE, CONT_KEYWORDS) != 0) { + # Process the CONTPARS pset commands. + call cont_colon (rv, cmdstr) + + } else { + # Now process the mode specific colon commands. + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, RVX_KEYWORDS)) { + case RVX_DISP: + # Print the rebinned wpc + call cmd_prtdisp (rv) + + case RVX_OSAMPLE: + # Set/Show the object sample region for correlation + if (cmd_regions(rv, RV_OSAMPLE(rv)) == ERR_CORREL) { + call sfree (sp) + return (ERR_CORREL) + } + + case RVX_RSAMPLE: + # Set/Show the template sample region for correlation + if (cmd_regions(rv,RV_RSAMPLE(rv)) == ERR_CORREL) { + call sfree (sp) + return (ERR_CORREL) + } + + case RVX_SHOW: + # List the current values of all parameters. + call rv_show (rv, STDOUT) + + case RVX_VERSION: + # Show the task version + call cmd_version () + + default: + # Default action. + call rv_errmsg (" Type '?' for a list of commands.") + } + } + + call sfree (sp) + return (OK) +end + + +# SPEC_CURSOR - Get the next command from the user in the input cursor loop +# and perform the requested function. + +int procedure spc_cursor (rv) + +pointer rv #I RV struct pointer + +pointer gp, sp +pointer cmd, buf +int wcs, key, stat +char ckey +real x, y, x1, x2, stdlam +bool prompt + +int spc_colon(), clgcur(), scan() +int fft_cursor(), rv_parent()#, stridx() + +define replot_ 99 +define exit_ 98 + +begin + # Update mode counter. + RV_MODES(rv) = (RV_MODES(rv) * 10) + SPEC_MODE + + # Allocate some space. + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + # Nab some pointers and initialize + key = RV_SPMKEY(rv) + gp = RV_GP(rv) + + RV_NEWXCOR(rv) = NO + RV_NEWGRAPH(rv) = NO + repeat { + + prompt = true +replot_ switch (key) { # switch on the keystroke + case '?': + # List options. + call gpagefile (gp, SM_HELP, "Spectrum Mode Options:") + + case ':': + # Process a colon command. + if (spc_colon(rv,Memc[cmd]) == QUIT) + break + prompt = false + + case 'b': + # Mark the sample regions for both spectra. + call gctran (gp, x, y, x1, x2, wcs, 1) + call rv_cut (rv, x1, x1, x2) + call gctran (gp, x, y, x, y, wcs, 0) + + call append_range (rv, RV_OSAMPLE(rv), x1, x2) + SR_MODIFY(RV_OSAMPLE(rv)) = YES + call append_range (rv, RV_RSAMPLE(rv), x1, x2) + SR_MODIFY(RV_RSAMPLE(rv)) = YES + + RV_NEWXCOR(rv) = YES + + case 'd': + # Print relative velocity between two different positions. + call gctran (gp, x, y, x, y, wcs, 1) + call rv_prshift (rv, x) + prompt = false + + case 'e': + # Show the summary plot after the fit. + call rv_eplot (rv, gp) + call rv_pause ("Hit any key to continue....") + key = RV_SPMKEY(rv) + goto replot_ + + case 'f': + # FFT Mode. + if (rv_parent(rv) == FFT_MODE) { + goto exit_ + } else if (fft_cursor(rv) == QUIT) { + RV_MODES(rv) = (RV_MODES(rv) - SPEC_MODE) / 10 + call sfree (sp) + return (QUIT) + } else { + key = RV_SPMKEY(rv) + goto replot_ + } + + case 'i': + # Display original input spectra. + call rv_splot (rv, SPLIT_PLOT) + + case 'I': + # Interrupt command. + call error (0, "Interrupt") + + case 'n': + # Display continuum subtracted spectra. + call rv_nplot (rv, SPLIT_PLOT) + + case 'p': + # Display the FFT prepared spectra. + call rv_fftcorr (rv, YES) + call rv_pause ("Hit any key to continue....") + key = RV_SPMKEY(rv) + goto replot_ + + case 'q': + # Quit. + break + + case 'r': + # Replot. + key = RV_SPMKEY(rv) + goto replot_ + + case 's': + # Mark the sample regions. + call gctran (gp, x, y, x1, x2, wcs, 1) + call rv_cut (rv, x1, x1, x2) + call gctran (gp, x, y, x, y, wcs, 0) + if (y > 0.5) { # Cut from the top + call append_range (rv, RV_OSAMPLE(rv), x1, x2) + call rv_mark_regions (RV_OSAMPLE(rv), RV_GP(rv)) + SR_MODIFY(RV_OSAMPLE(rv)) = YES + } else { + call append_range (rv, RV_RSAMPLE(rv), x1, x2) + call rv_mark_regions (RV_RSAMPLE(rv), RV_GP(rv)) + SR_MODIFY(RV_RSAMPLE(rv)) = YES + } + RV_NEWXCOR(rv) = YES + + case 'u': + # Unselect a sample region. + call gctran (gp, x, y, x1, x2, wcs, 1) + call gctran (gp, x, y, x, y, wcs, 0) + if (y > 0.5) { # Cut from the top + call delete_samp (rv, RV_OSAMPLE(rv), x1) + SR_MODIFY(RV_OSAMPLE(rv)) = YES + } else { + call delete_samp (rv, RV_RSAMPLE(rv), x1) + SR_MODIFY(RV_RSAMPLE(rv)) = YES + } + RV_NEWXCOR(rv) = YES + + case 'v': + # Fit the line and compute a velocity based on standard + # wavelength. + if (RV_DCFLAG(rv) == -1) { + call eprintf ( + "No dispersion available for velocity computation.") + } else { + call gctran (gp, x, y, x1, x2, wcs, 1) + call rv_cut (rv, x1, x1, x2) + call gctran (gp, x, y, x, y, wcs, 0) + stdlam = 0.0 + while (stdlam == 0.0) { + call printf ("Standard Wavelength: ") + call flush (STDOUT) + stat = scan() + call gargr (stdlam) + } + + if (y > 0.5) # Fit at the top + call rv_linefit (rv, x1, x2, stdlam, OBJECT_SPECTRUM) + else + call rv_linefit (rv, x1, x2, stdlam, REFER_SPECTRUM) + } + prompt = false + + case 'x': + # Return to the correlation mode. + RV_MODES(rv) = (RV_MODES(rv) - SPEC_MODE) / 10 + call sfree (sp) + return (QUIT) + + default: + # Unknown command. + prompt = false + call rv_mode_prompt (rv) + call rv_errmsg (" Type '?' for a list of commands.") + } + + if (prompt) + call rv_mode_prompt (rv) + ckey = key + #if (stridx(ckey,"?:bdepfsuvxqr\0") != 0) + if (ckey == 'n' || ckey == 'i') + RV_SPMKEY(rv) = key + } until (clgcur("cursor",x,y,wcs,key,Memc[cmd],SZ_LINE) == EOF) + +exit_ call sfree (sp) + RV_MODES(rv) = (RV_MODES(rv) - SPEC_MODE) / 10 + return (OK) +end diff --git a/noao/rv/splitplot.x b/noao/rv/splitplot.x new file mode 100644 index 00000000..e2956493 --- /dev/null +++ b/noao/rv/splitplot.x @@ -0,0 +1,870 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvplots.h" +include "rvsample.h" + +# SPLIT_PLOT - Plot the Fourier transform, power spectrum or spectrum +# normalization to the top or botom half of the screen. + +procedure split_plot (rv, gp, where, rinpt, npts, dtype, pltype) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +int where #I Where to make plot +real rinpt[npts] #I Input array +int npts #I No. points in input +int dtype #I Type of data being plotted (obj|ref) +int pltype #I Type of data plot to draw + +pointer sp, xdata, pldata, title +pointer xlbl, ylbl +real x1, x2, y1, y2 +int i, fnpts, pnpts +double rv_shift2vel() + +begin + if (gp == NULL) + return + + call smark (sp) + call salloc (title, 3*SZ_LINE, TY_CHAR) + call salloc (xlbl, SZ_FNAME, TY_CHAR) + call salloc (ylbl, SZ_FNAME, TY_CHAR) + call salloc (pldata, 2*npts, TY_REAL) + call salloc (xdata, 2*npts, TY_REAL) + + # Do some misc. initial stuff + RV_WHERE(rv) = where + RV_DTYPE(rv) = dtype + call aclrr (Memr[pldata], 2*npts) + call amovr (rinpt, Memr[pldata], npts) + pnpts = RV_IEND(rv) - RV_ISTART(rv) + 1 + + switch (pltype) { + case SPECTRUM_PLOT, PREPARED_PLOT, NORM_PLOT: + fnpts = npts + call sp_spectrum (rv, title, xlbl, ylbl, x1, x2, fnpts, + Memr[xdata], pltype) + + case FILTER_PLOT: + fnpts = npts + call sp_spectrum (rv, title, xlbl, ylbl, x1, x2, fnpts, + Memr[xdata], pltype) + + case CORRELATION_PLOT: + call sp_correlation (rv, where, title, xlbl, ylbl, x1, x2) + if (where == BOTTOM) + fnpts = npts + else { + x1 = WRKPIXX(rv,1) + x2 = WRKPIXX(rv,RV_CCFNPTS(rv)) + fnpts = RV_CCFNPTS(rv) + call strcpy ("", Memc[ylbl], SZ_LINE) + } + call amovr (WRKPIXX(rv,1), Memr[xdata], fnpts) + + case VCORRELATION_PLOT: + call sp_vcorrelation (rv, title, xlbl, ylbl, x1, x2) + if (RV_DCFLAG(rv) == -1 && (dtype == SUMMARY_PLOT || + dtype == BINARY_PLOT)) { + x1 = RV_WINL(rv) - RV_WINDOW(rv) + x2 = RV_WINR(rv) + RV_WINDOW(rv) + fnpts = RV_CCFNPTS(rv) + call amovr (WRKPIXX(rv,1), Memr[xdata], fnpts) + } else if (where == BOTTOM) { + do i = 1, npts + Memr[xdata+i-1] = real (rv_shift2vel(rv,WRKPIXX(rv,i))) + fnpts = npts + } + + case FOURIER_PLOT: + call sp_fourier (rv, dtype, where, rinpt, pldata, title, + xlbl, ylbl, x1, x2, npts, fnpts) + fnpts = int (fnpts / RVP_FFT_ZOOM(rv)) + + case PS_PLOT: + call sp_psplot (rv, dtype, where, rinpt, pldata, title, + xlbl, ylbl, x1, x2, npts, fnpts) + fnpts = int (fnpts / RVP_FFT_ZOOM(rv)) + + case ANTISYM_PLOT: + call sp_anplot (rv, title, xlbl, ylbl, x1, x2) + fnpts = RV_CCFNPTS(rv) + call amovr (WRKPIXX(rv,1), Memr[xdata], fnpts) + call amovr (ANTISYM(rv,1), Memr[pldata], fnpts) + + default: + call error (0, "split_plot: Illegal plot flag passed.") + } + + # Set viewports for the plot to the screen + call sp_set_viewports (rv, gp, where, dtype, pltype, Memc[xlbl]) + + # Now label the axes for the various plots + call sp_label_axes (rv, gp, dtype, pltype, where, x1, x2, y1, y2, + Memr[pldata], fnpts, pnpts, Memc[title], Memc[xlbl], Memc[ylbl]) + + # lastly, draw the actual vector in the window + call sp_draw_vector (rv, gp, pltype, where, x1, x2, y1, y2, + Memr[pldata], Memr[xdata], fnpts, pnpts) + + # Now make it pretty + call sp_annotate (rv, gp, pltype, dtype, fnpts, x1, x2, y1, y2) + + call gflush (gp) + call sfree (sp) +end + + +# SP_SET_VIEWPORTS - Set the view ports for the various plit screens + +procedure sp_set_viewports (rv, gp, where, dtype, pltype, xlbl) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +int where #I Where is plot being drawn +int dtype #I Type of data (2ndary flag) +int pltype #I Plot type +char xlbl[SZ_FNAME] #I X-axis Label + +begin + # Set those darned viewpoints + switch (where) { + case TOP: # Set top viewport + call gseti (gp, G_WCS, 1) + if (pltype == CORRELATION_PLOT && dtype != ANTISYM_PLOT) { + call gseti (gp, G_WCS, 3) + call gsview (gp, 0.115, 0.95, 0.775, 0.90) + } else if (pltype == CORRELATION_PLOT && dtype == ANTISYM_PLOT) + call gsview (gp, 0.115, 0.95, 0.65, 0.90) + else if (pltype == SPECTRUM_PLOT && dtype == SUMMARY_PLOT) + call gsview (gp, 0.115, 0.95, 0.70, 0.90) + else + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + call strcpy ("", xlbl, SZ_FNAME) # Overwrite axis label + + case MIDDLE: + call gseti (gp, G_WCS, 1) + call gsview (gp, 0.115, 0.95, 0.475, 0.63) # In a summary plot + + case BOTTOM: # Set bottom viewport + call gseti (gp, G_WCS, 1) + if (pltype == ANTISYM_PLOT) + call gsview (gp, 0.115, 0.95, 0.30, 0.55) + else if (pltype == CORRELATION_PLOT) { + call gseti (gp, G_WCS, 2) # Restore attributes + call gsview (gp, 0.115, 0.95, 0.15, 0.725) + } else if (pltype == VCORRELATION_PLOT && dtype == SUMMARY_PLOT) { + call gseti (gp, G_WCS, 2) # Restore attributes + call gsview (gp, 0.115, 0.95, 0.125, 0.465) + } else if (pltype == VCORRELATION_PLOT && dtype == BINARY_PLOT) { + call gseti (gp, G_WCS, 1) + call gsview (gp, 0.115, 0.95, 0.125, 0.64) + } else { + call gsview (gp, 0.115, 0.95, 0.125, 0.50) + } + + default: + call gclear (gp) + } + + call gflush (gp) +end + + +# SP_LABEL_AXES - Draw the axes labels for the requested plots + +procedure sp_label_axes (rv, gp, dtype, pltype, where, x1, x2, y1, y2, pldata, + fnpts, pnpts, title, xlbl, ylbl) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +int dtype #I Type of data (2ndry flag) +int pltype #I Type of plot to draw +int where #I Where to draw the plot +real x1, x2, y1, y2 #I Axis endpoints +real pldata[ARB] #I Data vector being drawn +int fnpts, pnpts #i FFT npts and plot npts +char title[ARB] #I Plot title +char xlbl[SZ_LINE], ylbl[SZ_LINE] #I Plot labels + +real v1, v2, range +int istart, npts +double rv_shift2vel() +real rv_maxpix(), rv_minpix() + +begin + # Now do the real plotting + if (where == BOTTOM && (pltype == CORRELATION_PLOT || + pltype == VCORRELATION_PLOT)) { + istart = max (1, RV_WINCENTER(rv) + 1 - RV_WINDOW(rv)) + npts = min (RV_WINR(rv) - RV_WINL(rv) + 1, RV_CCFNPTS(rv)) + y2 = rv_maxpix (pldata[istart], npts) + y1 = rv_minpix (pldata[istart], npts) + } else { + y2 = rv_maxpix (pldata, fnpts) + y1 = rv_minpix (pldata, fnpts) + } + range = abs (y2 - y1) + if (dtype != BINARY_PLOT) { + y2 = y2 + (.15 * range) + y1 = y1 - (.12 * range) + } else + y2 = y2 + (.35 * range) + call gswind (gp, x1, x2, y1, y2) + + if ((pltype == CORRELATION_PLOT || pltype == VCORRELATION_PLOT) && + where == BOTTOM) { + + if (dtype != BINARY_PLOT) { # Force plot scaling + if (!IS_INDEF(RV_Y2(rv))) + y2 = RV_Y2(rv) + else + RV_Y2(rv) = y2 + if (!IS_INDEF(RV_Y1(rv))) + y1 = RV_Y1(rv) + else + RV_Y1(rv) = y1 + call gswind (gp, x1, x2, y1, y2) + } + + if (dtype == SUMMARY_PLOT || dtype == BINARY_PLOT) { + call sp_color_viewport (gp) + call glabax (gp, "", xlbl, ylbl) + + } else if (RV_DCFLAG(rv) == -1) { + call sp_color_viewport (gp) + call glabax (gp, title, xlbl, ylbl) + + } else { + call gseti (gp, G_WCS, 1) # Set attributes + v1 = real (rv_shift2vel(rv,real(RV_WINL(rv)))) + v2 = real (rv_shift2vel(rv,real(RV_WINR(rv)))) + call gsview (gp, 0.115, 0.95, 0.15, 0.725) + call gswind (gp, v1, v2, y1, y2) + call gseti (gp, G_YDRAWAXES, 0) + call gseti (gp, G_XDRAWAXES, 2) + call sp_color_viewport (gp) + call glabax (gp, "", "", "") # Draw top axis + + call gseti (gp, G_WCS, 2) # Draw bottom labels + call gseti (gp, G_XDRAWAXES, 1) + call gseti (gp, G_YDRAWAXES, 3) + call glabax (gp, "", xlbl, ylbl) + + call gseti (gp, G_WCS, 2) # Restore attributes + call gseti (gp, G_XDRAWAXES, 3) + call gseti (gp, G_YDRAWAXES, 3) + } + + } else if (pltype == CORRELATION_PLOT) { + call gseti (gp, G_LABELTICKS, NO) # Set attributes + call gseti (gp, G_DRAWTICKS, NO) + + if (where==TOP) { # Do the label + call glabax (gp, title, "", "") + } else if (where == MIDDLE) { + call sp_color_viewport (gp) + call glabax (gp, "", "", "") + } + + call gseti (gp, G_LABELTICKS, YES) # Restore attributes + call gseti (gp, G_DRAWTICKS, YES) + + } else if (pltype == FOURIER_PLOT || pltype == PS_PLOT || + pltype == FILTER_PLOT) { + if (where==TOP) { # Do the label + call gseti (gp, G_WCS, 1) # Do the top axis + call gswind (gp, x1, x2, y1, y2) + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + call gseti (gp, G_XDRAWAXES, 2) + call gseti (gp, G_XDRAWTICKS, 2) + call gseti (gp, G_YDRAWAXES, 0) + call glabax (gp, "", "", "") + + call gseti (gp, G_WCS, 4) # Do the plot title + call gswind (gp, x1, x2, y1, y2) + #call gsview (gp, 0.115, 0.95, 0.51, 0.865) + call gsview (gp, 0.115, 0.95, 0.51, 0.91) + call gseti (gp, G_XDRAWAXES, 0) + call gseti (gp, G_YDRAWAXES, 0) + call glabax (gp, title, "", "") + + call gseti (gp, G_WCS, 2) # Remainder of top plot + call gseti (gp, G_YDRAWAXES, 3) + call gseti (gp, G_XDRAWAXES, 1) + call gseti (gp, G_XDRAWTICKS, 0) + call gseti (gp, G_XLABELTICKS, NO) + call gswind (gp, x1, x2, y1, y2) + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + call glabax (gp, "", xlbl, ylbl) + + call gseti (gp, G_XDRAWTICKS, YES) # Restore reality + call gseti (gp, G_XLABELTICKS, YES) + call gseti (gp, G_XDRAWAXES, 2) + + } else if (where == BOTTOM) { + call gseti (gp, G_WCS, 1) + call gswind (gp, x1, x2, y1, y2) + call gsview (gp, 0.115, 0.95, 0.125, 0.5) + call gseti (gp, G_XLABELTICKS, YES) + call gseti (gp, G_XDRAWAXES, 1) + + call sp_color_viewport (gp) + call glabax (gp, "", xlbl, ylbl) + + call gseti (gp, G_XDRAWAXES, 2) # Draw top boundary + call gseti (gp, G_DRAWTICKS, NO) + call glabax (gp, "", "", "") + + call gseti (gp, G_DRAWTICKS, YES) + call gseti (gp, G_LABELTICKS, YES) + call gseti (gp, G_XLABELTICKS, 2) + } + + } else if (pltype == SPECTRUM_PLOT || pltype == NORM_PLOT || + pltype == PREPARED_PLOT) { + + if (where == TOP) { + if (dtype == SUMMARY_PLOT) { + call glabax (gp, title, "", ylbl) + } else { + call gseti (gp, G_XLABELTICKS, NO) + call glabax (gp, title, "", ylbl) + call gseti (gp, G_XLABELTICKS, YES) + } + + } else if (where == BOTTOM) { + call gseti (gp, G_XLABELTICKS, YES) + call gseti (gp, G_XDRAWAXES, 3) + call sp_color_viewport (gp) + call glabax (gp, "", xlbl, ylbl) + } + + } else { + call sp_color_viewport (gp) + call glabax (gp, title, xlbl, ylbl) + } + + call gflush (gp) +end + + +# SP_DRAW_VECTOR - Draw the vector for the requested plot + +procedure sp_draw_vector (rv, gp, pltype, where, x1, x2, y1, y2, pldata, xdata, + fnpts, pnpts) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +int pltype #I Type of plot to draw +int where #I Where to plot data +real x1, x2, y1, y2 #I Boundaries of plot +real pldata[ARB] #I Vector to plot +real xdata[ARB] #I X-Vector to plot +int fnpts, pnpts #I FFT npts and plot npts + +real left, right +int i, npts + +begin + switch (pltype) { + case CORRELATION_PLOT: + if (DBG_QUICK(rv) == NO || (DBG_QUICK(rv) == YES && where==BOTTOM)){ + if (where == BOTTOM) { + i = RV_WINCENTER(rv) - RV_WINDOW(rv) + npts = 2 * RV_WINDOW(rv) + 1 + call gpline (gp, xdata[i], pldata[i], npts) + } else + call gpline (gp, xdata[2], pldata[2], fnpts-2) + call gflush (gp) + } + + left = RV_WINL(rv) + right = RV_WINR(rv) + switch (where) { + case TOP: + call gseti (gp, G_PLTYPE, GL_DASHED) + call gseti (gp, G_PLCOLOR, C_RED) + call gline (gp, left, y1, left, y2) + call gline (gp, right, y1, right, y2) + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + call gline (gp, x1, 0.0, x2, 0.0) # Zero level + case MIDDLE: + # Actual plot window + call gseti (gp, G_PLTYPE, GL_DASHED) + #call gseti (gp, G_PLCOLOR, C_RED) + call gline (gp, real(left-RV_WINDOW(rv)), y1, + real(left-RV_WINDOW(rv)), y2) + call gline (gp, real(right+RV_WINDOW(rv)), y1, + real(right+RV_WINDOW(rv)), y2) + # Parameter plot window + call gseti (gp, G_PLTYPE, GL_DOTTED) + call gseti (gp, G_PLCOLOR, C_RED) + call gline (gp, left, y1, left, y2) + call gline (gp, right, y1, right, y2) + call gseti (gp, G_PLTYPE, GL_SOLID) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + call gline (gp, x1, 0.0, x2, 0.0) # Zero level + case BOTTOM: + call gseti (gp, G_WCS, 2) + if (RV_FITDONE(rv) == YES) { + if (IS_DBLSTAR(rv) == NO) { + call gpmark (gp, xdata[RV_ISTART(rv)], + pldata[RV_ISTART(rv)], pnpts, 4, 2., 2.) + call rv_draw_fit (rv, gp, NO) + call gseti (gp, G_PLCOLOR, C_GREEN) + call rv_draw_background (rv, gp) + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } else { + i = DBL_I1(rv) + call gpmark (gp, xdata[i], pldata[i], DBL_NFITP(rv), + 4, 2., 2.) + call rv_plt_deblend (rv, gp, NO) + } + } + } + RV_X1(rv) = x1 + RV_X2(rv) = x2 + + case VCORRELATION_PLOT: + call gpline (gp, xdata, pldata, fnpts) + if (where == BOTTOM && RV_FITDONE(rv) == YES) { + if (IS_DBLSTAR(rv) == NO) { + call gpmark (gp, xdata[RV_ISTART(rv)], + pldata[RV_ISTART(rv)], pnpts, 4, 2., 2.) + if (RV_DCFLAG(rv) != -1) + call rv_draw_fit (rv, gp, YES) + else + call rv_draw_fit (rv, gp, NO) + call rv_draw_background (rv, gp) + } else { + i = DBL_I1(rv) + call gpmark (gp, xdata[i], pldata[i], DBL_NFITP(rv), + 4, 2., 2.) + call rv_plt_deblend (rv, gp, YES) + } + } + + case CONVOLUTION_PLOT, ANTISYM_PLOT, FILTER_PLOT, PREPARED_PLOT: + if (DBG_QUICK(rv) == NO && RV_DTYPE(rv) != SUMMARY_PLOT) + call gpline (gp, xdata, pldata, fnpts) + + case SPECTRUM_PLOT, NORM_PLOT: + if (DBG_QUICK(rv) == NO && RV_DTYPE(rv) != SUMMARY_PLOT) { + if (RV_DTYPE(rv) == OBJECT_SPECTRUM) + call gpline (gp, xdata, pldata, RV_NPTS(rv)) + else + call gpline (gp, xdata, pldata, RV_RNPTS(rv)) + } else if (RV_DTYPE(rv) == SUMMARY_PLOT) { + call gpline (gp, xdata, pldata, RV_NPTS(rv)) + #call gvline (gp, pldata, RV_NPTS(rv), x1, x2) + } + default: + call gvline (gp, pldata, fnpts, x1, x2) + } + RV_GTYPE(rv) = pltype + call gflush (gp) +end + + +# SP_ANNOTATE - Annotate the split plot to clarify what's what. + +procedure sp_annotate (rv, gp, pltype, dtype, fnpts, x1, x2, y1, y2) + +pointer rv #I RV struct pointer +pointer gp #I Graphics pointer +int pltype, dtype #I Plot and data types +int fnpts #I Npts in fft plot +real x1, x2, y1, y2 #I Plot boundaries + +double dex() +real l, r +int i + +begin + call gseti (gp, G_TXCOLOR, RV_TXTCOLOR(rv)) + switch (pltype) { + case FOURIER_PLOT, PS_PLOT: + if (dtype == OBJECT_SPECTRUM) { + if (RV_FILTER(rv) == OBJ_ONLY || RV_FILTER(rv) == BOTH) { + call gseti (gp, G_WCS, 2) + call gsview (gp, 0.115, 0.95, 0.51, 0.865) + call gswind (gp, x1, x2, y1, y2) + call fft_fltoverlay (rv, gp, int(fnpts*RVP_FFT_ZOOM(rv))*2, + y2) + } + } else if (dtype == REFER_SPECTRUM) { + if (RV_FILTER(rv) == TEMP_ONLY || RV_FILTER(rv) == BOTH) { + call gseti (gp, G_WCS, 2) + call gsview (gp, 0.115, 0.95, 0.125, 0.5) + call gswind (gp, x1, x2, y1, y2) + call fft_fltoverlay (rv, gp, int(fnpts*RVP_FFT_ZOOM(rv))*2, + y2) + } + } + if (RV_WHERE(rv) == TOP) { + call gctran (gp, 0.73, 0.8, x1, y1, 0, 2) + if (pltype == FOURIER_PLOT) + call gtext (gp, x1, y1, "Object FFT", "") + else + call gtext (gp, x1, y1, "Object PS", "") + call gctran (gp, 0.73, 0.77, x1, y1, 0, 1) + } else if (RV_WHERE(rv) == BOTTOM) { + call gctran (gp, 0.73, 0.43, x1, y1, 0, 1) + if (pltype == FOURIER_PLOT) + call gtext (gp, x1, y1, "Template FFT", "") + else + call gtext (gp, x1, y1, "Template PS", "") + call gctran (gp, 0.73, 0.4, x1, y1, 0, 1) + } + if (RV_FILTER(rv) == BOTH || RV_FILTER(rv) == OBJ_ONLY) { + if (RVP_WHEN(rv) == BEFORE) + call gtext (gp, x1, y1, "Before Filter", "") + else + call gtext (gp, x1, y1, "After Filter", "") + } + + case NORM_PLOT, SPECTRUM_PLOT, PREPARED_PLOT, FILTER_PLOT: + if (RV_WHERE(rv) == TOP && dtype != SUMMARY_PLOT) { + call gctran (gp, 0.7, 0.55, x1, y1, 0, 1) + switch (pltype) { + case NORM_PLOT: + if (dtype == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Norm. Object", "") + else + call gtext (gp, x1, y1, "Norm. Template", "") + case SPECTRUM_PLOT: + if (dtype == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Orig. Object", "") + else + call gtext (gp, x1, y1, "Orig. Template", "") + case PREPARED_PLOT: + call gtext (gp, x1, y1, "Prepared Object", "") + case FILTER_PLOT: + call gtext (gp, x1, y1, "Filtered Object", "") + } + } else if (RV_WHERE(rv) == BOTTOM) { + call gctran (gp, 0.7, 0.175, x1, y1, 0, 1) + switch (pltype) { + case NORM_PLOT: + if (dtype == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Norm. Object", "") + else + call gtext (gp, x1, y1, "Norm. Template", "") + case SPECTRUM_PLOT: + if (dtype == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Orig. Object", "") + else + call gtext (gp, x1, y1, "Orig. Template", "") + case PREPARED_PLOT: + call gtext (gp, x1, y1, "Prepared Temp.", "") + case FILTER_PLOT: + if (dtype == OBJECT_SPECTRUM) + call gtext (gp, x1, y1, "Filtered Object", "") + else if (dtype == REFER_SPECTRUM) + call gtext (gp, x1, y1, "Filtered Temp.", "") + } + } + if (dtype != SUMMARY_PLOT) { + if (pltype != PREPARED_PLOT) { + if (RV_WHERE(rv) == TOP) + call rv_mark_regions (RV_OSAMPLE(rv), gp) + else + call rv_mark_regions (RV_RSAMPLE(rv), gp) + } + } else if (dtype == SUMMARY_PLOT && RV_WHERE(rv) == TOP) { + if (SR_COUNT(RV_OSAMPLE(rv)) != ALL_SPECTRUM) { + call gseti (gp, G_PLCOLOR, C_GREEN) + do i = 1, SR_COUNT(RV_OSAMPLE(rv)) { + l = SRANGE(RV_OSAMPLE(rv),i) + r = ERANGE(RV_OSAMPLE(rv),i) + if (RV_PIXCORR(rv) == NO && RV_DCFLAG(rv) != -1 && + SR_UNITS(RV_OSAMPLE(rv)) == PIXELS) { + l = real (dex(RV_OW0(rv)+(l-1)*RV_OWPC(rv))) + r = real (dex(RV_OW0(rv)+(r-1)*RV_OWPC(rv))) + } + call mark_range (gp, l, r) + } + call gseti (gp, G_PLCOLOR, C_FOREGROUND) + } + } + + case ANTISYM_PLOT: + # Write the text + call gsview (gp, 0.05, 0.97, 0.30, 0.9) + call gswind (gp, 0.08, 0.97, 0.30, 0.9) + call gseti (gp, G_TXCOLOR, C_FOREGROUND) + call gtext (gp, 0.075, 0.45, "Correlation\000", "p=d") + } + call gseti (gp, G_TXCOLOR, C_FOREGROUND) +end + + +# SP_COLOR_VIEWPORT - Fill the specified viewport with the current background +# color. For color terminals such as XGterm the background color is only +# drawn in the first graph on the screen. + +procedure sp_color_viewport (gp) + +pointer gp #I graphics pointer + +real x1, x2, y1, y2, xv[5], yv[5] + +begin + # Get the current viewport boundaries. + call ggwind (gp, x1, x2, y1, y2) + + # Fill the polygon vector and color the area. + xv[1] = x1; yv[1] = y1 + xv[2] = x2; yv[2] = y1 + xv[3] = x2; yv[3] = y2 + xv[4] = x1; yv[4] = y2 + xv[5] = x1; yv[5] = y1 + call gseti (gp, G_FACOLOR, 0) + call gfill (gp, xv, yv, 4, GF_SOLID) + call gflush (gp) +end + + +# SP_SPECTRUM - Set window boundaries and title for a spectrum plot + +procedure sp_spectrum (rv, title, x_lbl, y_lbl, x1, x2, fnpts, xdata, pltype) + +pointer rv #I RV struct pointer +pointer title #O Plot title pointer +pointer x_lbl #O Plot x label pointer +pointer y_lbl #O Plot y label pointer +real x1, x2 #O Endpoints +int fnpts #I Npts to plot +real xdata[fnpts] #O X-axis data +int pltype #I Plot type + +int i, fft_pow2() + +begin + call get_plot_title (rv, title, fnpts) + call strcpy ("Intensity", Memc[y_lbl], SZ_FNAME) + if (RV_DCFLAG(rv) == -1 || pltype == PREPARED_PLOT) { + call strcpy ("Pixel", Memc[x_lbl], SZ_FNAME) + x1 = 1. + if (pltype == PREPARED_PLOT) { + i = int ((RV_GLOB_W2(rv) - RV_GLOB_W1(rv)) / RV_OWPC(rv) + 1) + x2 = fft_pow2 (i) + if (RV_RW0(rv) > RV_OW2(rv) || RV_OW0(rv) > RV_RW2(rv)) + x2 = x2 * 2 + } else + x2 = real (fnpts) + for (i=int(x2); i>=1; i=i-1) + xdata[i] = real[i] + } else { + call strcpy ("Wavelength", Memc[x_lbl], SZ_FNAME) + if (RV_DTYPE(rv) == SUMMARY_PLOT) { + x1 = 10. ** (RV_OW0(rv)) + x2 = 10. ** (RV_OW2(rv)) + } else { + x1 = 10. ** (RV_GLOB_W1(rv)) + x2 = 10. ** (RV_GLOB_W2(rv)) + } + + if (pltype == FILTER_PLOT || + pltype == NORM_PLOT || + pltype == SPECTRUM_PLOT) { + if (RV_DTYPE(rv) == REFER_SPECTRUM) { + do i = 1, fnpts + xdata[i] = 10. ** (RV_RW0(rv) + (i-1) * RV_RWPC(rv)) + } else { + do i = 1, fnpts + xdata[i] = 10. ** (RV_OW0(rv) + (i-1) * RV_OWPC(rv)) + } + } else if (RV_WHERE(rv) == TOP) { + do i = 1, fnpts + xdata[i] = 10. ** (RV_OW0(rv) + (i-1) * RV_OWPC(rv)) + } else { + do i = 1, fnpts + xdata[i] = 10. ** (RV_RW0(rv) + (i-1) * RV_RWPC(rv)) + } + } +end + + +# SP_VCORRELATION - Set window boundaries and titles for a velocity CCF +# plot. + +procedure sp_vcorrelation (rv, title, x_lbl, y_lbl, x1, x2) + +pointer rv #I RV struct pointer +pointer title #O Plot title pointer +pointer x_lbl #O Plot x label pointer +pointer y_lbl #O Plot y label pointer +real x1, x2 #O Endpoints +double rv_shift2vel() +real min(), max() + +begin + if (RV_DCFLAG(rv) == -1) { + call strcpy ("Pixel Correlation - No velocities will be computed", + Memc[title], SZ_LINE) + x1 = max (WRKPIXX(rv,1), real(RV_WINL(rv)-RV_WINDOW(rv))) + x2 = min (WRKPIXX(rv,RV_CCFNPTS(rv)), + real(RV_WINR(rv)+RV_WINDOW(rv))) + call strcpy ("Pixel Shift", Memc[x_lbl], SZ_FNAME) + } else { + call sprintf (Memc[title], SZ_LINE, + "Correlation function Template = '%s'") + call pargstr (TEMPNAME(rv)) + if (RV_DTYPE(rv) == SUMMARY_PLOT) { + x1 = max (WRKPIXX(rv,1), real(RV_WINL(rv)-RV_WINDOW(rv))) + x2 = min (WRKPIXX(rv,RV_CCFNPTS(rv)), + real(RV_WINR(rv)+RV_WINDOW(rv))) + } else { + x1 = max (WRKPIXX(rv,1), real(RV_WINL(rv))) + x2 = min (WRKPIXX(rv,RV_CCFNPTS(rv)), real(RV_WINR(rv))) + } + x1 = real (rv_shift2vel(rv,x1)) + x2 = real (rv_shift2vel(rv,x2)) + call strcpy ("Relative Velocity (Km/sec)", Memc[x_lbl], SZ_FNAME) + } + call strcpy ("Correlation", Memc[y_lbl], SZ_FNAME) +end + + +# SP_CORRELATION - Set window boundaries and titles for a CCF plot. + +procedure sp_correlation (rv, where, title, x_lbl, y_lbl, x1, x2) + +pointer rv #I RV struct pointer +int where #I Where is the plot located? +pointer title #O Plot title pointer +pointer x_lbl #O Plot x label pointer +pointer y_lbl #O Plot y label pointer +real x1, x2 #O Endpoints + +real min(), max() + +begin + if (where == BOTTOM) { + if (RV_DCFLAG(rv) == -1) { + call strcpy ( + "Pixel Correlation - No velocities will be computed", + Memc[title], SZ_LINE) + } else { + call sprintf (Memc[title], SZ_LINE, + "Correlation function Template = '%s'") + call pargstr (TEMPNAME(rv)) + } + } else + call get_anplot_title (rv, title) + + call strcpy ("Correlation", Memc[y_lbl], SZ_FNAME) + call strcpy ("Pixel Shift", Memc[x_lbl], SZ_FNAME) + x1 = max (real(RV_WINL(rv)), WRKPIXX(rv,1)-1) + x2 = min (real(RV_WINR(rv)), WRKPIXX(rv,RV_CCFNPTS(rv))+1) +end + + +# SP_ANPLOT - Set window boundaries and title for an antisymmetric noise +# plot. + +procedure sp_anplot (rv, title, x_lbl, y_lbl, x1, x2) + +pointer rv #I RV struct pointer +pointer title #O Plot title pointer +pointer x_lbl #O Plot x label pointer +pointer y_lbl #O Plot y label pointer +real x1, x2 #O Endpoints + +begin + call sprintf (Memc[title], SZ_LINE, + "Antisymmetric Noise Component of CCF") + call strcpy ("", Memc[y_lbl], SZ_FNAME) + call strcpy ("Lag", Memc[x_lbl], SZ_FNAME) + x1 = WRKPIXX(rv,1) + x2 = WRKPIXX(rv,RV_CCFNPTS(rv)) +end + + +# SP_FOURIER - Set window boundaries and title for an FFT plot. + +procedure sp_fourier (rv, dtype, where, rinpt, pldata, title, x_lbl, y_lbl, + x1, x2, npts, fnpts) + +pointer rv #I RV struct pointer +int dtype #I Data type to plot +int where #I Where to plot the data +real rinpt[npts] #I Input plot array +pointer pldata #O Output plot array +pointer title #O Plot title pointer +pointer x_lbl #O Plot x label pointer +pointer y_lbl #O Plot y label pointer +real x1, x2 #O Endpoints +int npts #I Npts in data +int fnpts #I Npts in fft + +begin + call get_fft (rv, rinpt, npts, Memr[pldata], fnpts) + fnpts = max (RV_FFTNPTS(rv), fnpts) / 2 + if (where != BOTTOM) + call get_anplot_title (rv, title) + else + call strcpy ("", Memc[title], SZ_FNAME) + + if (RVP_LOG_SCALE(rv) == YES) + call strcpy ("log(|G(k)|)", Memc[y_lbl], SZ_FNAME) + else + call strcpy ("|G(k)|", Memc[y_lbl], SZ_FNAME) + + switch (where) { + case TOP: + call strcpy ("Frequency", Memc[x_lbl], SZ_FNAME) + x1 = 0.0 + x2 = (real (fnpts) / RVP_FFT_ZOOM(rv)) / (2. * real (fnpts)) + case BOTTOM: + call strcpy ("Wavenumber", Memc[x_lbl], SZ_FNAME) + x1 = 1. + x2 = real (fnpts) / RVP_FFT_ZOOM(rv) + } +end + + +# SP_PSPLOT - Set window boundaries and title for a power spectrum plot. + +procedure sp_psplot (rv, dtype, where, rinpt, pldata, title, x_lbl, y_lbl, + x1, x2, npts, fnpts) + +pointer rv #I RV struct pointer +int dtype #I Data type to plot +int where #I Where to plot the data +real rinpt[npts] #I Input plot array +pointer pldata #O Output plot array +pointer title #O Plot title pointer +pointer x_lbl #O Plot x label pointer +pointer y_lbl #O Plot y label pointer +real x1, x2 #O Endpoints +int npts #I Npts in data +int fnpts #O Npts to plot + + +begin + call get_pspec (rv, rinpt, npts, Memr[pldata], fnpts) + fnpts = max (RV_FFTNPTS(rv), fnpts) / 2 + call get_anplot_title (rv, title) + + if (RVP_LOG_SCALE(rv) == YES) + call strcpy ("log(|Power|)", Memc[y_lbl], SZ_FNAME) + else + call strcpy ("Power", Memc[y_lbl], SZ_FNAME) + + switch (where) { + case TOP: + call strcpy ("Frequency", Memc[x_lbl], SZ_FNAME) + x1 = 0.0 + x2 = (real (fnpts) / RVP_FFT_ZOOM(rv)) / (2. * real (fnpts)) + case BOTTOM: + call strcpy ("Wavenumber", Memc[x_lbl], SZ_FNAME) + x1 = 1. + x2 = real (fnpts) / RVP_FFT_ZOOM(rv) + } +end diff --git a/noao/rv/t_fxcor.x b/noao/rv/t_fxcor.x new file mode 100644 index 00000000..a250e8c8 --- /dev/null +++ b/noao/rv/t_fxcor.x @@ -0,0 +1,289 @@ +include <ctype.h> +include <gset.h> +include <imhdr.h> +include <error.h> +include "rvcomdef.h" +include "rvpackage.h" +include "rvflags.h" +include "rvsample.h" + +# T_FXCOR - Task entry point code. Initial procedure just handles the +# aquisition of the images and passes the pointers on to other work routines. + +procedure t_fxcor() + +pointer rv # RV struct pointer +pointer sp, device, root # stack storage +pointer infile, rinfile # image list pointers + +pointer rv_open(), imtopenp() +int rv_imio(), rv_clpars() +int imtlen() +bool interactive, clgetb() +errchk rv_open, rv_clpars, rv_imio + +define error_ 99 + +begin + call smark (sp) + call salloc (device, SZ_FNAME, TY_CHAR) + call salloc (root, SZ_FNAME, TY_CHAR) + + # Get file names of the spectra and open the package structure. + call clgstr ("output", Memc[root], SZ_FNAME) + call clgstr ("graphics", Memc[device], SZ_FNAME) + interactive = clgetb ("interactive") + rv = rv_open (Memc[root], Memc[device], interactive) + + # Do some CLIO to get some more parameters. + infile = imtopenp ("objects") + rinfile = imtopenp ("templates") + + RV_OBJECTS(rv) = infile # various initializations + RV_TEMPLATES(rv) = rinfile + RV_NOBJS(rv) = imtlen (infile) + RV_NTEMPS(rv) = imtlen (rinfile) + RV_RECORD(rv) = 0 + RV_TEMPNUM(rv) = 1 + RV_IMNUM(rv) = 1 + if (rv_clpars(rv) == ERR_READ) + goto error_ + + # Read the images and let's get started + RV_TEMPNUM(rv) = 1 + RV_OAPNUM(rv) = RV_APNUM(rv) + RV_RAPNUM(rv) = RV_APNUM(rv) + if (rv_imio(rv,infile,rinfile) == ERR_READ) + goto error_ + + # Open the graphics and gtools pointers + if (RV_GP(rv) == NULL) + call init_gp (rv, interactive, DEVICE(rv)) + + if (RV_INTERACTIVE(rv) == YES) { + RV_GTYPE(rv) = CORRELATION_PLOT + call rv_cursor (rv, infile, rinfile) + } else + call rv_batch (rv, infile, rinfile) + +error_ call imtclose (RV_OBJECTS(rv)) # close list pointers + call imtclose (RV_TEMPLATES(rv)) + call rv_close (rv) # free the structure + call flush (STDOUT) + call sfree (sp) +end + + +# RV_CLPARS - Get the parameters from the par file. + +int procedure rv_clpars (rv) + +pointer rv # RV struct pointer + +pointer sp, func, ap, cont, rb, filt, vb, ccf, obs +int code +bool clgetb() +real clgetr(), obsgetr() +pointer obsopen() +int rv_apnum_range(), rv_mask_regions(), rv_chk_filter(), cod_verbose() +int cod_fitfunc(), cod_which(), btoi(), cod_ccftype(), cod_rebin() + +errchk obsopen, rv_apnum_range, obsgetr + +begin + call smark (sp) + call salloc (ccf, SZ_FNAME, TY_CHAR) + call salloc (cont, SZ_FNAME, TY_CHAR) + call salloc (rb, SZ_FNAME, TY_CHAR) + call salloc (filt, SZ_FNAME, TY_CHAR) + call salloc (func, SZ_FNAME, TY_CHAR) + call salloc (ap, SZ_FNAME, TY_CHAR) + call salloc (vb, SZ_FNAME, TY_CHAR) + call salloc (obs, SZ_FNAME, TY_CHAR) + + code = OK + RV_APODIZE(rv) = clgetr ("apodize") + RV_AUTOWRITE(rv) = btoi (clgetb("autowrite")) + RV_AUTODRAW(rv) = btoi (clgetb("autodraw")) + RV_BACKGROUND(rv) = clgetr ("background") + RV_FITHGHT(rv) = clgetr ("height") + RV_FITWIDTH(rv) = clgetr ("width") + RV_IMUPDATE(rv) = btoi (clgetb ("imupdate")) + RV_MINWIDTH(rv) = clgetr ("minwidth") + RV_MAXWIDTH(rv) = clgetr ("maxwidth") + RV_PEAK(rv) = btoi (clgetb("peak")) + RV_PIXCORR(rv) = btoi (clgetb("pixcorr")) + RV_WEIGHTS(rv) = clgetr ("weights") + RV_WINPAR(rv) = clgetr ("window") + RV_WINCENPAR(rv) = clgetr ("wincenter") + + call clgstr ("ccftype", Memc[ccf], SZ_FNAME) + RV_CCFTYPE(rv) = cod_ccftype (Memc[ccf]) + + call clgstr ("continuum", Memc[cont], SZ_FNAME) + RV_CONTINUUM(rv) = cod_which (Memc[cont]) + + call clgstr ("rebin", Memc[rb], SZ_FNAME) + RV_REBIN(rv) = cod_rebin (Memc[rb]) + + call clgstr ("filter", Memc[filt], SZ_FNAME) + RV_FILTER(rv) = cod_which (Memc[filt]) + if (RV_FILTER(rv) == BOTH || RV_FILTER(rv) == OBJ_ONLY) { + if (rv_chk_filter(rv,OBJECT_SPECTRUM) != OK) + call error (0, "Invalid filter specification.") + } else if (RV_FILTER(rv) == BOTH || RV_FILTER(rv) == TEMP_ONLY) { + if (rv_chk_filter(rv,REFER_SPECTRUM) != OK) + call error (0, "Invalid filter specification.") + } + + call clgstr ("function", Memc[func], SZ_FNAME) + RV_FITFUNC(rv) = cod_fitfunc (Memc[func]) + + call clgstr ("apertures", Memc[ap], SZ_FNAME) + code = rv_apnum_range (rv, Memc[ap]) + + # Get the regions to mask (if any) + if (rv_mask_regions(rv) == ERR) + call rv_errmsg ("Error getting masking regions.") + + # Open observatory database and get the observatory parameters + iferr { + call clgstr ("observatory", Memc[obs], SZ_FNAME) + RV_OBSPTR(rv) = obsopen (Memc[obs]) + } then + call error (0, "Error opening `observatory' database.") + iferr { + RV_ALTITUDE(rv) = obsgetr (RV_OBSPTR(rv), "altitude") + RV_LATITUDE(rv) = obsgetr (RV_OBSPTR(rv), "latitude") + RV_LONGITUDE(rv) = obsgetr (RV_OBSPTR(rv), "longitude") + } then + call error (0, "Error getting observatory parameters.") + + # Now get the filter pset information + call filt_get_pars (rv) + + # Parse the verbose parameter + call clgstr ("verbose", Memc[vb], SZ_FNAME) + RV_VERBOSE(rv) = cod_verbose (Memc[vb]) + if (RV_VERBOSE(rv) == ERR) { + call error (0, + "`verbose' must be one of `short|long|nogki|nolog|txtonly'") + } + + # Check for a debug session + if (RV_APODIZE(rv) == 0.116) + call op_debug (rv) + + call sfree (sp) + return (code) +end + + +# RV_MASK_REGIONS - Decode the sample regions string. + +int procedure rv_mask_regions (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf1, buf2 + +int rv_load_sample() +bool streq() + +errchk samp_open + +begin + call smark (sp) + call salloc (buf1, SZ_LINE, TY_CHAR); call aclrs (Memc[buf1], SZ_LINE) + call salloc (buf2, SZ_LINE, TY_CHAR); call aclrs (Memc[buf2], SZ_LINE) + + call clgstr("osample", Memc[buf1], SZ_LINE) + call clgstr("rsample", Memc[buf2], SZ_LINE) + + # Parse the object parameter. We also allocate the sample + # structure here since this routine isn't called anywhere else. + iferr (call samp_open (RV_OSAMPLE(rv))) + call error (0, "Error allocating object sample structure.") + SR_IMTYPE(RV_OSAMPLE(rv)) = OBJECT_SPECTRUM + SR_MODIFY(RV_OSAMPLE(rv)) = NO + SR_PARENT(RV_OSAMPLE(rv)) = rv + SR_COUNT(RV_OSAMPLE(rv)) = 0 + if (streq(Memc[buf1],"") || streq(Memc[buf1]," ")) { + call error (0, "`osample' parameter specified as a NULL string") + } else if (streq(Memc[buf1], "*")) { + ORCOUNT(rv) = ALL_SPECTRUM + } else { + if (rv_load_sample(RV_OSAMPLE(rv), Memc[buf1]) == ERR) { + call sfree (sp) + return (ERR) + } + } + + # Parse the template sample parameter. + iferr (call samp_open (RV_RSAMPLE(rv))) + call error (0, "Error allocating template sample structure.") + SR_IMTYPE(RV_RSAMPLE(rv)) = REFER_SPECTRUM + SR_MODIFY(RV_RSAMPLE(rv)) = NO + SR_PARENT(RV_RSAMPLE(rv)) = rv + SR_COUNT(RV_RSAMPLE(rv)) = 0 + if (streq(Memc[buf2],"") || streq(Memc[buf2]," ")) { + call error (0, "`rsample' parameter specified as a NULL string") + } else if (streq(Memc[buf2], "*")) { + RRCOUNT(rv) = ALL_SPECTRUM + } else { + if (rv_load_sample(RV_RSAMPLE(rv), Memc[buf2]) == ERR) { + call sfree (sp) + return (ERR) + } + } + + call sfree (sp) + return (OK) +end + + +# RV_IMIO - Do the initial image io for the RVXCOR task. Process all of +# the template spectra and read the first object spectrum. + +int procedure rv_imio (rv, infile, rinfile) + +pointer rv #I RV struct pointer +pointer infile #I Object list input file +pointer rinfile #I Template list input file + +pointer sp, fname +int rv_getim(), imtgetim() +int read_template_list() +errchk rv_getim, read_template_list + +define error_ 99 + +begin + + call smark (sp) + call salloc (fname, SZ_FNAME, TY_CHAR) + + # Get the first input image. + if (infile != NULL) { + if (imtgetim (infile,Memc[fname],SZ_FNAME) == EOF) { + call rv_errmsg ("No input object images in list.") + goto error_ + } + } + + # Now read in the first OBJECT spectrum. + if (rv_getim (rv, Memc[fname], OBJECT_SPECTRUM, INDEF, INDEF, + INDEFI) == ERR_READ) + goto error_ + + # Read in the template data. + # First get all of the template spectra. + if (read_template_list (rv, rinfile) == ERR_READ) + goto error_ + + call sfree (sp) + return (OK) + +error_ call sfree (sp) + return (ERR_READ) +end diff --git a/noao/rv/titles.x b/noao/rv/titles.x new file mode 100644 index 00000000..5b873757 --- /dev/null +++ b/noao/rv/titles.x @@ -0,0 +1,110 @@ +include <gset.h> +include "rvpackage.h" +include "rvflags.h" + +# GET_PLOT_TITLE - Create a title string for the plot + +procedure get_plot_title (rv, title, npts) + +pointer rv #I RV struct pointer +pointer title #I Preallocated pointer to str +int npts #I Npts in data + +pointer system_id, sp + +begin + # Do the silly title string + if (RV_WHERE(rv) == BOTTOM && RV_DCFLAG(rv) == -1) { + call strcpy ("Pixel Correlation - No velocities will be computed.", + Memc[title], SZ_LINE) + + } else if (RV_WHERE(rv) == TOP) { + call smark (sp) + call salloc (system_id, SZ_LINE, TY_CHAR) + + call sysid (Memc[system_id], SZ_LINE) + + call sprintf (Memc[title], 4*SZ_LINE, + "%s\nObject='%s' Reference='%s'\nStar='%s' Temp='%s' npts=%d aperture=%d") + call pargstr (Memc[system_id]) + call pargstr (IMAGE(rv)) + call pargstr (RIMAGE(rv)) + call pargstr (OBJNAME(rv)) + call pargstr (TEMPNAME(rv)) + call pargi (npts) + call pargi (RV_APNUM(rv)) + call sfree (sp) + + } else # No title string + call strcpy ("", Memc[title], SZ_LINE) +end + + +# NPLOT_TITLE - Create a plot title for the normalized data + +procedure nplot_title (rv, pltype, where, title) + +pointer rv #I RV struct pointer +int pltype #I Type of spectrum being drawn +int where #I Where will plot be drawn +char title[ARB] #O title string created + +pointer sp, system_id, buf + +begin + call smark (sp) + call salloc (system_id, SZ_LINE, TY_CHAR) + call salloc (buf, 4*SZ_LINE, TY_CHAR) + + if (where == TOP) { + call sysid (Memc[system_id], SZ_LINE) # Do the sys title + call strcpy (Memc[system_id], title, SZ_LINE) + call strcat ("\n", title, SZ_LINE) + } else + call strcpy ("", title, SZ_LINE) + + if (pltype == OBJECT_SPECTRUM) { + call sprintf (Memc[buf], 2*SZ_LINE, + "Normalization of '%s' Aperture # = %d") + call pargstr (IMAGE(rv)) + call pargi (RV_APNUM(rv)) + } else if (pltype == REFER_SPECTRUM) { + call sprintf (Memc[buf], 2*SZ_LINE, + "Normalization of '%s' Template # = %d") + call pargstr (RIMAGE(rv)) + call pargi (RV_TEMPNUM(rv)) + } + call strcat (Memc[buf], title, 3*SZ_LINE) + + call sfree (sp) +end + + +# GET_ANPLOT_TITLE - Get the title string for an antisymmetric noise plot + +procedure get_anplot_title (rv, title) + +pointer rv #I RV struct pointer +pointer title #U Pre-allocated title string + +pointer system_id, sp + +begin + call smark (sp) + call salloc (system_id, SZ_LINE, TY_CHAR) + + # Do the silly title string + call sysid (Memc[system_id], SZ_LINE) + + call sprintf (Memc[title], 3*SZ_LINE, +"%s\nObject='%s' Temp='%s' npts=%d aperture=%d\nStar = '%s' Template = '%s'") + call pargstr (Memc[system_id]) + call pargstr (IMAGE(rv)) + call pargstr (RIMAGE(rv)) + call pargi (RV_CCFNPTS(rv)) + call pargi (RV_APNUM(rv)) + call pargstr (OBJNAME(rv)) + call pargstr (TEMPNAME(rv)) + + call sfree (sp) +end diff --git a/noao/rv/wrtccf.x b/noao/rv/wrtccf.x new file mode 100644 index 00000000..bbf09a8e --- /dev/null +++ b/noao/rv/wrtccf.x @@ -0,0 +1,184 @@ +include <imhdr.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcont.h" +include "rvfilter.h" + +# WRITE_CCF - Write the CCF image to disk. + +procedure write_ccf (rv) + +pointer rv #I RV struct pointer + +pointer sp, bp +int imaccess(), access() +int stat, scan() +bool streq() + +define err_ 99 +define loop_ 98 + +begin + call smark (sp) + call salloc (bp, SZ_FNAME, TY_CHAR) + + if (RV_CCFFILE(rv) == NULL) { + call malloc (RV_CCFFILE(rv), SZ_FNAME, TY_CHAR) + Memc[RV_CCFFILE(rv)] = EOS + } + + call gargstr (Memc[bp], SZ_FNAME) + if (Memc[bp] != EOS) + call strcpy (Memc[bp], Memc[RV_CCFFILE(rv)], SZ_FNAME) + else { +loop_ call printf ("Output filename (%s): ") + call pargstr (Memc[RV_CCFFILE(rv)]) + call flush (STDOUT) + stat = scan () + call gargstr (Memc[bp], SZ_FNAME) + if (Memc[bp] != EOS && Memc[bp] != '\n') + call strcpy (Memc[bp], Memc[RV_CCFFILE(rv)], SZ_FNAME) + else if (streq("",Memc[RV_CCFFILE(rv)]) || + streq(" ",Memc[RV_CCFFILE(rv)])) + goto loop_ + } + + if (RV_CCFTYPE(rv) == OUTPUT_TEXT) { + if (access (Memc[RV_CCFFILE(rv)], 0, 0) == YES) { + call printf ("Warning: File `%s' already exists.\n") + call pargstr (Memc[RV_CCFFILE(rv)]) + call flush (STDOUT) + call tsleep (2) + goto loop_ + } + call wrt_ccf_text(rv) + + } else if (RV_CCFTYPE(rv) == OUTPUT_IMAGE) { + if (imaccess(Memc[RV_CCFFILE(rv)], 0) == YES) { + call printf ("Warning: Image `%s' already exists.\n") + call pargstr (Memc[RV_CCFFILE(rv)]) + call flush (STDOUT) + call tsleep (2) + goto loop_ + } + call wrt_ccf_image(rv) + } + +err_ call sfree (sp) +end + + +# WRT_CCF_IMAGE - Write the ccf as an output image with appropriate header +# information. + +procedure wrt_ccf_image (rv) + +pointer rv #I RV struct pointer + +pointer sp, x, im, buf, bp + +pointer immap(), impl1r() +double rv_shift2vel() +errchk immap, impl1r + +define err_ 99 + +begin + call smark (sp) + call salloc (x, RV_CCFNPTS(rv), TY_REAL) + call salloc (bp, SZ_FNAME, TY_CHAR) + + # Open the image + iferr (im = immap(Memc[RV_CCFFILE(rv)], NEW_IMAGE, 2880)) { + call rv_errmsg ("Error opening ccf output image '%s'.") + call pargstr (Memc[RV_CCFFILE(rv)]) + goto err_ + } + + # Set up the image parameters + IM_PIXTYPE(im) = TY_REAL + IM_NDIM(im) = 1 + IM_LEN(im,1) = RV_CCFNPTS(rv) + call sprintf (IM_TITLE(im), SZ_IMTITLE, "Correlation Function") + + # Now dump the data into the image + buf = impl1r (im) + call amovr (WRKPIXY(rv,1), Memr[buf], RV_CCFNPTS(rv)) + + # Add image header information + call imastr (im, "object", IMAGE(rv)) + call imastr (im, "template", RIMAGE(rv)) + call imaddi (im, "npts", RV_CCFNPTS(rv)) + if (RV_DCFLAG(rv) != -1) { + call imaddr (im, "crval1", + real(rv_shift2vel(rv,real(-(RV_CCFNPTS(rv)/2))))) + call imaddr (im, "cdelt1", RV_DELTAV(rv)) + } else { + call imaddr (im, "crval1", real(-RV_CCFNPTS(rv))/2.) + call imaddr (im, "cdelt1", 1.) + } + call imaddi (im, "crpix1", 1) + call imastr (im, "ctype1", "velocity") + call imastr (im, "cunit1", "km/s") + call nam_filtype (rv, Memc[bp]) + call imastr (im, "filtype", Memc[bp]) + call imaddi (im, "cuton", RVF_CUTON(rv)) + call imaddi (im, "cutoff", RVF_CUTOFF(rv)) + call imaddi (im, "fullon", RVF_FULLON(rv)) + call imaddi (im, "fulloff", RVF_FULLOFF(rv)) + + call imunmap (im) +err_ call sfree (sp) +end + + +# WRT_CCF_TEXT - Write out the ccf to a text file. + +procedure wrt_ccf_text (rv) + +pointer rv #I RV struct pointer + +pointer fd, sp, x +int i, j, npts + +pointer open() +double rv_shift2vel() +errchk open + +begin + # Open the text file + iferr (fd=open(Memc[RV_CCFFILE(rv)], NEW_FILE, TEXT_FILE)) { + call rv_errmsg ("Error opening ccf output file `%s'.") + call pargstr (Memc[RV_CCFFILE(rv)]) + return + } + + npts = RV_CCFNPTS(rv) + + call smark (sp) + call salloc (x, npts, TY_REAL) + + # Sret up X-axis + if (RV_DCFLAG(rv) != -1) { + do i = 1, npts + Memr[x+i-1] = real (rv_shift2vel(rv,WRKPIXX(rv,i))) + + } else { + i = - (RV_CCFNPTS(rv) / 2) + do j = 1, npts { + Memr[x+j-1] = real (i) + i = i + 1 + } + } + + # Write it out + do i = 1, npts { + call fprintf (fd, "%.1f %f\n") + call pargr (Memr[x+i-1]) + call pargr (WRKPIXY(rv,i)) + } + call flush (fd) + + call close (fd) + call sfree (sp) +end diff --git a/noao/rv/x_rv.x b/noao/rv/x_rv.x new file mode 100644 index 00000000..3c503a56 --- /dev/null +++ b/noao/rv/x_rv.x @@ -0,0 +1,3 @@ +task fxcor = t_fxcor, + rvidlines = t_rvidlines, + rvreidlines = t_rvreidlines diff --git a/noao/rv/zzdebug.x b/noao/rv/zzdebug.x new file mode 100644 index 00000000..a8ae9656 --- /dev/null +++ b/noao/rv/zzdebug.x @@ -0,0 +1,569 @@ +include <error.h> +include <gio.h> +include <gset.h> +include "rvpackage.h" +include "rvflags.h" +include "rvcomdef.h" + +.help debugging +.nf ___________________________________________________________________________ +RV_DEBUG - Debugging facility. + + A debugging facility has been set up in the RV package that is des- +igned to be hidden from ordinary users. Several layers of debugging are pro- +vided, to write info on various operations of the package. These layers are +defined as follows: + + Level: Action: + ------ ------- + 0 Simple procedure trace + 1 Data cache and flag output + 2 CCF and line fitting output + 3 Velocity computation and correction output + 4 FFT information + +These layers are set up such that (e.g.) a level 3 debug flag will include all +information up to and including level 3 output. + +.endhelp _____________________________________________________________________ + + +# RV_DEBUG - Debugging utility commands. + +procedure rv_debug (rv, cmdstr) + +pointer rv #I RV struct pointer +char cmdstr[SZ_LINE] #I Command line + +pointer sp, cmd, buf +int strdic() + +begin + call smark (sp) + call salloc (cmd, SZ_LINE, TY_CHAR) + call salloc (buf, SZ_LINE, TY_CHAR) + + call sscan (cmdstr) + call gargwrd (Memc[cmd], SZ_LINE) + + # Unpack the keyword from the string and look it up in the + # dictionary. Switch on command and call the appropriate routines. + switch (strdic(Memc[cmd], Memc[cmd], SZ_FNAME, DEBUG_KEYWORDS)) { + case DEBUG_DEBUG: + # Toggle the debugging flag + call cmd_dbg_debug (rv, NULL) + + case DEBUG_D_ON: + # Toggle the debugging flag + call cmd_dbg_debug (rv, YES) + + case DEBUG_D_OFF: + # Toggle the debugging flag + call cmd_dbg_debug (rv, NO) + + case DEBUG_FILE: + # Set the debug file name for output + call cmd_dbg_file (rv) + + case DEBUG_LEVEL: + # Set the debug level for output + call cmd_dbg_level (rv) + + case DEBUG_OTHER: + # Compare other algorithims? + call cmd_dbg_other (rv) + + default: + call rv_errmsg ("rv_debug: invalid case label.") + } + + call sfree (sp) +end + + +procedure cmd_dbg_file (rv) + +pointer rv #I RV struct pointer + +pointer sp, buf, open() +errchk open + +begin + call smark (sp) + call salloc (buf, SZ_LINE, TY_CHAR) + + call gargstr (Memc[buf], SZ_FNAME) + if (Memc[buf] != EOS) { + call realloc (DBG_FNAME(rv), SZ_FNAME, TY_CHAR) + call strcpy (Memc[buf+1], DEBUG_FNAME(rv), SZ_FNAME) + if (DBG_FD(rv) != NULL && DBG_FD(rv) != STDOUT) + call close (DBG_FD(rv)) + iferr (DBG_FD(rv) = open (DEBUG_FNAME(rv), APPEND, TEXT_FILE)) + call error (0, "Error opening debug file.") + call dbg_init (rv, DBG_FD(rv)) + + } else { + call printf ("Debugging filename = '%s'\n") + if (DBG_FNAME(rv) == NULL) + call pargstr ("") + else + call pargstr (DEBUG_FNAME(rv)) + } + + call sfree (sp) +end + + +procedure cmd_dbg_debug (rv, flag) + +pointer rv #I RV struct pointer +int flag #I Debugging state + +bool bval, itob() +int nscan(), btoi() + +begin + switch (flag) { + case YES: + DBG_DEBUG(rv) = YES + if (DBG_FD(rv) == NULL) + DBG_FD(rv) = STDOUT + case NO: + DBG_DEBUG(rv) = NO + default: + call gargb (bval) + if (nscan() == 2) { + DBG_DEBUG(rv) = btoi (bval) + } else { + call printf ("Debugging flag = %b\n") + call pargb (itob(DBG_DEBUG(rv))) + } + } +end + + +procedure cmd_dbg_level (rv) + +pointer rv #I RV struct pointer + +int nscan() +int ival + +begin + call gargi (ival) + if (nscan() == 2) { + DBG_LEVEL(rv) = ival + } else { + call printf ("Debugging level = %d\n") + call pargi (DBG_LEVEL(rv)) + } +end + + +procedure cmd_dbg_other (rv) + +pointer rv #I RV struct pointer + +int nscan() +int ival + +begin + call gargi (ival) + if (nscan() == 2) { + DBG_OTHER(rv) = ival + } else { + call printf ("Debugging other = %b\n") + call pargi (DBG_OTHER(rv)) + } +end + + +procedure d_printf (fd, str) + +pointer fd # Debug file descriptor +char str[SZ_LINE] # Format string + +begin + if (fd == NULL) + return + else if (fd == STDOUT) + call printf (str) + else if (fd == STDERR) + call eprintf (str) + else + call fprintf (fd, str) + + call flush (fd) +end + + +procedure d_flush (fd) + +pointer fd + +begin + if (fd != NULL) + call flush (fd) +end + + +procedure dbg_init (rv, fd) + +pointer rv, fd + +pointer sp, system_id + +begin + if (fd == NULL) + return + + call smark (sp) + call salloc (system_id, SZ_LINE, TY_CHAR) + + call sysid (Memc[system_id], SZ_LINE) + call d_printf (fd, "\n\t-->%s<--\n\n") + call pargstr (Memc[system_id]) + + call d_printf (fd, "Task: `fxcor'\n\n") + call d_printf (fd, "\tObject = '%s'/%4d\t\tTemplate = '%s'/%4d\n") + call pargstr (IMAGE(rv)); call pargi (RV_NPTS(rv)) + call pargstr (RIMAGE(rv)); call pargi (RV_RNPTS(rv)) + call d_printf (fd, "%12t=> '%s'%42t=> '%s'\n\n") + call pargstr (OBJNAME(rv)); call pargstr (TEMPNAME(rv)) + + call flush (fd) + call sfree (sp) +end + + +# OP_DEBUG - Read the _RVDEBUG parameters. + +procedure op_debug (rv) + +pointer rv #I RV struct pointer + +pointer db, sp, bp, ks +pointer clopset(), open() +bool clgpsetb(), streq() +int clgpseti(), btoi() +errchk clopset, open + +begin + if (DBG_FD(rv) != NULL && DBG_FD(rv) != STDOUT && DBG_FD(rv) != STDERR) + return + + call smark (sp) + call salloc (bp, SZ_FNAME, TY_CHAR) + call salloc (ks, SZ_FNAME, TY_CHAR) + + db = clopset ("rvdebug") + + DBG_DEBUG(rv) = btoi (clgpsetb(db, "debug")) + DBG_LEVEL(rv) = clgpseti (db, "level") + DBG_OTHER(rv) = clgpseti(db, "other") + DBG_QUICK(rv) = btoi (clgpsetb(db, "quickdraw")) + + call clgpset (db, "file", Memc[bp], SZ_LINE) + call clgpset (db, "keystroke", Memc[ks], SZ_LINE) + DBG_KEYSTROKE(rv) = Memc[ks] + if (!streq(Memc[bp],"") && !streq(Memc[bp]," ")) { + call realloc (DBG_FNAME(rv), SZ_FNAME, TY_CHAR) + call strcpy (Memc[bp], DEBUG_FNAME(rv), SZ_FNAME) + iferr (DBG_FD(rv) = open (DEBUG_FNAME(rv), APPEND, TEXT_FILE)) + call error (0, "Error opening debug file.") + if (DBG_DEBUG(rv) == YES) + call dbg_init (rv, DBG_FD(rv)) + } else if (streq("STDOUT", Memc[bp])) + DBG_FD(rv) = STDOUT + else + DBG_FD(rv) = NULL + + call clcpset (db) + call sfree (sp) +end + + +procedure zz_pause(str) +char str[ARB] + +real x, y +int wcs, key, stat +char command[SZ_FNAME] +int clgcur() + +begin + call eprintf("%s") + call pargstr(str) + call flush (STDERR) + stat = clgcur("cursor", x, y, wcs, key, command, SZ_FNAME) + call eprintf(" \n") + + if ('x' == key || 'q' == key || 'I' == key) + call error (0,"Quitting") + + return +end + + +procedure zz_dump1r(fname, data, npts) +char fname[SZ_FNAME] +real data[ARB] +int npts + +pointer fd +int i, open() +errchk open + +begin + fd = open(fname, WRITE_ONLY, TEXT_FILE) + + do i = 1, npts { + call fprintf(fd, "%f %f\n") + call pargr(real(i)) + call pargr(data[i]) + } + call flush(fd) + call close(fd) + return +end + + +procedure zz_dump1rx (fname, data, npts, x1, xinc) +char fname[SZ_FNAME] +real data[ARB] +int npts +real x1, xinc + +pointer fd +int i, open() +errchk open + +begin + fd = open(fname, WRITE_ONLY, TEXT_FILE) + + do i = 1, npts { + call fprintf(fd, "%f %f\n") + call pargr(x1+(i-1)*xinc) + call pargr(data[i]) + } + call flush(fd) + call close(fd) + return +end + + +procedure zz_dump1i(fname, data, npts) +char fname[SZ_FNAME] +int data[ARB] +int npts + +pointer fd +int i, open() +errchk open + +begin + fd = open(fname, WRITE_ONLY, TEXT_FILE) + + do i = 1, npts { + call fprintf(fd, "%d %d\n") + call pargi(i) + call pargi(data[i]) + } + call flush(fd) + call close(fd) + return +end + + +procedure zz_pvec (gp, y, npts, lo, hi, title) + +pointer gp +real y[npts] +int npts +real lo, hi +char title[SZ_LINE] + +real x1, x2, y1, y2 + +begin + if (gp == NULL) + return + + call gclear (gp) + call gascale (gp, y, npts, 2) + call ggwind (gp, x1, x2, y1, y2) + call gswind (gp, lo-(hi*.1), hi+(hi*.1), y1-(y2*.1), y2+(y2*.1)) + call glabax (gp, title, "pixel", "intensity") + call gvline (gp, y, npts, lo, hi) + + call zz_pause("") +end + + +procedure zz_pvecm (gp, y, npts, lo, hi, title) + +pointer gp +real y[npts] +int npts +real lo, hi +char title[SZ_LINE] + +real x1, x2, y1, y2 + +begin + if (gp == NULL) + return + + call gclear (gp) + call gascale (gp, y, npts, 2) + call ggwind (gp, x1, x2, y1, y2) + call gswind (gp, lo-(hi*.1), hi+(hi*.1), y1-(y2*.1), y2+(y2*.1)) + call glabax (gp, title, "pixel", "intensity") + call gvline (gp, y, npts, lo, hi) +end + + +procedure zz_print_struct (rv) + +pointer rv + +begin + call zz_prstruct1 (rv) + call zz_prstruct2 (rv) +end + + +procedure zz_prstruct1 (rv) + +pointer rv + +begin + call eprintf ("RV_OPIXX = %d\n") ; call pargi(RV_OPIXX(rv)) + call eprintf ("RV_OPIXY = %d\n") ; call pargi(RV_OPIXY(rv)) + call eprintf ("RV_RPIXX = %d\n") ; call pargi(RV_RPIXX(rv)) + call eprintf ("RV_RPIXY = %d\n") ; call pargi(RV_RPIXY(rv)) + call eprintf ("RV_WKPIXX = %d\n") ; call pargi(RV_WKPIXX(rv)) + call eprintf ("RV_WKPIXY = %d\n") ; call pargi(RV_WKPIXY(rv)) + call eprintf ("RV_APODIZE = %g\n") ; call pargr(RV_APODIZE(rv)) + call eprintf ("RV_AUTOWRITE = %d\n") ; call pargi(RV_AUTOWRITE(rv)) + call eprintf ("RV_AUTODRAW = %d\n") ; call pargi(RV_AUTODRAW(rv)) + call eprintf ("RV_CONTINUUM = %d\n") ; call pargi(RV_CONTINUUM(rv)) + call eprintf ("RV_FILTER = %d\n") ; call pargi(RV_FILTER(rv)) + call eprintf ("RV_INTERACTIVE = %d\n") ; call pargi(RV_INTERACTIVE(rv)) + call eprintf ("RV_PIXCORR = %d\n") ; call pargi(RV_PIXCORR(rv)) + call eprintf ("RV_INTERP = %d\n") ; call pargi(RV_INTERP(rv)) + call eprintf ("RV_BACKGROUND = %g\n") ; call pargr(RV_BACKGROUND(rv)) + call eprintf ("RV_FITDONE = %d\n") ; call pargi(RV_FITDONE(rv)) + call eprintf ("RV_FITFUNC = %d\n") ; call pargi(RV_FITFUNC(rv)) + call eprintf ("RV_FITHGHT = %g\n") ; call pargr(RV_FITHGHT(rv)) + call eprintf ("RV_FITWIDTH = %g\n") ; call pargr(RV_FITWIDTH(rv)) + call eprintf ("RV_ISHIFT = %d\n") ; call pargi(RV_ISHIFT(rv)) + call eprintf ("RV_ISTART = %d\n") ; call pargi(RV_ISTART(rv)) + call eprintf ("RV_IEND = %d\n") ; call pargi(RV_IEND(rv)) + call eprintf ("RV_MINWIDTH = %g\n") ; call pargr(RV_MINWIDTH(rv)) + call eprintf ("RV_MAXWIDTH = %g\n") ; call pargr(RV_MAXWIDTH(rv)) + call eprintf ("RV_MAXITERS = %d\n") ; call pargi(RV_MAXITERS(rv)) + call eprintf ("RV_PEAK = %d\n") ; call pargi(RV_PEAK(rv)) + call eprintf ("RV_TOLERANCE = %g\n") ; call pargr(RV_TOLERANCE(rv)) + call eprintf ("RV_WEIGHTS = %g\n") ; call pargr(RV_WEIGHTS(rv)) + call eprintf ("RV_WINPAR = %g\n") ; call pargr(RV_WINPAR(rv)) + call eprintf ("RV_WINCENPAR = %g\n") ; call pargr(RV_WINCENPAR(rv)) + call eprintf ("RV_WINDOW = %d\n") ; call pargi(RV_WINDOW(rv)) + call eprintf ("RV_WINCENTER = %d\n") ; call pargi(RV_WINCENTER(rv)) + call eprintf ("RV_WINL = %d\n") ; call pargi(RV_WINL(rv)) + call eprintf ("RV_WINR = %d\n") ; call pargi(RV_WINR(rv)) + call eprintf ("RV_APNUM = %d\n") ; call pargi(RV_APNUM(rv)) + call eprintf ("RV_CCFNPTS = %d\n") ; call pargi(RV_CCFNPTS(rv)) + call eprintf ("RV_CURAPNUM = %d\n") ; call pargi(RV_CURAPNUM(rv)) + call eprintf ("RV_DI1 = %d\n") ; call pargi(RV_DI1(rv)) + call eprintf ("RV_DSCALE = %g\n") ; call pargr(RV_DSCALE(rv)) + call eprintf ("RV_DSLOPE = %g\n") ; call pargr(RV_DSLOPE(rv)) + call eprintf ("RV_DX1 = %g\n") ; call pargr(RV_DX1(rv)) + call eprintf ("RV_DY1 = %g\n") ; call pargr(RV_DY1(rv)) + call eprintf ("RV_DX2 = %g\n") ; call pargr(RV_DX2(rv)) + call eprintf ("RV_DY2 = %g\n") ; call pargr(RV_DY2(rv)) + call eprintf ("RV_FILL = %d\n") ; call pargi(RV_FILL(rv)) + call eprintf ("RV_FFTNPTS = %d\n") ; call pargi(RV_FFTNPTS(rv)) + call eprintf ("RV_IMNUM = %d\n") ; call pargi(RV_IMNUM(rv)) + call eprintf ("RV_IMUPDATE = %d\n") ; call pargi(RV_IMUPDATE(rv)) + call eprintf ("RV_IS_DOUBLE = %d\n") ; call pargi(RV_IS_DOUBLE(rv)) + call eprintf ("RV_MODES = %d\n") ; call pargi(RV_MODES(rv)) + call eprintf ("RV_NOBJS = %d\n") ; call pargi(RV_NOBJS(rv)) + call eprintf ("RV_NTEMPS = %d\n") ; call pargi(RV_NTEMPS(rv)) + call eprintf ("RV_NFITP = %d\n") ; call pargi(RV_NFITP(rv)) + call eprintf ("RV_NPTS = %d\n") ; call pargi(RV_NPTS(rv)) + call eprintf ("RV_NSHIFTS = %d\n") ; call pargi(RV_NSHIFTS(rv)) + call eprintf ("RV_NUMAPS = %d\n") ; call pargi(RV_NUMAPS(rv)) + call eprintf ("RV_OAPNUM = %d\n") ; call pargi(RV_OAPNUM(rv)) + call eprintf ("RV_REBIN = %d\n") ; call pargi(RV_REBIN(rv)) + call eprintf ("RV_RNPTS = %d\n") ; call pargi(RV_RNPTS(rv)) + call eprintf ("RV_RAPNUM = %d\n") ; call pargi(RV_RAPNUM(rv)) + call eprintf ("RV_TEMPNUM = %d\n") ; call pargi(RV_TEMPNUM(rv)) + call eprintf ("RV_UPDATE = %d\n") ; call pargi(RV_UPDATE(rv)) + call eprintf ("RV_VERBOSE = %d\n") ; call pargi(RV_VERBOSE(rv)) + call eprintf ("RV_ZTHRESH = %g\n") ; call pargr(RV_ZTHRESH(rv)) + call eprintf ("RV_OBSPTR = %d\n") ; call pargi(RV_OBSPTR(rv)) + call eprintf ("RV_ALTITUDE = %g\n") ; call pargr(RV_ALTITUDE(rv)) + call eprintf ("RV_LATITUDE = %g\n") ; call pargr(RV_LATITUDE(rv)) + call eprintf ("RV_LONGITUDE = %g\n") ; call pargr(RV_LONGITUDE(rv)) + call eprintf ("RV_NEWGRAPH = %d\n") ; call pargi(RV_NEWGRAPH(rv)) + call eprintf ("RV_RECORD = %d\n") ; call pargi(RV_RECORD(rv)) + call eprintf ("RV_TXFD = %d\n") ; call pargi(RV_TXFD(rv)) + call eprintf ("RV_GRFD = %d\n") ; call pargi(RV_GRFD(rv)) + call eprintf ("RV_VBFD = %d\n") ; call pargi(RV_VBFD(rv)) + call eprintf ("RV_CCFFILE = %d\n") ; call pargi(RV_CCFFILE(rv)) + call eprintf ("RV_CCFTYPE = %d\n") ; call pargi(RV_CCFTYPE(rv)) + call eprintf ("RV_STATLINE = %d\n") ; call pargi(RV_STATLINE(rv)) + call eprintf ("RV_TEMPCODE = %d\n") ; call pargi(RV_TEMPCODE(rv)) + call eprintf ("RV_TCODE = %d\n") ; call pargi(RV_TCODE(rv)) + call eprintf ("RV_PRINTZ = %d\n") ; call pargi(RV_PRINTZ(rv)) + call eprintf ("RV_DTYPE = %d\n") ; call pargi(RV_DTYPE(rv)) + call eprintf ("RV_GTYPE = %d\n") ; call pargi(RV_GTYPE(rv)) + call eprintf ("RV_RESDONE = %d\n") ; call pargi(RV_RESDONE(rv)) + call eprintf ("RV_SPMKEY = %d\n") ; call pargi(RV_SPMKEY(rv)) + call eprintf ("RV_SPMPLOT = %d\n") ; call pargi(RV_SPMPLOT(rv)) + call eprintf ("RV_WHERE = %d\n") ; call pargi(RV_WHERE(rv)) + call eprintf ("RV_X1 = %g\n") ; call pargr(RV_X1(rv)) + call eprintf ("RV_X2 = %g\n") ; call pargr(RV_X2(rv)) + call eprintf ("RV_Y1 = %g\n") ; call pargr(RV_Y1(rv)) + call eprintf ("RV_Y2 = %g\n") ; call pargr(RV_Y2(rv)) +end + + +procedure zz_prstruct2 (rv) + +pointer rv + +begin + call eprintf ("RV_APPARAM = %d\n") ; call pargi(RV_APPARAM(rv)) + call eprintf ("RV_APLIST = %d\n") ; call pargi(RV_APLIST(rv)) + call eprintf ("RV_CMD = %d\n") ; call pargi(RV_CMD(rv)) + call eprintf ("RV_DCBIAS = %g\n") ; call pargr(RV_DCBIAS(rv)) + call eprintf ("RV_DCFLAG = %d\n") ; call pargi(RV_DCFLAG(rv)) + call eprintf ("RV_DELTAV = %g\n") ; call pargr(RV_DELTAV(rv)) + call eprintf ("RV_DO_CORRECT = %d\n") ; call pargi(RV_DO_CORRECT(rv)) + call eprintf ("RV_OFORMAT = %d\n") ; call pargi(RV_OFORMAT(rv)) + call eprintf ("RV_RFORMAT = %d\n") ; call pargi(RV_RFORMAT(rv)) + call eprintf ("RV_FWHM_Y = %g\n") ; call pargr(RV_FWHM_Y(rv)) + call eprintf ("RV_GLOB_W1 = %g\n") ; call pargr(RV_GLOB_W1(rv)) + call eprintf ("RV_GLOB_W2 = %g\n") ; call pargr(RV_GLOB_W2(rv)) + call eprintf ("RV_NEWXCOR = %d\n") ; call pargi(RV_NEWXCOR(rv)) + call eprintf ("RV_OW0 = %g\n") ; call pargr(RV_OW0(rv)) + call eprintf ("RV_OW2 = %g\n") ; call pargr(RV_OW2(rv)) + call eprintf ("RV_OWPC = %g\n") ; call pargr(RV_OWPC(rv)) + call eprintf ("RV_RW0 = %g\n") ; call pargr(RV_RW0(rv)) + call eprintf ("RV_RW2 = %g\n") ; call pargr(RV_RW2(rv)) + call eprintf ("RV_RWPC = %g\n") ; call pargr(RV_RWPC(rv)) + call eprintf ("RV_DO_REBIN = %d\n") ; call pargi(RV_DO_REBIN(rv)) + call eprintf ("RV_VOBS = %g\n") ; call pargd(RV_VOBS(rv)) + call eprintf ("RV_VCOR = %g\n") ; call pargd(RV_VCOR(rv)) + call eprintf ("RV_ERROR = %g\n") ; call pargd(RV_ERROR(rv)) + call eprintf ("RV_HJD = %g\n") ; call pargd(RV_HJD(rv)) + call eprintf ("RV_MJD_OBS = %g\n") ; call pargd(RV_MJD_OBS(rv)) + call eprintf ("RV_VREL = %g\n") ; call pargr(RV_VREL(rv)) + call eprintf ("RV_R = %g\n") ; call pargr(RV_R(rv)) + call eprintf ("RV_SHIFT = %g\n") ; call pargr(RV_SHIFT(rv)) + call eprintf ("RV_SIGMA = %g\n") ; call pargr(RV_SIGMA(rv)) + call eprintf ("RV_FWHM = %g\n") ; call pargr(RV_FWHM(rv)) + call eprintf ("RV_HEIGHT = %g\n") ; call pargr(RV_HEIGHT(rv)) +end |