aboutsummaryrefslogtreecommitdiff
path: root/noao/digiphot/ptools/pexamine
diff options
context:
space:
mode:
authorJoe Hunkeler <jhunkeler@gmail.com>2015-08-11 16:51:37 -0400
committerJoe Hunkeler <jhunkeler@gmail.com>2015-08-11 16:51:37 -0400
commit40e5a5811c6ffce9b0974e93cdd927cbcf60c157 (patch)
tree4464880c571602d54f6ae114729bf62a89518057 /noao/digiphot/ptools/pexamine
downloadiraf-osx-40e5a5811c6ffce9b0974e93cdd927cbcf60c157.tar.gz
Repatch (from linux) of OSX IRAF
Diffstat (limited to 'noao/digiphot/ptools/pexamine')
-rw-r--r--noao/digiphot/ptools/pexamine/mkpkg21
-rw-r--r--noao/digiphot/ptools/pexamine/pexamine.h115
-rw-r--r--noao/digiphot/ptools/pexamine/pexamine.key146
-rw-r--r--noao/digiphot/ptools/pexamine/ptahgmr.x44
-rw-r--r--noao/digiphot/ptools/pexamine/ptalimr.x35
-rw-r--r--noao/digiphot/ptools/pexamine/ptcolon.x668
-rw-r--r--noao/digiphot/ptools/pexamine/ptdelete.x335
-rw-r--r--noao/digiphot/ptools/pexamine/ptgetphot.x432
-rw-r--r--noao/digiphot/ptools/pexamine/ptimplot.x940
-rw-r--r--noao/digiphot/ptools/pexamine/ptplot.x1462
-rw-r--r--noao/digiphot/ptools/pexamine/ptrddata.x125
-rw-r--r--noao/digiphot/ptools/pexamine/ptsetup.x360
-rw-r--r--noao/digiphot/ptools/pexamine/ptwtfile.x143
-rw-r--r--noao/digiphot/ptools/pexamine/t_pexamine.x188
14 files changed, 5014 insertions, 0 deletions
diff --git a/noao/digiphot/ptools/pexamine/mkpkg b/noao/digiphot/ptools/pexamine/mkpkg
new file mode 100644
index 00000000..b2aa7dd8
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/mkpkg
@@ -0,0 +1,21 @@
+# The mkpkg file for the PEXAMINE task.
+
+$checkout libpkg.a ".."
+$update libpkg.a
+$checkin libpkg.a ".."
+$exit
+
+libpkg.a:
+ ptahgmr.x <mach.h> pexamine.h
+ ptalimr.x <mach.h>
+ ptcolon.x <gset.h> pexamine.h
+ ptdelete.x <gset.h> <mach.h> pexamine.h
+ ptgetphot.x <tbset.h> ../../lib/ptkeysdef.h pexamine.h
+ ptimplot.x <imhdr.h> <math.h> <gset.h> <mach.h>
+ ptplot.x <error.h> <fset.h> <tbset.h> <gset.h> <mach.h> \
+ <ctype.h> ../../lib/ptkeysdef.h pexamine.h
+ ptrddata.x ../../lib/ptkeysdef.h pexamine.h
+ ptsetup.x <error.h> pexamine.h <ctotok.h>
+ ptwtfile.x ../../lib/ptkeysdef.h pexamine.h
+ t_pexamine.x <error.h> <fset.h> pexamine.h
+ ;
diff --git a/noao/digiphot/ptools/pexamine/pexamine.h b/noao/digiphot/ptools/pexamine/pexamine.h
new file mode 100644
index 00000000..138ff1f4
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/pexamine.h
@@ -0,0 +1,115 @@
+# The PEXAMINE structure definitions.
+
+# Define the task termination conditions.
+
+define PX_QUIT 0
+define PX_EXIT 1
+
+# Define the delete indices
+
+define PX_GOOD 0
+define PX_DELETE 1
+define PX_MARK 2
+
+# Define some useful constants.
+
+define PX_SZCOLNAME 19 # the maximum length of a column name
+define PX_MAXNCOLS 20 # the maximum number of columns
+
+# Define the default photometry columns.
+
+define PX_DAOCOLS ",GROUP,ID,XCENTER,YCENTER,MSKY,STDEV,MAG,MERR,NITER,\
+CHI,SHARPNESS,ROUNDNESS"
+define PX_APCOLS ",ID,XCENTER,YCENTER,MSKY,STDEV,MAG,MERR,"
+
+# Define the structure.
+
+define LEN_PXSTRUCT (15 + 10 * PX_SZCOLNAME + 10)
+
+define PX_RNPHOT Memi[$1] # number of req'd photometry columns
+define PX_RNUSER Memi[$1+1] # number of req'd user columns
+define PX_RNCOLS Memi[$1+2] # total number of req'd columns
+define PX_RCOLNAMES Memi[$1+3] # ptr to list of req'd column names
+define PX_NPHOT Memi[$1+4] # number of photometry columns
+define PX_NUSER Memi[$1+5] # number of user columns
+define PX_NCOLS Memi[$1+6] # total number of stored columns
+define PX_COLNAMES Memi[$1+7] # ptr to list of stored column names
+define PX_COLPTRS Memi[$1+8] # ptr to array of stored column pointers
+
+define PX_RXCOLNAME Memc[P2C($1+10)] # the req'd x column
+define PX_RYCOLNAME Memc[P2C($1+10+PX_SZCOLNAME+1)] # the req'd y column
+define PX_XCOLNAME Memc[P2C($1+10+2*PX_SZCOLNAME+2)] # the x column
+define PX_YCOLNAME Memc[P2C($1+10+3*PX_SZCOLNAME+3)] # the y column
+define PX_RXPOSNAME Memc[P2C($1+10+4*PX_SZCOLNAME+4)] # the req'd xp column
+define PX_RYPOSNAME Memc[P2C($1+10+5*PX_SZCOLNAME+5)] # the req'd yp column
+define PX_XPOSNAME Memc[P2C($1+10+6*PX_SZCOLNAME+6)] # the x coord column
+define PX_YPOSNAME Memc[P2C($1+10+7*PX_SZCOLNAME+7)] # the y coord column
+define PX_RHCOLNAME Memc[P2C($1+10+8*PX_SZCOLNAME+8)] # the req'd hgm column
+define PX_HCOLNAME Memc[P2C($1+10+9*PX_SZCOLNAME+9)] # the hgm column
+
+# Define the colon commands arguments
+
+define PX_PCMDS "|photcolumns|usercolumns|xcolumn|ycolumn|hcolumn|xposcolumn|\
+yposcolumn|eparam|unlearn|x1|x2|y1|y2|marker|szmarker|grid|logx|logy|box|\
+ticklabels|majrx|minrx|majry|minry|round|fill|nbins|z1|z2|top_closed|rinner|\
+router|ncolumns|nlines|axes|angh|angv|floor|ceiling|zero|ncontours|interval|\
+nhi|dashpat|label|delete|"
+
+define PX_PCMD_PHOTCOLUMNS 1
+define PX_PCMD_USERCOLUMNS 2
+define PX_PCMD_XCOLUMN 3
+define PX_PCMD_YCOLUMN 4
+define PX_PCMD_HCOLUMN 5
+define PX_PCMD_XPOSCOLUMN 6
+define PX_PCMD_YPOSCOLUMN 7
+define PX_PCMD_EDIT 8
+define PX_PCMD_UNLEARN 9
+define PX_PCMD_X1 10
+define PX_PCMD_X2 11
+define PX_PCMD_Y1 12
+define PX_PCMD_Y2 13
+define PX_PCMD_MARKER 14
+define PX_PCMD_SZMARKER 15
+define PX_PCMD_GRID 16
+define PX_PCMD_LOGX 17
+define PX_PCMD_LOGY 18
+define PX_PCMD_BOX 19
+define PX_PCMD_TICKLABELS 20
+define PX_PCMD_MAJRX 21
+define PX_PCMD_MINRX 22
+define PX_PCMD_MAJRY 23
+define PX_PCMD_MINRY 24
+define PX_PCMD_ROUND 25
+define PX_PCMD_FILL 26
+define PX_PCMD_NBINS 27
+define PX_PCMD_Z1 28
+define PX_PCMD_Z2 29
+define PX_PCMD_TOP_CLOSED 30
+define PX_PCMD_RIN 31
+define PX_PCMD_ROUT 32
+define PX_PCMD_NCOLUMNS 33
+define PX_PCMD_NLINES 34
+define PX_PCMD_AXES 35
+define PX_PCMD_ANGH 36
+define PX_PCMD_ANGV 37
+define PX_PCMD_FLOOR 38
+define PX_PCMD_CEILING 39
+define PX_PCMD_ZERO 40
+define PX_PCMD_NCONTOURS 41
+define PX_PCMD_INTERVAL 42
+define PX_PCMD_NHI 43
+define PX_PCMD_DASHPAT 44
+define PX_PCMD_LABEL 45
+define PX_PCMD_DELETE 46
+
+# Define the plot types
+
+define PX_PLOTTYPES "|xyplot|histplot|radplot|surfplot|cntrplot|"
+
+define PX_XYPLOT 1
+define PX_HISTPLOT 2
+define PX_RADPLOT 3
+define PX_SURFPLOT 4
+define PX_CNTRPLOT 5
+
+define PX_MARKERS "|point|box|plus|cross|circle|hline|vline|diamond|"
diff --git a/noao/digiphot/ptools/pexamine/pexamine.key b/noao/digiphot/ptools/pexamine/pexamine.key
new file mode 100644
index 00000000..892e0542
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/pexamine.key
@@ -0,0 +1,146 @@
+ PEXAMINE Interactive Cursor Keystroke Commands
+
+ Basic Commands
+
+? Print help for the PEXAMINE task
+: PEXAMINE colon commands
+g Activate the graphics cursor
+i Activate the image cursor
+e Exit PEXAMINE and save the edited catalog
+q Quit PEXAMINE and discard the edited catalog
+
+ Data Examining Commands
+
+l List the name, datatype and units for all columns in the catalog
+o Print out the names and values of the stored columns for the
+ object nearest the cursor
+x Replot the current y column versus the current x column
+h Replot the current histogram
+r Plot the radial profile of the object nearest the cursor
+s Plot the surface of the object nearest the cursor
+c Plot the contour plot of the object nearest the cursor
+m Print the data values of the object nearest the cursor
+p Replot the current graph
+
+ Data Editing Commands
+
+z Reinitialize the data by removing all deletions and replot
+d Mark the point nearest the cursor for deletion
+u Undelete the marked point nearest the cursor
+t Toggle between marking points for deletion or undeletion
+( Mark points with X < X (cursor) for deletion or undeletion
+) Mark points with X > X (cursor) for deletion or undeletion
+v Mark points with Y < Y (cursor) for deletion or undeletion
+^ Mark points with Y > Y (cursor) for deletion or undeletion
+b Mark points inside a box for deletion or undeletion
+f Actually delete the marked points and replot
+
+
+ PEXAMINE Interactive Colon Commands
+
+:xcolumn [name] Show/set the X-Y plot X axis quantity
+:ycolumn [name] Show/set the X-Y plot Y axis quantity
+:hcolumn [name] Show/set the histogram plot quantity
+:photcolumns [col1,col2,...] Show/set the list of photometry columns
+:usercolumns [col1,col2,...] Show/set the list of user columns
+:delete [yes/no] Delete or undelete points
+:eparam [x/h/r/s/c] Edit/unlearn the specified plot pset
+ or
+:unlearn
+
+
+ PEXAMINE Interactive X-Y Plotting Commands
+
+:x1 [value] Left world x-coord if not autoscaling
+:x2 [value] Right world x-coord if not autoscaling
+:y1 [value] Lower world y-coord if not autoscaling
+:y2 [value] Upper world y-coord if not autoscaling
+:szmarker [value] Marker size
+:marker [point|box|plus|cross|circle|diamond|hline|vline] Marker type
+:logx [yes/no] Log scale the x axis?
+:logy [yes/no] Log scale the y axis?
+:box [yes/no] Draw box around periphery of window?
+:ticklabels [yes/no] Label tick marks?
+:grid [yes/no] Draw grid lines at major tick marks?
+:majrx [value] Number of major divisions along x axis
+:minrx [value] Number of minor divisions along x axis
+:majry [value] Number of major divisions along y axis
+:minry [value] Number of minor divisions along y axis
+:round [yes/no] Round axes to nice values?
+:fill [yes/no] Fill viewport vs enforce unity aspect ratio?
+
+
+ PEXAMINE Interactive Histogram Plotting Commands
+
+:nbins [value] Number of bins in the histogram
+:z1 [value] Minimum histogram intensity
+:z2 [value] Maximum histogram intensity
+:top_closed [y/n] Include z in the top bin?
+:x1 [value] Left world x-coord if not autoscaling
+:x2 [value] Right world x-coord if not autoscaling
+:y1 [value] Lower world y-coord if not autoscaling
+:y2 [value] Upper world y-coord if not autoscaling
+:logy [yes/no] Log scale the y axis?
+:box [yes/no] Draw box around periphery of window?
+:ticklabels [yes/no] Label tick marks?
+:majrx [value] Number of major divisions along x axis
+:minrx [value] Number of minor divisions along x axis
+:majry [value] Number of major divisions along y axis
+:minry [value] Number of minor divisions along y axis
+:round [yes/no] Round axes to nice values?
+:fill [yes/no] Fill viewport vs enforce unity aspect ratio?
+
+ PEXAMINE Interactive Radial Profile Plotting Commands
+
+:rinner [value] Inner radius of the region to be plotted
+:router [value] Outer radius of the region to be plotted
+:x1 [value] Left world x-coord if not autoscaling
+:x2 [value] Right world x-coord if not autoscaling
+:y1 [value] Lower world y-coord if not autoscaling
+:y2 [value] Upper world y-coord if not autoscaling
+:szmarker [value] Marker size
+:marker [point|box|plus|cross|circle|diamond|hline|vline] Marker type
+:logx [yes/no] Log scale the x axis?
+:logy [yes/no] Log scale the y axis?
+:box [yes/no] Draw box around periphery of window?
+:ticklabels [yes/no] Label tick marks?
+:grid [yes/no] Draw grid lines at major tick marks?
+:majrx [value] Number of major divisions along x axis
+:minrx [value] Number of minor divisions along x axis
+:majry [value] Number of major divisions along y axis
+:minry [value] Number of minor divisions along y axis
+:round [yes/no] Round axes to nice values?
+:fill [yes/no] Fill viewport vs enforce unity aspect ratio?
+
+
+ PEXAMINE Interactive Surface Plotting Commands
+
+:ncolumns [value] Number of columns to be plotted
+:nlines [value] Number of lines to be plotted
+:axes [yes/no] Draw axes?
+:angh [value] Horizontal viewing angle
+:angv [value] Vertical viewing angle
+:floor [value] Minimum value to be plotted
+:ceiling [value] Maximum value to be plotted
+
+
+ PEXAMINE Interactive Contour Plotting Commands
+
+:ncolumns [value] Number of columns to be plotted
+:nlines [value] Number of lines to be plotted
+:floor [value] Minimum value to be plotted
+:ceiling [value] Maximum value to be plotted
+:zero [value] Greyscale value of zero contour
+:ncontours [value] Number of contours to be drawn
+:interval [value] Contour interval
+:nhi [value] Hi/low marking option
+:dashpat [value] Bit pattern for generating dashed lines
+:label [yes/no] Label major contours with their values?
+:box [yes/no] Draw box around periphery of window?
+:ticklabels [yes/no] Label tick marks?
+:majrx [value] Number of major divisions along x axis
+:minrx [value] Number of minor divisions along x axis
+:majry [value] Number of major divisions along y axis
+:minry [value] Number of minor divisions along y axis
+:round [yes/no] Round axes to nice values?
+:fill [yes/no] Fill viewport vs enforce unity aspect ratio?
diff --git a/noao/digiphot/ptools/pexamine/ptahgmr.x b/noao/digiphot/ptools/pexamine/ptahgmr.x
new file mode 100644
index 00000000..acf303b5
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptahgmr.x
@@ -0,0 +1,44 @@
+include <mach.h>
+include "pexamine.h"
+
+# PT_AHGMR -- Accumulate the histogram of the input vector. The output vector
+# HGM (the histogram) should be cleared prior to the first call. Delete
+# points or points marked for deletion are not included in the plot.
+
+procedure pt_ahgmr (data, delete, npix, hgm, nbins, z1, z2)
+
+real data[ARB] # data vector
+int delete[ARB] # deletions array
+int npix # number of pixels
+int hgm[ARB] # output histogram
+int nbins # number of bins in histogram
+real z1, z2 # greyscale values of first and last bins
+
+real z
+real dz
+int bin, i
+
+begin
+ dz = real (nbins - 1) / real (z2 - z1)
+ if (abs (dz - 1.0) < (EPSILONR * 2.0)) {
+ do i = 1, npix {
+ if ((delete[i] == PX_DELETE) || (delete[i] == PX_MARK))
+ next
+ z = data[i]
+ if (z >= z1 && z <= z2) {
+ bin = int (z - z1) + 1
+ hgm[bin] = hgm[bin] + 1
+ }
+ }
+ } else {
+ do i = 1, npix {
+ if ((delete[i] == PX_DELETE) || (delete[i] == PX_MARK))
+ next
+ z = data[i]
+ if (z >= z1 && z <= z2) {
+ bin = int ((z - z1) * dz) + 1
+ hgm[bin] = hgm[bin] + 1
+ }
+ }
+ }
+end
diff --git a/noao/digiphot/ptools/pexamine/ptalimr.x b/noao/digiphot/ptools/pexamine/ptalimr.x
new file mode 100644
index 00000000..614b2099
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptalimr.x
@@ -0,0 +1,35 @@
+include <mach.h>
+
+# PT_ALIMR -- Compute the limits (minimum and maximum values) of a vector
+# after rejecting any INDEF valued points.
+
+procedure pt_alimr (a, npix, minval, maxval)
+
+real a[ARB] # the input array
+int npix # the number of points
+real minval, maxval # the minimum and maximum value
+
+int i, ngood
+real value
+
+begin
+ minval = MAX_REAL
+ maxval = -MAX_REAL
+ ngood = 0
+
+ do i = 1, npix {
+ value = a[i]
+ if (IS_INDEFR(value))
+ next
+ ngood = ngood + 1
+ if (value < minval)
+ minval = value
+ if (value > maxval)
+ maxval = value
+ }
+
+ if (ngood == 0) {
+ minval = INDEFR
+ maxval = INDEFR
+ }
+end
diff --git a/noao/digiphot/ptools/pexamine/ptcolon.x b/noao/digiphot/ptools/pexamine/ptcolon.x
new file mode 100644
index 00000000..df2a29ae
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptcolon.x
@@ -0,0 +1,668 @@
+include <gset.h>
+include "pexamine.h"
+
+# PT_COLON -- Execute PEXAMINE colon commands.
+
+procedure pt_colon (px, gd, cmdstr, newdata, newxy, newhist, newcoords,
+ newplot, plottype, undelete)
+
+pointer px # pointer to the pexamine structure
+pointer gd # pointer to the graphics stream
+char cmdstr[ARB] # the colon command
+int newdata # read new columns from the input file
+int newxy # load new columns into the x and y arrays
+int newhist # load new column into the histogram array
+int newcoords # load new data into the coords array
+int newplot # replot the current plot
+int plottype # the plot type
+int undelete # delete or undelete points
+
+bool bval
+int type, ncmd, nrcols, ncols, ival, marktype
+pointer sp, cmd, str, rcols, cols
+real rval
+bool clgetb()
+int strdic(), nscan(), clgeti()
+real clgetr()
+
+errchk clgstr(), clgetb(), clgeti(), clgetr()
+errchk clpstr(), clputb(), clputi(), clputr()
+
+begin
+ # Allocate working space.
+ call smark (sp)
+ call salloc (cmd, SZ_LINE, TY_CHAR)
+ call salloc (rcols, PX_SZCOLNAME * (PX_MAXNCOLS + 1), TY_CHAR)
+ call salloc (cols, PX_SZCOLNAME * (PX_MAXNCOLS + 1), TY_CHAR)
+
+ # Get the command.
+ call sscan (cmdstr)
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call sfree (sp)
+ return
+ }
+
+ # Define the pset type.
+ call salloc (str, SZ_LINE, TY_CHAR)
+ switch (plottype) {
+ case PX_XYPLOT:
+ call strcpy ("xyplot.", Memc[str], SZ_LINE)
+ case PX_HISTPLOT:
+ call strcpy ("histplot.", Memc[str], SZ_LINE)
+ case PX_RADPLOT:
+ call strcpy ("radplot.", Memc[str], SZ_LINE)
+ case PX_SURFPLOT:
+ call strcpy ("surfplot.", Memc[str], SZ_LINE)
+ case PX_CNTRPLOT:
+ call strcpy ("cntrplot.", Memc[str], SZ_LINE)
+ }
+
+ # Process the command.
+ ncmd = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PX_PCMDS)
+ switch (ncmd) {
+
+ case PX_PCMD_PHOTCOLUMNS:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call pt_gphotcols (px, Memc[rcols], nrcols, Memc[cols],
+ ncols)
+ if (gd != NULL)
+ call gdeactivate (gd, AW_CLEAR)
+ call pt_lcols ("PHOTOMETRY COLUMNS", Memc[rcols], nrcols,
+ Memc[cols], ncols)
+ if (gd != NULL)
+ call greactivate (gd, AW_PAUSE)
+ } else {
+ call pt_gusercols (px, Memc[rcols], nrcols, Memc[cols], ncols)
+ call pt_setnames (px, Memc[cmd], Memc[rcols])
+ newdata = YES
+ newxy = YES
+ newhist = YES
+ newcoords = YES
+ newplot = YES
+ }
+
+ case PX_PCMD_USERCOLUMNS:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call pt_gusercols (px, Memc[rcols], nrcols, Memc[cols], ncols)
+ if (gd != NULL)
+ call gdeactivate (gd, AW_CLEAR)
+ call pt_lcols ("USER COLUMNS", Memc[rcols], nrcols, Memc[cols],
+ ncols)
+ if (gd != NULL)
+ call greactivate (gd, AW_PAUSE)
+ } else {
+ call pt_gphotcols (px, Memc[rcols], nrcols, Memc[cols], ncols)
+ call pt_setnames (px, Memc[rcols], Memc[cmd])
+ newdata = YES
+ newxy = YES
+ newhist = YES
+ newcoords = YES
+ newplot = YES
+ }
+
+ case PX_PCMD_XCOLUMN:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call printf ("X column requested: %s stored: %s\n")
+ call pargstr (PX_RXCOLNAME(px))
+ call pargstr (PX_XCOLNAME(px))
+ } else {
+ call strupr (Memc[cmd])
+ call strcpy (Memc[cmd], PX_RXCOLNAME(px), PX_SZCOLNAME)
+ if (strdic (Memc[cmd], Memc[cmd], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) > 0) {
+ call strcpy (Memc[cmd], PX_XCOLNAME(px), PX_SZCOLNAME)
+ newxy = YES
+ newplot = YES
+ call clputr ("xyplot.x1", INDEFR)
+ call clputr ("xyplot.x2", INDEFR)
+ } else {
+ call printf ("Column %s not found\n")
+ call pargstr (PX_RXCOLNAME(px))
+ }
+ }
+
+ case PX_PCMD_YCOLUMN:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call printf ("Y column requested: %s stored: %s\n")
+ call pargstr (PX_RYCOLNAME(px))
+ call pargstr (PX_YCOLNAME(px))
+ } else {
+ call strupr (Memc[cmd])
+ call strcpy (Memc[cmd], PX_RYCOLNAME(px), PX_SZCOLNAME)
+ if (strdic (Memc[cmd], Memc[cmd], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) > 0) {
+ call strcpy (Memc[cmd], PX_YCOLNAME(px), PX_SZCOLNAME)
+ newxy = YES
+ newplot = YES
+ call clputr ("xyplot.y1", INDEFR)
+ call clputr ("xyplot.y2", INDEFR)
+ } else {
+ call printf ("Column %s not found\n")
+ call pargstr (PX_RYCOLNAME(px))
+ }
+ }
+
+ case PX_PCMD_HCOLUMN:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call printf ("Histogram column requested: %s stored: %s\n")
+ call pargstr (PX_RHCOLNAME(px))
+ call pargstr (PX_HCOLNAME(px))
+ } else {
+ call strupr (Memc[cmd])
+ call strcpy (Memc[cmd], PX_RHCOLNAME(px), PX_SZCOLNAME)
+ if (strdic (Memc[cmd], Memc[cmd], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) > 0) {
+ call strcpy (Memc[cmd], PX_HCOLNAME(px), PX_SZCOLNAME)
+ newhist = YES
+ newplot = YES
+ call clputr ("histplot.z1", INDEFR)
+ call clputr ("histplot.z2", INDEFR)
+ call clputr ("histplot.x1", INDEFR)
+ call clputr ("histplot.x2", INDEFR)
+ call clputr ("histplot.y1", INDEFR)
+ call clputr ("histplot.y2", INDEFR)
+ } else {
+ call printf ("Column %s not found\n")
+ call pargstr (PX_RHCOLNAME(px))
+ }
+ }
+
+ case PX_PCMD_XPOSCOLUMN:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call printf ("X coord column requested: %s stored: %s\n")
+ call pargstr (PX_RXPOSNAME(px))
+ call pargstr (PX_XPOSNAME(px))
+ } else {
+ call strupr (Memc[cmd])
+ call strcpy (Memc[cmd], PX_RXPOSNAME(px), PX_SZCOLNAME)
+ if (strdic (Memc[cmd], Memc[cmd], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) > 0) {
+ call strcpy (Memc[cmd], PX_XPOSNAME(px), PX_SZCOLNAME)
+ newcoords = YES
+ } else {
+ call printf ("Column %s not found\n")
+ call pargstr (PX_RXPOSNAME(px))
+ }
+ }
+
+ case PX_PCMD_YPOSCOLUMN:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call printf ("X coord column requested: %s stored: %s\n")
+ call pargstr (PX_RYPOSNAME(px))
+ call pargstr (PX_YPOSNAME(px))
+ } else {
+ call strupr (Memc[cmd])
+ call strcpy (Memc[cmd], PX_RYPOSNAME(px), PX_SZCOLNAME)
+ if (strdic (Memc[cmd], Memc[cmd], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) > 0) {
+ call strcpy (Memc[cmd], PX_YPOSNAME(px), PX_SZCOLNAME)
+ newcoords = YES
+ } else {
+ call printf ("Column %s not found\n")
+ call pargstr (PX_RXPOSNAME(px))
+ }
+ }
+
+ case PX_PCMD_EDIT:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS)
+ call printf ("The parameter set is undefined\n")
+ else {
+ type = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PX_PLOTTYPES)
+ if (gd != NULL)
+ call gdeactivate (gd, 0)
+ switch (type) {
+ case PX_XYPLOT:
+ call clcmdw ("eparam xyplot")
+ case PX_HISTPLOT:
+ call clcmdw ("eparam histplot")
+ case PX_RADPLOT:
+ call clcmdw ("eparam radplot")
+ case PX_SURFPLOT:
+ call clcmdw ("eparam surfplot")
+ case PX_CNTRPLOT:
+ call clcmdw ("eparam cntrplot")
+ default:
+ call printf (
+ "The parameter set %s undefined\n")
+ call pargstr (Memc[cmd])
+ }
+ newplot = YES
+ if (gd != NULL)
+ call greactivate (gd, 0)
+ }
+
+ case PX_PCMD_UNLEARN:
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS)
+ call printf ("The parameter set is undefined\n")
+ else {
+ type = strdic (Memc[cmd], Memc[cmd], SZ_LINE, PX_PLOTTYPES)
+ switch (type) {
+ case PX_XYPLOT:
+ call clcmdw ("unlearn xyplot")
+ case PX_HISTPLOT:
+ call clcmdw ("unlearn histplot")
+ case PX_RADPLOT:
+ call clcmdw ("unlearn radplot")
+ case PX_SURFPLOT:
+ call clcmdw ("unlearn surfplot")
+ case PX_CNTRPLOT:
+ call clcmdw ("unlearn cntrplot")
+ default:
+ call printf ("The parameter set %s is undefined\n")
+ call pargstr (Memc[cmd])
+ }
+ newplot = YES
+ }
+
+ case PX_PCMD_NBINS:
+ call strcpy ("histplot.nbins", Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("nbins = %d\n")
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_Z1:
+ call strcpy ("histplot.z1", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("z1 = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_Z2:
+ call strcpy ("histplot.z2", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("z2 = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_TOP_CLOSED:
+ call strcpy ("histplot.top_closed", Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("top_closed = %b\n")
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_X1:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_X2:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_Y1:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_Y2:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_MARKER:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargwrd (Memc[cmd], SZ_LINE)
+ if (Memc[cmd] == EOS) {
+ call clgstr (Memc[str], Memc[cmd], SZ_LINE)
+ call printf ("marker = %s\n")
+ call pargstr (Memc[cmd])
+ } else {
+ call pt_marker (Memc[cmd], SZ_LINE, marktype)
+ call clpstr (Memc[str], Memc[cmd])
+ }
+
+ case PX_PCMD_SZMARKER:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (clgetr (Memc[str]))
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_GRID:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargb (bval)
+ call pargstr (Memc[cmd])
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_LOGX:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargstr (Memc[cmd])
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_LOGY:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargstr (Memc[cmd])
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_BOX:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargstr (Memc[cmd])
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_TICKLABELS:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargstr (Memc[cmd])
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_FILL:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargstr (Memc[cmd])
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_ROUND:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("%s = %b\n")
+ call pargstr (Memc[cmd])
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_MAJRX:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("%s = %d\n")
+ call pargstr (Memc[cmd])
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_MINRX:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("%s = %d\n")
+ call pargstr (Memc[cmd])
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_MAJRY:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("%s = %d\n")
+ call pargstr (Memc[cmd])
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_MINRY:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("%s = %d\n")
+ call pargstr (Memc[cmd])
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_DELETE:
+ call gargb (bval)
+ if (nscan() == 1) {
+ call printf ("delete = %b\n")
+ if (undelete == YES)
+ call pargb (false)
+ else
+ call pargb (true)
+ } else {
+ if (bval)
+ undelete = NO
+ else
+ undelete = YES
+ }
+
+ case PX_PCMD_RIN:
+ call strcpy ("radplot.rinner", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("rinner = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_ROUT:
+ call strcpy ("radplot.router", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("router = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_NCOLUMNS:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("%s = %d\n")
+ call pargstr (Memc[cmd])
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_NLINES:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("%s = %d\n")
+ call pargstr (Memc[cmd])
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_AXES:
+ call strcpy ("surfplot.axes", Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("axes = %b\n")
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ case PX_PCMD_ANGH:
+ call strcpy ("surfplot.angh", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("angh = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_ANGV:
+ call strcpy ("surfplot.angv", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("angv = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_FLOOR:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_CEILING:
+ call strcat (Memc[cmd], Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("%s = %g\n")
+ call pargstr (Memc[cmd])
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_ZERO:
+ call strcpy ("cntrplot.zero", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("zero = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_NCONTOURS:
+ call strcpy ("cntrplot.ncontours", Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("ncontours = %d\n")
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_INTERVAL:
+ call strcpy ("cntrplot.interval", Memc[str], SZ_LINE)
+ call gargr (rval)
+ if (nscan() == 1) {
+ rval = clgetr (Memc[str])
+ call printf ("interval = %g\n")
+ call pargr (rval)
+ } else
+ call clputr (Memc[str], rval)
+
+ case PX_PCMD_NHI:
+ call strcpy ("cntrplot.nhi", Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("nhi = %d\n")
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_DASHPAT:
+ call strcpy ("cntrplot.dashpat", Memc[str], SZ_LINE)
+ call gargi (ival)
+ if (nscan() == 1) {
+ ival = clgeti (Memc[str])
+ call printf ("dashpat = %d\n")
+ call pargi (ival)
+ } else
+ call clputi (Memc[str], ival)
+
+ case PX_PCMD_LABEL:
+ call strcpy ("cntrplot.label", Memc[str], SZ_LINE)
+ call gargb (bval)
+ if (nscan() == 1) {
+ bval = clgetb (Memc[str])
+ call printf ("label = %b\n")
+ call pargb (bval)
+ } else
+ call clputb (Memc[str], bval)
+
+ default:
+ call printf ("Unknown or ambiguous colon command\7\n")
+ }
+
+ call sfree (sp)
+end
diff --git a/noao/digiphot/ptools/pexamine/ptdelete.x b/noao/digiphot/ptools/pexamine/ptdelete.x
new file mode 100644
index 00000000..f8a6581e
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptdelete.x
@@ -0,0 +1,335 @@
+include <gset.h>
+include <mach.h>
+include "pexamine.h"
+
+define MSIZE 2.0
+
+# PT_DELPT -- Mark/unmark the point nearest the cursor.
+
+procedure pt_delpt (gd, wx, wy, xpos, ypos, x, y, deleted, npix, undelete,
+ matchrad)
+
+pointer gd # pointer to the graphics stream
+real wx # X cursor position
+real wy # Y cursor position
+real xpos[ARB] # X coordinate array
+real ypos[ARB] # Y coordinate array
+real x[ARB] # X array of plotted data
+real y[ARB] # Y array of plotted data
+int deleted[ARB] # array of delete indicators
+int npix # number of pixels
+int undelete # undelete flag
+real matchrad # matching radius
+
+int i, row
+real r2min, r2, mr2, wx0, wy0, xpos0, ypos0
+
+begin
+ # Initialize.
+ row = 0
+ r2min = MAX_REAL
+
+ # Set matching radius for the image display or graph.
+ if (IS_INDEFR(matchrad)) {
+ mr2 = MAX_REAL
+ if (gd != NULL)
+ call gctran (gd, wx, wy, wx0, wy0, 1, 0)
+ else {
+ wx0 = wx
+ wy0 = wy
+ }
+ } else {
+ mr2 = matchrad ** 2
+ wx0 = wx
+ wy0 = wy
+ }
+
+ # Search for the point nearest the cursor.
+ do i = 1 , npix {
+
+ if (deleted[i] == PX_DELETE)
+ next
+
+ if ((deleted[i] == PX_MARK && undelete == NO) ||
+ (deleted[i] == PX_GOOD && undelete == YES))
+ next
+
+ if (! IS_INDEFR(xpos[i]) && ! IS_INDEFR(ypos[i])) {
+ if (IS_INDEFR(matchrad)) {
+ if (gd != NULL)
+ call gctran (gd, xpos[i], ypos[i], xpos0, ypos0, 1, 0)
+ else {
+ xpos0 = xpos[i]
+ ypos0 = ypos[i]
+ }
+ } else {
+ xpos0 = xpos[i]
+ ypos0 = ypos[i]
+ }
+ r2 = (wx0 - xpos0) ** 2 + (wy0 - ypos0) ** 2
+ } else
+ r2 = MAX_REAL
+ if (r2 >= r2min)
+ next
+
+ r2min = r2
+ row = i
+ }
+
+ # Return if point not found.
+ if ((row == 0) || (r2min > mr2))
+ return
+
+ # Delete the point.
+ if (undelete == NO) {
+ deleted[row] = PX_MARK
+ if (gd == NULL)
+ return
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[row], y[row], GM_CROSS, MSIZE, MSIZE)
+ } else {
+ deleted[row] = PX_GOOD
+ if (gd == NULL)
+ return
+ call gseti (gd, G_PMLTYPE, GL_CLEAR)
+ call gmark (gd, x[row], y[row], GM_CROSS, MSIZE, MSIZE)
+ }
+end
+
+
+# PT_DYGTG -- Delete all points with Y > Y (cursor).
+
+procedure pt_dygtg (gd, wy, ypos, x, y, deleted, npix, undelete)
+
+pointer gd # pointer to graphics stream
+real wy # Y cursor position
+real ypos[ARB] # Y array of coordinate data
+real x[ARB] # X array of plotted data
+real y[ARB] # Y array of plotted data
+int deleted[ARB] # array of delete indicators
+int npix # number of pixels
+int undelete # the delete or undelete flag
+
+int i
+
+begin
+ do i = 1 , npix {
+ if (ypos[i] <= wy)
+ next
+ if ((deleted[i] == PX_GOOD) && (undelete == NO)) {
+ deleted[i] = PX_MARK
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ } else if ((deleted[i] == PX_MARK) && (undelete == YES)) {
+ deleted[i] = PX_GOOD
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_CLEAR)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ }
+ }
+end
+
+
+# PT_DYLTG -- Delete all points with Y < Y (cursor).
+
+procedure pt_dyltg (gd, wy, ypos, x, y, deleted, npix, undelete)
+
+pointer gd # pointer to graphics stream
+real wy # Y cursor position
+real ypos[ARB] # Y array of coordinate data
+real x[ARB] # X array of plotted data
+real y[ARB] # Y array of plotted data
+int deleted[ARB] # array of delete indicators
+int npix # number of pixels
+int undelete # the delete or undelete flag
+
+int i
+
+begin
+ do i = 1 , npix {
+ if (ypos[i] >= wy)
+ next
+ if ((deleted[i] == PX_GOOD) && (undelete == NO)) {
+ deleted[i] = PX_MARK
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ } else if ((deleted[i] == PX_MARK) && (undelete == YES)) {
+ deleted[i] = PX_GOOD
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_CLEAR)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ }
+ }
+end
+
+
+# PT_DXGTG -- Mark delete for all points with X > X (cursor)
+
+procedure pt_dxgtg (gd, wx, xpos, x, y, deleted, npix, undelete)
+
+pointer gd # pointer to graphics stream
+real wx # X cursor position
+real xpos[ARB] # X coordinate array
+real x[ARB] # X array of plotted data
+real y[ARB] # Y array of plotted data
+int deleted[ARB] # array of delete indicators
+int npix # number of pixels
+int undelete # the delete or undelete flag
+
+int i
+
+begin
+ do i = 1 , npix {
+ if (xpos[i] <= wx)
+ next
+ if ((deleted[i] == PX_GOOD) && (undelete == NO)) {
+ deleted[i] = PX_MARK
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ } else if ((deleted[i] == PX_MARK) && (undelete == YES)) {
+ deleted[i] = PX_GOOD
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_CLEAR)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ }
+ }
+end
+
+
+# PT_DXLTG -- Mark delete for all points with X < X (cursor).
+
+procedure pt_dxltg (gd, wx, xpos, x, y, deleted, npix, undelete)
+
+pointer gd # pointer to graphics stream
+real wx # X cursor position
+real xpos[ARB] # X coordinate array
+real x[ARB] # X array of plotted data
+real y[ARB] # Y array of plotted data
+int deleted[ARB] # array of delete indicators
+int npix # number of pixels
+int undelete # the delete or undelete flag
+
+int i
+
+begin
+ do i = 1 , npix {
+ if (xpos[i] >= wx)
+ next
+ if ((deleted[i] == PX_GOOD) && (undelete == NO)) {
+ deleted[i] = PX_MARK
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ } else if ((deleted[i] == PX_MARK) && (undelete == YES)) {
+ deleted[i] = PX_GOOD
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_CLEAR)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ }
+ }
+end
+
+
+# PT_DBOXG -- Delete all points inside a box
+
+procedure pt_dboxg (gd, xpos, ypos, x, y, deleted, npix, x1, y1, x2, y2,
+ undelete)
+
+pointer gd # pointer to the graphics stream
+real xpos[ARB] # x coordinate array
+real ypos[ARB] # y coordinate array
+real x[ARB] # x array of plotted data
+real y[ARB] # y array of plotted data
+int deleted[ARB] # array of deletion indicators
+int npix # number of pixels
+real x1, y1, x2, y2 # corners of the box
+int undelete # delete or undelete points
+
+int i
+real temp
+
+begin
+ # Make sure the points are in the correct order.
+ if (x2 < x1) {
+ temp = x1
+ x1 = x2
+ x2 = temp
+ }
+ if (y2 < y1) {
+ temp = y1
+ y1 = y2
+ y2 = temp
+ }
+
+ # Search for points within the box and delete.
+ do i = 1 , npix {
+ if (xpos[i] < x1 || xpos[i] > x2 || ypos[i] < y1 || ypos[i] > y2)
+ next
+ if ((deleted[i] == PX_GOOD) && (undelete == NO)) {
+ deleted[i] = PX_MARK
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ } else if ((deleted[i] == PX_MARK) && (undelete == YES)) {
+ deleted[i] = PX_GOOD
+ if (gd == NULL)
+ next
+ call gseti (gd, G_PMLTYPE, GL_CLEAR)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ }
+ }
+end
+
+
+# PT_MDELETE -- Overplot crosses on those points which have been marked for
+# deletion.
+
+procedure pt_mdelete (gd, x, y, deleted, npix)
+
+pointer gd # pointer to the graphics stream
+real x[ARB] # the array plotted along the x axis
+real y[ARB] # the array plotted along the y axis
+int deleted[ARB] # the array of deletion indices
+int npix # the number of pixels
+
+int i
+
+begin
+ do i = 1, npix {
+ if (deleted[i] != PX_MARK)
+ next
+ call gseti (gd, G_PMLTYPE, GL_SOLID)
+ call gmark (gd, x[i], y[i], GM_CROSS, MSIZE, MSIZE)
+ }
+end
+
+
+# PT_UPDATE -- Actually delete points currently marked for deletion.
+
+procedure pt_update (deleted, npix)
+
+int deleted[ARB] # array of deletions indices
+int npix # the number of pixels
+
+int i
+
+begin
+ # Add the marked points to the deletions array.
+ do i = 1, npix {
+ if (deleted[i] != PX_MARK)
+ next
+ deleted[i] = PX_DELETE
+ }
+end
diff --git a/noao/digiphot/ptools/pexamine/ptgetphot.x b/noao/digiphot/ptools/pexamine/ptgetphot.x
new file mode 100644
index 00000000..df3b27f0
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptgetphot.x
@@ -0,0 +1,432 @@
+include <tbset.h>
+include "../../lib/ptkeysdef.h"
+include "pexamine.h"
+
+define NAPRESULT 10
+
+# PT_GETPHOT -- Read the specified columns out of the photometry catalog.
+# PT_GETPHOT works with either the "old" APPHOT files or the new ST Tables.
+
+int procedure pt_getphot (px, apd, key, max_nstars, first_star)
+
+pointer px # pointer to the pexamine structure
+int apd # input photometry file descriptor
+pointer key # pointer to key structure for text files
+int max_nstars # the maximum number of stars
+int first_star # first star to load
+
+int i, nstars
+int pt_goldap(), pt_gtabphot(), strdic()
+errchk pt_goldap(), pt_gtabphot()
+
+begin
+ # Allocate the required memory for the photometry, user and
+ # dummy columns and fill with INDEFR.
+ do i = 1, PX_MAXNCOLS {
+ call realloc (Memi[PX_COLPTRS(px)+i-1], max_nstars, TY_REAL)
+ call amovkr (INDEFR, Memr[Memi[PX_COLPTRS(px)+i-1]], max_nstars)
+ }
+
+ # Get the results.
+ if (key == NULL)
+ nstars = pt_gtabphot (apd, px, max_nstars, first_star)
+ else
+ nstars = pt_goldap (apd, px, key, max_nstars, first_star)
+
+ # Reallocate space if necessary.
+ if (nstars < max_nstars) {
+ do i = 1, PX_MAXNCOLS {
+ if (Memi[PX_COLPTRS(px)+i-1] == NULL)
+ next
+ if (i > PX_NCOLS(px)) {
+ call mfree (Memi[PX_COLPTRS(px)+i-1], TY_REAL)
+ Memi[PX_COLPTRS(px)+i-1] = NULL
+ } else
+ call realloc (Memi[PX_COLPTRS(px)+i-1], nstars, TY_REAL)
+ }
+ }
+
+ # Get the x and y columns.
+ if (strdic (PX_RXCOLNAME(px), PX_XCOLNAME(px), PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0)
+ PX_XCOLNAME(px) = EOS
+ if (strdic (PX_RYCOLNAME(px), PX_YCOLNAME(px), PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0)
+ PX_YCOLNAME(px) = EOS
+
+ # Get the x and y coordinate columns.
+ if (strdic (PX_RXPOSNAME(px), PX_XPOSNAME(px), PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0)
+ PX_XPOSNAME(px) = EOS
+ if (strdic (PX_RYPOSNAME(px), PX_YPOSNAME(px), PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0)
+ PX_YPOSNAME(px) = EOS
+
+ # Get the histogram column names.
+ if (strdic (PX_RHCOLNAME(px), PX_HCOLNAME(px), PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0)
+ PX_HCOLNAME(px) = EOS
+
+ return (nstars)
+end
+
+
+# PT_GOLDAP -- Read in the photometry from an old style APPHOT file.
+
+int procedure pt_goldap (apd, px, apkey, max_nstars, first_star)
+
+int apd # pointer to the input file descriptor
+pointer px # pointer to the pexamine structure
+pointer apkey # pointer to the key structure
+int max_nstars # maximum number of stars
+int first_star # first star to load
+
+char lbracket
+int i, ip, index, nselect, nphot, nptr, nstars
+pointer sp, data, rcolname, colname
+int pt_photsel(), pt_getnames(), strdic(), stridx()
+data lbracket /'['/
+
+begin
+ call smark (sp)
+ call salloc (data, PX_MAXNCOLS, TY_REAL)
+ call salloc (rcolname, PX_SZCOLNAME, TY_CHAR)
+ call salloc (colname, PX_SZCOLNAME, TY_CHAR)
+
+ # Rewind the text file.
+ call seek (apd, BOF)
+
+ # Now read in the results.
+ nptr = 0
+ nstars = 0
+ while (pt_photsel (apkey, apd, Memc[PX_RCOLNAMES(px)], first_star +
+ max_nstars - 1, Memc[PX_COLNAMES(px)], Memr[data]) != EOF) {
+ nselect = KY_NSELECT(apkey)
+ if (nselect <= 0)
+ break
+ nstars = nstars + 1
+ if (nstars < first_star)
+ next
+ do i = 1, nselect
+ Memr[Memi[PX_COLPTRS(px)+i-1]+nptr] = Memr[data+i-1]
+ nptr = nptr + 1
+ }
+
+ # Count the fields.
+ ip = 1
+ nselect = 0
+ while (pt_getnames (Memc[PX_COLNAMES(px)], ip, Memc[rcolname],
+ PX_SZCOLNAME) != EOF)
+ nselect = nselect + 1
+ PX_NCOLS(px) = nselect
+
+ # Count the photometry fields.
+ ip = 1
+ nselect = 0
+ nphot = 0
+ while (pt_getnames (Memc[PX_RCOLNAMES(px)], ip, Memc[rcolname],
+ PX_SZCOLNAME) != EOF) {
+ nselect = nselect + 1
+ if (nselect > PX_RNPHOT(px))
+ break
+ if (strdic (Memc[rcolname], Memc[colname], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0) {
+ index = stridx (lbracket, Memc[rcolname])
+ if (index <= 1)
+ next
+ call strcpy (Memc[rcolname], Memc[colname], index - 1)
+ if (strdic (Memc[colname], Memc[colname], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)]) <= 0)
+ next
+ }
+ nphot = nphot + 1
+ }
+ PX_NPHOT(px) = nphot
+
+ # Count the user fields.
+ PX_NUSER(px) = PX_NCOLS(px) - PX_NPHOT(px)
+
+ call sfree (sp)
+
+ return (nptr)
+end
+
+
+# PT_GTABPHOT -- Read in the photometry from an ST table. It may be possible
+# to do this more efficiently depending on how the table ir organized.
+
+int procedure pt_gtabphot (tp, px, max_nstars, first_star)
+
+pointer tp # table descriptor
+pointer px # pointer to the pexamine structure
+int max_nstars # maximum number of stars
+int first_star # first star to load
+
+bool nullflag
+int ntot, ncount, record, ip, col, nrow, ival
+pointer sp, colname, colptrs, cptr, dptr
+int pt_getnames(), tbpsta(), tbcigi()
+
+begin
+ # Allocate working memory.
+ call smark (sp)
+ call salloc (colname, PX_SZCOLNAME, TY_CHAR)
+ call salloc (colptrs, PX_MAXNCOLS + 2, TY_POINTER)
+
+ # Define the column pointers for the preset columns.
+ ip = 1
+ ncount = 0
+ Memc[PX_COLNAMES(px)] = EOS
+ ntot = 0
+ while (pt_getnames (Memc[PX_RCOLNAMES(px)], ip, Memc[colname],
+ PX_SZCOLNAME) != EOF) {
+
+ ncount = ncount + 1
+ call tbcfnd (tp, Memc[colname], Memi[colptrs+ntot], 1)
+ if (Memi[colptrs+ntot] == NULL)
+ call strcat ("[1]", Memc[colname], PX_SZCOLNAME)
+ call tbcfnd (tp, Memc[colname], Memi[colptrs+ntot], 1)
+ if (Memi[colptrs+ntot] == NULL)
+ next
+
+ call strcat (",", Memc[PX_COLNAMES(px)], (PX_MAXNCOLS + 1) *
+ PX_SZCOLNAME)
+ call strcat (Memc[colname], Memc[PX_COLNAMES(px)],
+ (PX_MAXNCOLS + 1) * PX_SZCOLNAME)
+
+ ntot = ntot + 1
+ if (ncount <= PX_RNPHOT(px))
+ PX_NPHOT(px) = ntot
+ }
+ PX_NCOLS(px) = ntot
+ PX_NUSER(px) = PX_NCOLS(px) - PX_NPHOT(px)
+
+ # Get the results filling in any record that can not be interpreted
+ # as a real number with INDEFR.
+
+ nrow = tbpsta (tp, TBL_NROWS)
+ if (first_star > nrow) {
+ call sfree (sp)
+ return (0)
+ }
+
+ nrow = min (nrow - first_star + 1, max_nstars)
+
+ do col = 1, PX_NCOLS(px) {
+
+ cptr = Memi[colptrs+col-1]
+ if (cptr == NULL)
+ next
+ dptr = Memi[PX_COLPTRS(px)+col-1]
+ if (dptr == NULL)
+ next
+
+ if (tbcigi (cptr, TBL_COL_DATATYPE) == TY_REAL) {
+ do record = first_star, nrow + first_star - 1
+ call tbrgtr (tp, cptr, Memr[dptr+record-first_star],
+ nullflag, 1, record)
+ } else if (tbcigi (cptr, TBL_COL_DATATYPE) == TY_INT) {
+ do record = first_star, nrow + first_star - 1 {
+ call tbrgti (tp, cptr, ival, nullflag, 1, record)
+ Memr[dptr+record-first_star] = ival
+ }
+ }
+ }
+
+ call sfree (sp)
+
+ if (PX_NCOLS(px) <= 0)
+ return (0)
+ else
+ return (nrow)
+end
+
+
+# PT_PHOTSEL -- Procedure to select real records from a text file.
+
+int procedure pt_photsel (key, fd, infields, max_nrecords, outfields, data)
+
+pointer key # pointer to key structure
+int fd # text file descriptor
+char infields[ARB] # requested output fields
+int max_nrecords # maximum number of records to be read
+char outfields[ARB] # selected output field
+real data[ARB] # array of real values read from the file
+
+int nchars, nunique, uunique, funique, ncontinue, recptr
+int first_rec, record
+pointer line
+int getline(), strncmp(), pt_choose()
+
+data first_rec /YES/
+
+begin
+ # Initialize the file read.
+ if (first_rec == YES) {
+ record = 0
+ nunique = 0
+ uunique = 0
+ funique = 0
+ call malloc (line, SZ_LINE, TY_CHAR)
+ }
+
+ ncontinue = 0
+ recptr = 1
+
+ # Loop over the text file records.
+ repeat {
+
+ # Check for the maximum number of records and EOF.
+ if (record >= max_nrecords)
+ nchars = EOF
+ else
+ nchars = getline (fd, Memc[line])
+ if (nchars == EOF)
+ break
+
+ # Determine the type of record.
+ if (Memc[line] == KY_CHAR_POUND) {
+
+ if (strncmp (Memc[line], KY_CHAR_KEYWORD, KY_LEN_STR) == 0) {
+ call pt_kyadd (key, Memc[line], nchars)
+ } else if (strncmp (Memc[line], KY_CHAR_NAME,
+ KY_LEN_STR) == 0) {
+ nunique = nunique + 1
+ call pt_kname (key, Memc[line], nchars, nunique)
+ } else if (strncmp (Memc[line], KY_CHAR_UNITS,
+ KY_LEN_STR) == 0) {
+ uunique = uunique + 1
+ call pt_knunits (key, Memc[line], nchars, uunique)
+ } else if (strncmp (Memc[line], KY_CHAR_FORMAT,
+ KY_LEN_STR) == 0) {
+ funique = funique + 1
+ call pt_knformats (key, Memc[line], nchars, funique)
+ }
+
+ } else if (Memc[line] == KY_CHAR_NEWLINE) {
+ # skip blank lines
+
+ } else {
+
+ # Construct the table record.
+ call pt_mkrec (key, Memc[line], nchars, first_rec, recptr,
+ ncontinue)
+
+ # Construct output record when there is no continuation char.
+ if (Memc[line+nchars-2] != KY_CHAR_CONT) {
+
+ # Select the appropriate records.
+ if (first_rec == YES) {
+ call pt_fields (key, infields, outfields)
+ if (pt_choose (key, outfields) <= 0) {
+ nchars = EOF
+ break
+ }
+ }
+
+ # Construct the output record by moving selected fields
+ # into the data structures.
+
+ call pt_grecord (key, data)
+ first_rec = NO
+ record = record + 1
+
+ # Record is complete so exit the loop.
+ break
+ }
+ }
+
+ }
+
+ if (nchars == EOF) {
+ first_rec = YES
+ record = 0
+ nunique = 0
+ uunique = 0
+ funique = 0
+ call mfree (line, TY_CHAR)
+ return (EOF)
+ } else
+ return (record)
+end
+
+
+# PT_FIELDS -- Check the user definitions for multiply defined entries.
+
+procedure pt_fields (key, infields, outfields)
+
+pointer key # pointer to keys strucuture
+char infields[ARB] # the list of input fields
+char outfields[ARB] # the list of input fields
+
+int ijunk, num
+pointer sp, name, aranges, ranges, rangeset, list
+int pt_gnfn(), pt_ranges(), decode_ranges(), get_next_number(), strlen()
+int pt_kstati()
+pointer pt_ofnl()
+
+begin
+ call smark (sp)
+ call salloc (name, PX_SZCOLNAME, TY_CHAR)
+ call salloc (aranges, SZ_LINE, TY_CHAR)
+ call salloc (ranges, SZ_LINE, TY_CHAR)
+ call salloc (rangeset, 3 * KY_MAXNRANGES + 1, TY_INT)
+
+ list = pt_ofnl (key, infields)
+ outfields[1] = EOS
+ while (pt_gnfn (list, Memc[name], Memc[aranges], KY_SZPAR) != EOF) {
+ if (Memc[name] == EOS)
+ next
+ num = 0
+ if (Memc[aranges] == EOS) {
+ if (pt_kstati (key, Memc[name], KY_NUMELEMS) > 1)
+ call strcat ("[1]", Memc[name], PX_SZCOLNAME)
+ } else if (pt_ranges (Memc[aranges], Memc[ranges], ijunk,
+ SZ_LINE) == ERR) {
+ call strcat ("[1]", Memc[name], PX_SZCOLNAME)
+ } else if (decode_ranges (Memc[ranges], Memi[rangeset],
+ KY_MAXNRANGES, ijunk) == ERR) {
+ call strcat ("[1]", Memc[name], PX_SZCOLNAME)
+ } else if (get_next_number (Memi[rangeset], num) > 0) {
+ call sprintf (Memc[name+strlen(Memc[name])], PX_SZCOLNAME,
+ "[%d]")
+ call pargi (num)
+ } else {
+ call strcat ("[1]", Memc[name], PX_SZCOLNAME)
+ }
+ call strcat (",", outfields, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], outfields, PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ }
+
+ call pt_cfnl (list)
+ call sfree (sp)
+end
+
+
+# PT_GRECORD -- Move selected photometry results into a real arrays.
+
+procedure pt_grecord (key, data)
+
+pointer key # pointer to keys strucuture
+real data[ARB] # output array of real selected data
+
+int i, index, elem, maxch, kip, ip
+int ctor()
+
+begin
+ do i = 1, KY_NSELECT(key) {
+
+ index = Memi[KY_SELECT(key)+i-1]
+ elem = Memi[KY_ELEM_SELECT(key)+i-1]
+ maxch = Memi[KY_LEN_SELECT(key)+i-1]
+ kip = Memi[KY_PTRS(key)+index-1] + (elem - 1) * maxch
+
+ ip = 1
+ if (kip == NULL)
+ data[i] = INDEFR
+ else if (ctor (Memc[kip], ip, data[i]) <= 0)
+ data[i] = INDEFR
+ }
+
+end
diff --git a/noao/digiphot/ptools/pexamine/ptimplot.x b/noao/digiphot/ptools/pexamine/ptimplot.x
new file mode 100644
index 00000000..8e586b97
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptimplot.x
@@ -0,0 +1,940 @@
+include <imhdr.h>
+include <gset.h>
+include <math.h>
+include <mach.h>
+
+
+# PT_RPLOT -- Plot the radial profile.
+
+procedure pt_rplot (gd, im, wx, wy)
+
+pointer gd # pointer to the graphics stream
+pointer im # pointer to the input image
+real wx, wy # radial profile coordinates
+
+int marker_type, lenbuf, npix
+pointer sp, radius, intensity, marker, longtitle
+real szmarker, rin, rout, x1, x2, y1, y2, dmin, dmax
+bool clgetb()
+int clgeti(), strlen(), pt_radpix()
+real clgetr()
+
+begin
+ # Check for undefined graphics stream.
+ if (gd == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Check for undefined input image.
+ if (im == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Check for an undefined center.
+ if (IS_INDEFR(wx) || IS_INDEFR(wy)) {
+ call printf ("The radial profile plot center is undefined.\n")
+ return
+ }
+
+ # Get the inner and outer radii.
+ rin = clgetr ("radplot.rinner")
+ rout = clgetr ("radplot.router")
+ if (rout <= rin) {
+ call printf (
+ "The outer radius %g is <= the inner radius %g\n")
+ call pargr (rin)
+ call pargr (rout)
+ return
+ }
+
+ # Allocate working space.
+ call smark (sp)
+
+ # Get the data.
+ lenbuf = PI * (rin + rout + 1.0) * (rout - rin + 0.5)
+ call salloc (radius, lenbuf, TY_REAL)
+ call salloc (intensity, lenbuf, TY_REAL)
+ npix = pt_radpix (im, wx, wy, rin, rout, Memr[radius], Memr[intensity])
+ if (npix <= 0) {
+ call printf ("The object at %g %g is off the image\n")
+ call pargr (wx)
+ call pargr (wy)
+ call sfree (sp)
+ return
+ }
+
+ # Clear the plotting strucuture.
+ call gclear (gd)
+
+ # Fetch the window and viewport parameters.
+ x1 = clgetr ("radplot.x1")
+ x2 = clgetr ("radplot.x2")
+ y1 = clgetr ("radplot.y1")
+ y2 = clgetr ("radplot.y2")
+ if (IS_INDEFR(x1) || IS_INDEFR(x2)) {
+ call pt_alimr (Memr[radius], npix, dmin, dmax)
+ if (IS_INDEFR(x1))
+ x1 = dmin
+ if (IS_INDEFR(x2))
+ x2 = dmax
+ }
+ if (IS_INDEFR(y1) || IS_INDEFR(y2)) {
+ call pt_alimr (Memr[intensity], npix, dmin, dmax)
+ if (IS_INDEFR(y1))
+ y1 = dmin
+ if (IS_INDEFR(y2))
+ y2 = dmax
+ }
+
+ # Set the scale of the axes.
+ call gswind (gd, x1, x2, y1, y2)
+ if (clgetb ("radplot.logx"))
+ call gseti (gd, G_XTRAN, GW_LOG)
+ else
+ call gseti (gd, G_XTRAN, GW_LINEAR)
+ if (clgetb ("radplot.logy"))
+ call gseti (gd, G_YTRAN, GW_LOG)
+ else
+ call gseti (gd, G_YTRAN, GW_LINEAR)
+
+ # Get the x and y axes parameters.
+ if (! clgetb ("radplot.fill"))
+ call gseti (gd, G_ASPECT, 1)
+ if (clgetb ("radplot.round"))
+ call gseti (gd, G_ROUND, YES)
+
+ # Get the axis drawing parameters.
+ if (clgetb ("radplot.box")) {
+
+ # Get number of major and minor tick marks.
+ call gseti (gd, G_XNMAJOR, clgeti ("radplot.majrx"))
+ call gseti (gd, G_XNMINOR, clgeti ("radplot.minrx"))
+ call gseti (gd, G_YNMAJOR, clgeti ("radplot.majry"))
+ call gseti (gd, G_YNMINOR, clgeti ("radplot.minry"))
+
+ # Label tick marks on axes.
+ if (clgetb ("radplot.ticklabels"))
+ call gseti (gd, G_LABELTICKS, YES)
+ else
+ call gseti (gd, G_LABELTICKS, NO)
+
+ # Draw grid.
+ if (clgetb ("radplot.grid"))
+ call gseti (gd, G_DRAWGRID, YES)
+ else
+ call gseti (gd, G_DRAWGRID, NO)
+
+ # Optionally draw a box around the plot.
+ call salloc (longtitle, 2 * SZ_LINE, TY_CHAR)
+ if (clgetb ("radplot.banner")) {
+ call sysid (Memc[longtitle], 2 * SZ_LINE)
+ call sprintf (Memc[longtitle+strlen(Memc[longtitle])],
+ 2 * SZ_LINE, "\n%s: xc=%g yc=%g rinner=%g router=%g\n%s")
+ call pargstr (IM_HDRFILE(im))
+ call pargr (wx)
+ call pargr (wy)
+ call pargr (rin)
+ call pargr (rout)
+ call pargstr ("Radial Profile Plot")
+ } else {
+ call sprintf (Memc[longtitle], 2 * SZ_LINE,
+ "%s: xc=%g yc=%g rinner=%g router=%g\n%s")
+ call pargstr (IM_HDRFILE(im))
+ call pargr (wx)
+ call pargr (wy)
+ call pargr (rin)
+ call pargr (rout)
+ call pargstr ("Radial Profile Plot")
+ }
+ call glabax (gd, Memc[longtitle], "Radial distance (pixels)",
+ "Intensity (counts)")
+ }
+
+ # Get the marker type, the size of the marker and the linewidth.
+ call salloc (marker, SZ_FNAME, TY_CHAR)
+ call clgstr ("radplot.marker", Memc[marker], SZ_FNAME)
+ call pt_marker (Memc[marker], SZ_FNAME, marker_type)
+ if (marker_type != GM_POINT)
+ szmarker = clgetr ("radplot.szmarker")
+ else
+ szmarker = 0.0
+ call gsetr (gd, G_PLWIDTH, 2.0)
+
+ # Draw the points in using the deletions array.
+ call gpmark (gd, Memr[radius], Memr[intensity], npix, marker_type,
+ szmarker, szmarker)
+ call gflush (gd)
+
+ call sfree (sp)
+end
+
+
+define CSIZE 24
+
+# PT_SPLOT -- Draw a perspective view of a surface. The altitude
+# and azimuth of the viewing angle are variable.
+
+procedure pt_splot (gd, im, x, y)
+
+pointer gd # pointer to the graphics stream
+pointer im # pointer to the image descriptor
+real x, y # the object center
+
+int nx, ny, x1, x2, y1, y2, npts, wkid
+pointer data, sp, sdata, work, longtitle
+real floor, ceiling, angv, angh
+bool clgetb()
+int clgeti(), strlen()
+pointer pt_gdata()
+real clgetr()
+
+int first
+real vpx1, vpx2, vpy1, vpy2
+common /frstfg/ first
+common /noaovp/ vpx1, vpx2, vpy1, vpy2
+
+begin
+ # Check for undefined graphics stream.
+ if (gd == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Check for undefined input image.
+ if (im == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Check for an undefined center.
+ if (IS_INDEFR(x) || IS_INDEFR(y)) {
+ call printf ("The surface plot center is undefined\n")
+ return
+ }
+
+ # Get the data.
+ ny = clgeti ("surfplot.nlines")
+ nx = clgeti ("surfplot.ncolumns")
+ x1 = x - (nx - 1) / 2 + 0.5
+ x2 = x + nx / 2 + 0.5
+ y1 = y - (ny - 1) / 2 + 0.5
+ y2 = y + ny / 2 + 0.5
+ data = pt_gdata (im, x1, x2, y1, y2)
+ if (data == NULL) {
+ call printf ("The requested image section if off the image\n")
+ return
+ }
+
+ call smark (sp)
+
+ # Set the title.
+ call salloc (longtitle, 2 * SZ_LINE, TY_CHAR)
+ if (clgetb ("surfplot.banner")) {
+ Memc[longtitle] = '\n'
+ call sysid (Memc[longtitle+1], 2 * SZ_LINE)
+ call sprintf (Memc[longtitle+strlen(Memc[longtitle])], 2 * SZ_LINE,
+ "\nObject at x: %g y: %g\nSurface plot of %s[%d:%d,%d:%d]")
+ call pargr (x)
+ call pargr (y)
+ call pargstr (IM_HDRFILE(im))
+ call pargi (x1)
+ call pargi (x2)
+ call pargi (y1)
+ call pargi (y2)
+ } else {
+ call sprintf (Memc[longtitle], 2 * SZ_LINE,
+ "\nObject at x: %g y: %g\nSurface plot of %s[%d:%d,%d:%d]")
+ call pargr (x)
+ call pargr (y)
+ call pargstr (IM_HDRFILE(im))
+ call pargi (x1)
+ call pargi (x2)
+ call pargi (y1)
+ call pargi (y2)
+ }
+
+ # Initialize the plot.
+ call gclear (gd)
+
+ # Set the viewport, turn off axes drawing.
+ call gsview (gd, 0.1, 0.9, 0.1, 0.9)
+ call gseti (gd, G_DRAWAXES, NO)
+ call glabax (gd, Memc[longtitle], "", "")
+
+ nx = x2 - x1 + 1
+ ny = y2 - y1 + 1
+ npts = nx * ny
+
+ # Take floor and ceiling if enabled (nonzero).
+ floor = clgetr ("surfplot.floor")
+ ceiling = clgetr ("surfplot.ceiling")
+ if (IS_INDEFR (floor) && IS_INDEFR (ceiling))
+ sdata = data
+ else {
+ call salloc (sdata, npts, TY_REAL)
+ call amovr (Memr[data], Memr[sdata], npts)
+ if (! IS_INDEFR (floor) && ! IS_INDEFR (ceiling)) {
+ floor = min (floor, ceiling)
+ ceiling = max (floor, ceiling)
+ }
+ if (! IS_INDEFR (floor))
+ call amaxkr (Memr[sdata], floor, Memr[sdata], npts)
+ if (! IS_INDEFR (ceiling))
+ call aminkr (Memr[sdata], ceiling, Memr[sdata], npts)
+ }
+
+ # Open graphics device and make plot.
+ call gopks (STDERR)
+ wkid = 1
+ call gopwk (wkid, 6, gd)
+ call gacwk (wkid)
+
+ first = 1
+ call srfabd()
+ call ggview (gd, vpx1, vpx2, vpy1, vpy2)
+ call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1)
+
+ angh = clgetr ("surfplot.angh")
+ angv = clgetr ("surfplot.angv")
+ call salloc (work, 2 * (2*nx*ny+nx+ny), TY_REAL)
+ call ezsrfc (Memr[sdata], nx, ny, angh, angv, Memr[work])
+
+ if (clgetb ("surfplot.axes")) {
+ call gswind (gd, real (x1), real (x2), real (y1), real (y2))
+ call gseti (gd, G_CLIP, NO)
+ call pt_perimeter (gd, Memr[sdata], nx, ny, angh, angv)
+ }
+
+ call gdawk (wkid)
+ call gclks ()
+ call sfree (sp)
+end
+
+
+# PT_CPLOT -- Contour map
+# This is an interface to the NCAR CONREC routine.
+
+procedure pt_cplot (gd, im, x, y)
+
+pointer gd # pointer to the graphics stream
+pointer im # pointer to the input image
+real x, y # center of the contour plot
+
+int nx, ny, x1, x2, y1, y2, nhi, dashpat, npts, ncontours, wkid, nset
+pointer data, sp, longtitle, data1
+real xs, xe, ys, ye, vx1, vx2, vy1, vy2
+real zero, floor, ceiling, zmin, zmax, interval, finc
+bool clgetb(), fp_equalr()
+int clgeti(), btoi(), strlen()
+pointer pt_gdata()
+real clgetr()
+
+int isizel, isizem, isizep, nrep, ncrt, ilab, nulbll, ioffd
+int ioffm, isolid, nla, nlm, first
+real xlt, ybt, side, ext, hold[5]
+common /conflg/ first
+common /conre4/ isizel, isizem , isizep, nrep, ncrt, ilab, nulbll,
+ ioffd, ext, ioffm, isolid, nla, nlm, xlt, ybt, side
+common /noaolb/ hold
+
+begin
+ # Check for undefined graphics stream.
+ if (gd == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Check for undefined input image.
+ if (im == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Check fo an undefined center.
+ if (IS_INDEFR(x) || IS_INDEFR(y)) {
+ call printf ("The center of the contour plot is undefined\n")
+ return
+ }
+
+ # Get the data.
+ ny = clgeti ("cntrplot.nlines")
+ nx = clgeti ("cntrplot.ncolumns")
+ x1 = x - (nx - 1) / 2 + 0.5
+ x2 = x + nx / 2 + 0.5
+ y1 = y - (ny - 1) / 2 + 0.5
+ y2 = y + ny / 2 + 0.5
+ data = pt_gdata (im, x1, x2, y1, y2)
+ if (data == NULL) {
+ call printf ("The image section to be contoured is off the image\n")
+ return
+ }
+
+ call smark (sp)
+
+ # Intialize the plot
+ call gclear (gd)
+
+ # Set the WCS.
+ xs = x1
+ xe = x2
+ ys = y1
+ ye = y2
+ call gswind (gd, xs, xe, ys, ye)
+
+ nx = x2 - x1 + 1
+ ny = y2 - y1 + 1
+ if (! clgetb ("cntrplot.fill"))
+ call gsetr (gd, G_ASPECT, real (ny-1) / real (nx-1))
+ call gseti (gd, G_ROUND, btoi (clgetb ("cntrplot.round")))
+
+ if (clgetb ("cntrplot.box")) {
+
+ # Get number of major and minor tick marks.
+ call gseti (gd, G_XNMAJOR, clgeti ("cntrplot.majrx"))
+ call gseti (gd, G_XNMINOR, clgeti ("cntrplot.minrx"))
+ call gseti (gd, G_YNMAJOR, clgeti ("cntrplot.majry"))
+ call gseti (gd, G_YNMINOR, clgeti ("cntrplot.minry"))
+
+ # Label tick marks on axes ?
+ call gseti (gd, G_LABELTICKS, btoi (clgetb ("cntrplot.ticklabels")))
+
+ # Construct the title.
+ call salloc (longtitle, 2 * SZ_LINE, TY_CHAR)
+ if (clgetb ("cntrplot.banner")) {
+ call sysid (Memc[longtitle], 2 * SZ_LINE)
+ call sprintf (Memc[longtitle+strlen(Memc[longtitle])],
+ 2 * SZ_LINE,
+ "\nObject at x: %g y: %g\n\nContour plot of %s[%d:%d,%d:%d]\n")
+ call pargr (x)
+ call pargr (y)
+ call pargstr (IM_HDRFILE(im))
+ call pargi (x1)
+ call pargi (x2)
+ call pargi (y1)
+ call pargi (y2)
+ } else {
+ call sprintf (Memc[longtitle], 2 * SZ_LINE,
+ "\nObject at x: %g y: %g\n\nContour plot of %s[%d:%d,%d:%d]\n")
+ call pargr (x)
+ call pargr (y)
+ call pargstr (IM_HDRFILE(im))
+ call pargi (x1)
+ call pargi (x2)
+ call pargi (y1)
+ call pargi (y2)
+ }
+
+ call glabax (gd, Memc[longtitle], "", "")
+ }
+
+ # First of all, intialize conrec's block data before altering any
+ # parameters in common.
+ first = 1
+ call conbd
+
+ # Set the contouring parameters.
+ zero = clgetr ("cntrplot.zero")
+ floor = clgetr ("cntrplot.floor")
+ ceiling = clgetr ("cntrplot.ceiling")
+ nhi = clgeti ("cntrplot.nhi")
+ dashpat = clgeti ("cntrplot.dashpat")
+
+ # Resolve INDEF limits.
+ npts = nx * ny
+ if (IS_INDEFR (floor) || IS_INDEFR (ceiling)) {
+ call alimr (Memr[data], npts, zmin, zmax)
+ if (IS_INDEFR (floor))
+ floor = zmin
+ if (IS_INDEFR (ceiling))
+ ceiling = zmax
+ }
+
+ # Apply the zero point shift.
+ if (abs (zero) > EPSILON) {
+ call salloc (data1, npts, TY_REAL)
+ call asubkr (Memr[data], zero, Memr[data1], npts)
+ floor = floor - zero
+ ceiling = ceiling - zero
+ } else
+ data1 = data
+
+ # Avoid conrec's automatic scaling.
+ if (fp_equalr (floor, 0.0))
+ floor = EPSILON
+ if (fp_equalr (ceiling, 0.0))
+ ceiling = EPSILON
+
+ # The user can suppress the contour labelling by setting the common
+ # parameter "ilab" to zero.
+ if (btoi (clgetb ("cntrplot.label")) == NO)
+ ilab = 0
+ else
+ ilab = 1
+
+ # User can specify either the number of contours or the contour
+ # interval, or let conrec pick a nice number. Get params and
+ # encode the FINC param expected by conrec.
+
+ ncontours = clgeti ("cntrplot.ncontours")
+ if (ncontours <= 0) {
+ interval = clgetr ("cntrplot.interval")
+ if (interval <= 0.0)
+ finc = 0
+ else
+ finc = interval
+ } else
+ finc = - abs (ncontours)
+
+ # Open device and make contour plot.
+ call gopks (STDERR)
+ wkid = 1
+ call gopwk (wkid, 6, gd)
+ call gacwk (wkid)
+
+ # Make the contour plot.
+ nset = 1 # No conrec viewport
+ ioffm = 1 # No conrec box
+ call gswind (gd, 1., real (nx), 1., real (ny))
+ call ggview (gd, vx1, vx2, vy1, vy2)
+ call set (vx1, vx2, vy1, vy2, 1.0, real (nx), 1.0, real (ny), 1)
+ call conrec (Memr[data1], nx, nx, ny, floor, ceiling, finc, nset,
+ nhi, -dashpat)
+
+ call gdawk (wkid)
+ call gclks ()
+
+ call gswind (gd, xs, xe, ys, ye)
+ if (fp_equalr (hold[5], 1.0)) {
+ call sprintf (Memc[longtitle], 2 * SZ_LINE,
+ "\n\nContoured from %g to %g, interval = %g\n\n")
+ call pargr (hold[1])
+ call pargr (hold[2])
+ call pargr (hold[3])
+ } else {
+ call sprintf (Memc[longtitle], 2 * SZ_LINE,
+ "\n\nContoured from %g to %g, interval = %g, labels scaled by %g\n\n")
+ call pargr (hold[1])
+ call pargr (hold[2])
+ call pargr (hold[3])
+ call pargr (hold[5])
+ }
+
+ call gseti (gd, G_DRAWAXES, NO)
+ call glabax (gd, Memc[longtitle], "", "")
+
+ call sfree (sp)
+end
+
+
+# PT_PERIMETER -- Draw and label axes around the surface plot.
+
+procedure pt_perimeter (gd, z, ncols, nlines, angh, angv)
+
+pointer gd # graphics pointer
+int ncols # number of image columns
+int nlines # number of image lines
+real z[ncols, nlines] # array of intensity values
+real angh # angle of horizontal inclination
+real angv # angle of vertical inclination
+
+char tlabel[10]
+int i, j
+pointer sp, x_val, y_val, kvec
+real xmin, ymin, delta, fact1, flo, hi, xcen, ycen
+real x1_perim, x2_perim, y1_perim, y2_perim, z1, z2
+real wc1, wc2, wl1, wl2, del
+int itoc()
+
+data fact1 /2.0/
+real vpx1, vpx2, vpy1, vpy2
+common /noaovp/ vpx1, vpx2, vpy1, vpy2
+
+begin
+ call smark (sp)
+ call salloc (x_val, ncols + 2, TY_REAL)
+ call salloc (y_val, nlines + 2, TY_REAL)
+ call salloc (kvec, max (ncols, nlines) + 2, TY_REAL)
+
+ # Get window coordinates set up calling procedure.
+ call ggwind (gd, wc1, wc2, wl1, wl2)
+
+ # Set up window, viewport for output. The coordinates returned
+ # from trn32s are in the range [1-1024].
+ call set (vpx1, vpx2, vpy1, vpy2, 1.0, 1024., 1.0, 1024., 1)
+
+ # Find range of z for determining perspective.
+ flo = MAX_REAL
+ hi = -flo
+ do j = 1, nlines {
+ call alimr (z[1,j], ncols, z1, z2)
+ flo = min (flo, z1)
+ hi = max (hi, z2)
+ }
+
+ # Set up linear endpoints and spacing as used in surface.
+ delta = (hi-flo) / (max (ncols, nlines) -1.) * fact1
+ xmin = -(real (ncols/2) * delta + real (mod (ncols+1, 2)) * delta)
+ ymin = -(real (nlines/2) * delta + real (mod (nlines+1, 2)) * delta)
+ del = 2.0 * delta
+
+ # The perimeter is separated from the surface plot by the
+ # width of delta.
+ x1_perim = xmin - delta
+ y1_perim = ymin - delta
+ x2_perim = xmin + (real (ncols) * delta)
+ y2_perim = ymin + (real (nlines) * delta)
+
+ # Set up linear arrays over full perimeter range.
+ do i = 1, ncols + 2
+ Memr[x_val+i-1] = x1_perim + (i-1) * delta
+ do i = 1, nlines + 2
+ Memr[y_val+i-1] = y1_perim + (i-1) * delta
+
+ # Draw and label axes and tick marks.
+ # It is important that frame has not been called after calling srface.
+ # First to draw the perimeter. Which axes get drawn depends on the
+ # values of angh and angv. Get angles in the range [-180, 180].
+
+ if (angh > 180.)
+ angh = angh - 360.
+ else if (angh < -180.)
+ angh = angh + 360.
+ if (angv > 180.)
+ angv = angv - 360.
+ else if (angv < -180.)
+ angv = angv + 360.
+
+ # Calculate positions for the axis labels.
+ xcen = 0.5 * (x1_perim + x2_perim)
+ ycen = 0.5 * (y1_perim + y2_perim)
+
+ if (angh >= 0.0) {
+
+ # Case 1: xy rotation positive, looking down from above mid z.
+ if (angv >= 0.0) {
+
+ # First draw x axis.
+ call amovkr (y2_perim, Memr[kvec], ncols + 2)
+ call pt_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1)
+ call pt_label_axis (xcen, y2_perim+del, flo, "X-AXIS", -1, -2)
+ call pt_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta,
+ flo, ncols)
+ if (itoc (int (wc1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (xmin, y2_perim+del, flo, tlabel, -1, -2)
+ if (itoc (int (wc2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (Memr[x_val+ncols], y2_perim+del, flo,
+ tlabel, -1, -2)
+
+ # Now draw y axis.
+ call amovkr (x2_perim, Memr[kvec], nlines + 2)
+ call pt_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1)
+ call pt_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1)
+ call pt_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1],
+ flo, nlines)
+ if (itoc (int (wl1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1)
+ if (itoc (int (wl2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x2_perim+del, Memr[y_val+nlines], flo,
+ tlabel, 2, -1)
+
+ # Case 2: xy rotation positive, looking up from below mid z.
+ } else {
+
+ # First draw x axis.
+ call amovkr (y1_perim, Memr[kvec], ncols + 2)
+ call pt_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1)
+ call pt_label_axis (xcen, y1_perim-del, flo, "X-AXIS", -1, 2)
+ call pt_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta,
+ flo, ncols)
+ if (itoc (int (wc1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (xmin, y1_perim-del, flo, tlabel, -1, 2)
+ if (itoc (int (wc2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (Memr[x_val+ncols], y1_perim-del, flo,
+ tlabel, -1, 2)
+
+ # Now draw y axis.
+ call amovkr (x1_perim, Memr[kvec], nlines + 2)
+ call pt_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1)
+ call pt_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1)
+ call pt_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1],
+ flo, nlines)
+ if (itoc (int (wl1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1)
+ if (itoc (int (wl2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x1_perim-del, Memr[y_val+nlines], flo,
+ tlabel, 2, 1)
+ }
+ }
+
+ if (angh < 0.0) {
+
+ # Case 3: xy rotation negative, looking down from above mid z
+ # (default).
+ if (angv > 0.0) {
+
+ # First draw x axis.
+ call amovkr (y1_perim, Memr[kvec], ncols + 2)
+ call pt_draw_axis (Memr[x_val+1], Memr[kvec], flo, ncols + 1)
+ call pt_label_axis (xcen, y1_perim-del, flo, "X-AXIS", 1, 2)
+ call pt_draw_ticksx (Memr[x_val+1], y1_perim, y1_perim-delta,
+ flo, ncols)
+ if (itoc (int (wc1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (xmin, y1_perim-del, flo, tlabel, 1, 2)
+ if (itoc (int (wc2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (Memr[x_val+ncols], y1_perim-del, flo,
+ tlabel, 1, 2)
+
+ # Now draw y axis.
+ call amovkr (x2_perim, Memr[kvec], nlines + 2)
+ call pt_draw_axis (Memr[kvec], Memr[y_val], flo, nlines + 1)
+ call pt_label_axis (x2_perim+del, ycen, flo, "Y-AXIS", 2, -1)
+ call pt_draw_ticksy (x2_perim, x2_perim+delta, Memr[y_val+1],
+ flo, nlines)
+ if (itoc (int (wl1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x2_perim+del, ymin, flo, tlabel, 2, -1)
+ if (itoc (int (wl2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x2_perim+del, Memr[y_val+nlines], flo,
+ tlabel, 2, -1)
+
+ # Case 4: xy rotation negative, looking up from below mid Z.
+ } else {
+
+ # First draw x axis.
+ call amovkr (y2_perim, Memr[kvec], ncols + 2)
+ call pt_draw_axis (Memr[x_val], Memr[kvec], flo, ncols + 1)
+ call pt_label_axis (xcen, y2_perim+del, flo, "X-AXIS", 1, -2)
+ call pt_draw_ticksx (Memr[x_val+1], y2_perim, y2_perim+delta,
+ flo, ncols)
+ if (itoc (int (wc1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (xmin, y2_perim+del, flo, tlabel, 1, -2)
+ if (itoc (int (wc2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (Memr[x_val+ncols], y2_perim+del, flo,
+ tlabel, 1, -2)
+
+ # Now draw y axis.
+ call amovkr (x1_perim, Memr[kvec], nlines + 2)
+ call pt_draw_axis (Memr[kvec], Memr[y_val+1], flo, nlines + 1)
+ call pt_label_axis (x1_perim-del, ycen, flo, "Y-AXIS", 2, 1)
+ call pt_draw_ticksy (x1_perim, x1_perim-delta, Memr[y_val+1],
+ flo, nlines)
+ if (itoc (int (wl1), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x1_perim-del, ymin, flo, tlabel, 2, 1)
+ if (itoc (int (wl2), tlabel, 10) <= 0)
+ tlabel[1] = EOS
+ call pt_label_axis (x1_perim-del, Memr[y_val+nlines], flo,
+ tlabel, 2, 1)
+ }
+ }
+
+ # Flush plotit buffer before returning.
+ call plotit (0, 0, 2)
+ call sfree (sp)
+end
+
+
+# PT_DRAW_AXIS -- Draw the axes around the plot.
+
+procedure pt_draw_axis (xvals, yvals, zval, nvals)
+
+real xvals[nvals]
+real yvals[nvals]
+real zval
+int nvals
+
+int i
+pointer sp, xt, yt
+real dum
+
+begin
+ call smark (sp)
+ call salloc (xt, nvals, TY_REAL)
+ call salloc (yt, nvals, TY_REAL)
+
+ do i = 1, nvals
+ call trn32s (xvals[i], yvals[i], zval, Memr[xt+i-1], Memr[yt+i-1],
+ dum, 1)
+
+ call gpl (nvals, Memr[xt], Memr[yt])
+ call sfree (sp)
+end
+
+
+# PT_LABEL_AXIS -- Label the axes.
+
+procedure pt_label_axis (xval, yval, zval, sppstr, path, up)
+
+real xval
+real yval
+real zval
+char sppstr[SZ_LINE]
+int path
+int up
+
+int nchars
+int strlen()
+% character*64 fstr
+
+begin
+ nchars = strlen (sppstr)
+% call f77pak (sppstr, fstr, 64)
+ call pwrzs (xval, yval, zval, fstr, nchars, CSIZE, path, up, 0)
+end
+
+
+# PT_DRAW_TICKSX -- Draw the x tick marks.
+
+procedure pt_draw_ticksx (x, y1, y2, zval, nvals)
+
+real x[nvals]
+real y1, y2
+real zval
+int nvals
+
+int i
+real tkx[2], tky[2], dum
+
+begin
+ do i = 1, nvals {
+ call trn32s (x[i], y1, zval, tkx[1], tky[1], dum, 1)
+ call trn32s (x[i], y2, zval, tkx[2], tky[2], dum, 1)
+ call gpl (2, tkx[1], tky[1])
+ }
+end
+
+
+# PT_DRAW_TICKSY -- Draw the y tick marks.
+
+procedure pt_draw_ticksy (x1, x2, y, zval, nvals)
+
+real x1, x2
+real y[nvals]
+real zval
+int nvals
+
+int i
+real tkx[2], tky[2], dum
+
+begin
+ do i = 1, nvals {
+ call trn32s (x1, y[i], zval, tkx[1], tky[1], dum, 1)
+ call trn32s (x2, y[i], zval, tkx[2], tky[2], dum, 1)
+ call gpl (2, tkx[1], tky[1])
+ }
+end
+
+
+# PT_GDATA -- Get image data with boundary checking.
+
+pointer procedure pt_gdata (im, x1, x2, y1, y2)
+
+pointer im # pointer to the input image
+int x1, x2, y1, y2 # subraster limits both input and output
+
+int i, nc, nl
+pointer imgs2r()
+errchk imgs2r
+
+begin
+ nc = IM_LEN(im,1)
+ nl = IM_LEN(im,2)
+ if (IS_INDEFI (x1))
+ x1 = 1
+ if (IS_INDEFI (x2))
+ x2 = nc
+ if (IS_INDEFI (y1))
+ y1 = 1
+ if (IS_INDEFI (y2))
+ y2 = nl
+
+ i = max (x1, x2)
+ x1 = min (x1, x2)
+ x2 = i
+ i = max (y1, y2)
+ y1 = min (y1, y2)
+ y2 = i
+
+ if (x2 < 1 || x1 > nc || y2 < 1 || y1 > nl)
+ return (NULL)
+
+ x1 = max (1, x1)
+ x2 = min (nc, x2)
+ y1 = max (1, y1)
+ y2 = min (nl, y2)
+
+ return (imgs2r (im, x1, x2, y1, y2))
+end
+
+
+# PT_RADPIX -- Procedure to fetch the image pixels in an annulus around
+# a given center.
+
+int procedure pt_radpix (im, wx, wy, rin, rout, rcoords, pix)
+
+pointer im # pointer to IRAF image
+real wx, wy # center of sky annulus
+real rin, rout # inner and outer radius of sky annulus
+real rcoords[ARB] # radial coordinate array
+real pix[ARB] # pixel array
+
+int i, j, ncols, nlines, c1, c2, l1, l2, npix
+pointer buf
+real xc1, xc2, xl1, xl2, rin2, rout2, rj2, r2
+pointer imgs2r()
+
+begin
+ if (rout <= rin)
+ return (0)
+
+ # Test for out of bounds sky regions.
+ ncols = IM_LEN(im,1)
+ nlines = IM_LEN(im,2)
+ xc1 = wx - rout
+ xc2 = wx + rout
+ xl1 = wy - rout
+ xl2 = wy + rout
+ if (xc2 < 1.0 || xc1 > real (ncols) || xl2 < 1.0 || xl1 > real (nlines))
+ return (0)
+
+ # Compute the column and line limits.
+ c1 = max (1.0, min (real (ncols), wx - rout)) + 0.5
+ c2 = min (real (ncols), max (1.0, wx + rout)) + 0.5
+ l1 = max (1.0, min (real (nlines), wy - rout)) + 0.5
+ l2 = min (real (nlines), max (1.0, wy + rout)) + 0.5
+
+ # Fetch the sky pixels.
+ rin2 = rin ** 2
+ rout2 = rout ** 2
+ npix = 0
+
+ do j = l1, l2 {
+ buf = imgs2r (im, c1, c2, j, j)
+ rj2 = (wy - j) ** 2
+ do i = c1, c2 {
+ r2 = (wx - i) ** 2 + rj2
+ if (r2 > rin2 && r2 <= rout2) {
+ rcoords[npix+1] = sqrt (r2)
+ pix[npix+1] = Memr[buf+i-c1]
+ npix = npix + 1
+ }
+ }
+ }
+
+ return (npix)
+end
diff --git a/noao/digiphot/ptools/pexamine/ptplot.x b/noao/digiphot/ptools/pexamine/ptplot.x
new file mode 100644
index 00000000..beeb9fec
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptplot.x
@@ -0,0 +1,1462 @@
+include <error.h>
+include <mach.h>
+include <ctype.h>
+include <gset.h>
+include <fset.h>
+include <tbset.h>
+include "../../lib/ptkeysdef.h"
+include "pexamine.h"
+
+define GHELPFILE "ptools$pexamine/pexamine.key"
+define FRACTION 0.05
+
+int procedure pt_plot (gd, px, apd, apkey, im, deleted, npix, max_npix,
+ first_star, match_radius, use_display)
+
+pointer gd # pointer to the graphics stream
+pointer px # pointer to the pexamine structure
+pointer apd # the input catalog descriptor
+pointer apkey # pointer to the text file structure
+pointer im # pointer to the input image
+int deleted[ARB] # array of deleted values
+int npix # number of points
+int max_npix # maximum number of points
+int first_star # first object read in
+real match_radius # tolerance in pixels for cursor positioning
+int use_display # use the image display
+
+int newdata, newxy, xyinvalid, newhist, hinvalid, plottype, newplot
+int firstplot, newcoo, cooinvalid, undelete, status, key, starno, curtype
+pointer sp, title, xlabel, ylabel, cmd, x, y, h, xpos, ypos
+real wx, wy, twx, twy
+
+bool fp_equalr()
+int pt_rxydata(), pt_rhdata(), pt_rcoodata(), pt_getphot(), pt_fstarg()
+int pt_gcur(), pt_gldata()
+
+define replot_ 91
+
+begin
+ # Allocate working stack space.
+ call smark (sp)
+ call salloc (title, SZ_LINE, TY_CHAR)
+ call salloc (xlabel, SZ_LINE, TY_CHAR)
+ call salloc (ylabel, SZ_LINE, TY_CHAR)
+ call salloc (cmd, SZ_LINE, TY_CHAR)
+
+ # Initialize some parameters.
+ twx = INDEFR
+ twy = INDEFR
+ newdata = NO
+ newxy = YES
+ newhist = YES
+ newcoo = YES
+ newplot = YES
+ firstplot = YES
+ curtype = 'g'
+ plottype = PX_XYPLOT
+ call amovki (PX_GOOD, deleted, npix)
+
+ undelete = NO
+
+replot_
+ if (newdata == YES) {
+ if (apkey != NULL) {
+ call pt_kyfree (apkey)
+ call pt_kyinit (apkey)
+ }
+ npix = pt_getphot (px, apd, apkey, npix, first_star)
+ }
+
+ if (newxy == YES)
+ xyinvalid = pt_rxydata (px, x, y)
+ if (newhist == YES)
+ hinvalid = pt_rhdata (px, h)
+ if (newcoo == YES)
+ cooinvalid = pt_rcoodata (px, xpos, ypos)
+
+ switch (plottype) {
+ case PX_XYPLOT:
+ call pt_xyinfo (px, apd, apkey, Memc[title], SZ_LINE,
+ Memc[xlabel], Memc[ylabel], SZ_LINE)
+ if (xyinvalid == NO) {
+ if (newplot == YES) {
+ call pt_xyplot (gd, Memr[x], Memr[y], deleted, npix,
+ Memc[title], Memc[xlabel], Memc[ylabel])
+ }
+ } else {
+ call printf ("Cannot plot X: %s versus Y: %s\n")
+ call pargstr (Memc[xlabel])
+ call pargstr (Memc[ylabel])
+ }
+
+ case PX_HISTPLOT:
+ call pt_hinfo (px, apd, apkey, Memc[title], SZ_LINE,
+ Memc[xlabel], Memc[ylabel], SZ_LINE)
+ if (hinvalid == NO) {
+ if (newplot == YES) {
+ call pt_hplot (gd, Memr[h], deleted, npix, Memc[title],
+ Memc[xlabel], Memc[ylabel])
+ }
+ } else {
+ call printf ("Cannot plot histogram of %s\n")
+ call pargstr (Memc[xlabel])
+ }
+
+ case PX_RADPLOT:
+ if (im != NULL) {
+ if (newplot == YES)
+ call pt_rplot (gd, im, twx, twy)
+ } else
+ call printf ("The input image is undefined\n")
+
+ case PX_SURFPLOT:
+ if (im != NULL) {
+ if (newplot == YES)
+ call pt_splot (gd, im, twx, twy)
+ } else
+ call printf ("The input image is undefined\n")
+
+ case PX_CNTRPLOT:
+ if (im != NULL) {
+ if (newplot == YES)
+ call pt_cplot (gd, im, twx, twy)
+ } else
+ call printf ("The input image is undefined\n")
+
+ default:
+ call printf ("Invalid plot type\n")
+ }
+
+ if ((firstplot == YES || newdata == YES) && (xyinvalid == NO)) {
+ call printf ("nstars read: %d first_star: %d max_nstars: %d\n")
+ call pargi (npix)
+ call pargi (first_star)
+ call pargi (max_npix)
+ }
+
+ newdata = NO
+ newxy = NO
+ newcoo = NO
+ newhist = NO
+ newplot = NO
+ firstplot = NO
+
+ while (pt_gcur (curtype, wx, wy, key, Memc[cmd], SZ_LINE) != EOF) {
+
+ switch (key) {
+
+ # Quit and do not make changes.
+ case 'q':
+ call printf ("Type 'q' to confirm quit without saving edits\n")
+ if (pt_gcur (curtype, wx, wy, key, Memc[cmd], SZ_LINE) == EOF)
+ next
+ if (key != 'q')
+ next
+ status = PX_QUIT
+ break
+
+ # Exit and do the changes.
+ case 'e':
+ status = PX_EXIT
+ break
+
+ # Print the help page.
+ case '?':
+ call gpagefile (gd, GHELPFILE, "")
+
+ # Activate the graphics cursor.
+ case 'g':
+ curtype = 'g'
+
+ # Activate the image cursor.
+ case 'i':
+ if (use_display == YES)
+ curtype = 'i'
+ else
+ call printf ("The image display is not available\n")
+
+ # Plot the current y column versus the current x column.
+ case 'x':
+ if (plottype != PX_XYPLOT) {
+ newplot = YES
+ plottype = PX_XYPLOT
+ }
+ if (newplot == YES)
+ goto replot_
+
+ # Plot the current histogram.
+ case 'h':
+ if (plottype != PX_HISTPLOT) {
+ newplot = YES
+ plottype = PX_HISTPLOT
+ }
+ if (newplot == YES)
+ goto replot_
+
+ # Print a matrix of points around the cursor.
+ case 'm':
+ if (im == NULL) {
+ call printf ("The input image is undefined\n")
+ next
+ } else if (cooinvalid == YES) {
+ call printf ("The x or y coordinate data is undefined\n")
+ next
+ } else if (curtype == 'i') {
+ starno = pt_fstarg (gd, wx, wy, Memr[xpos], Memr[ypos],
+ npix, match_radius)
+ } else if (xyinvalid == YES) {
+ call printf ("The x or y column data is undefined\n")
+ next
+ } else if (plottype != PX_XYPLOT) {
+ call printf ("Points must be marked on an X-Y plot\n")
+ next
+ } else {
+ starno = pt_fstarg (gd, wx, wy, Memr[x], Memr[y], npix,
+ INDEFR)
+ }
+
+ if (starno > 0)
+ call pt_print (gd, im, Memr[xpos+starno-1],
+ Memr[ypos+starno-1])
+
+ # Plot the the radial profile of the point nearest the graphics
+ # cursor.
+ case 'r', 's', 'c':
+
+ if (im == NULL) {
+ call printf ("The input image is undefined\n")
+ next
+ }
+ if (cooinvalid == YES) {
+ call printf ("The x or y coordinate data is undefined\n")
+ next
+ }
+
+ if (curtype == 'i') {
+ starno = pt_fstarg (gd, wx, wy, Memr[xpos], Memr[ypos],
+ npix, match_radius)
+ } else if (xyinvalid == YES) {
+ call printf ("The x or y column data is undefined\n")
+ next
+ } else if (plottype != PX_XYPLOT) {
+ call printf ("Points must be marked on the X-Y plot\n")
+ next
+ } else {
+ starno = pt_fstarg (gd, wx, wy, Memr[x], Memr[y], npix,
+ INDEFR)
+ }
+
+ if (starno > 0) {
+ switch (key) {
+ case 'r':
+ if (plottype != PX_RADPLOT)
+ newplot = YES
+ plottype = PX_RADPLOT
+ case 'c':
+ if (plottype != PX_CNTRPLOT)
+ newplot = YES
+ plottype = PX_CNTRPLOT
+ case 's':
+ if (plottype != PX_SURFPLOT)
+ newplot = YES
+ plottype = PX_SURFPLOT
+ }
+ wx = Memr[xpos+starno-1]
+ wy = Memr[ypos+starno-1]
+ if (! fp_equalr (wx, twx) && ! fp_equalr (wy, twy)) {
+ newplot = YES
+ twx = wx
+ twy = wy
+ }
+ } else
+ call printf ("Cannot find selected star in the catalog\n")
+
+ if (newplot == YES)
+ goto replot_
+
+ # Replot the current plot.
+ case 'p':
+ newplot = YES
+ goto replot_
+
+ # Print out the names, types and units of all defined columns.
+ case 'l':
+ call pt_colinfo (gd, apd, apkey)
+
+ # Print out the names, values and units of the stored columns
+ # for the object nearest the cursor.
+ case 'o':
+ if (curtype == 'g') {
+ if (xyinvalid == YES)
+ call printf ("The x or y column data is undefined\n")
+ else if (plottype != PX_XYPLOT)
+ call printf ("Points must be marked on an x-y plot\n")
+ else {
+ starno = pt_gldata (gd, px, apd, apkey, wx, wy,
+ Memr[x], Memr[y], npix, INDEFR)
+ if (starno > 0)
+ call printf ("Star found\n")
+ else
+ call printf ("Star not found\n")
+ }
+ } else if (curtype == 'i') {
+ if (cooinvalid == NO) {
+ starno = pt_gldata (gd, px, apd, apkey, wx, wy,
+ Memr[xpos], Memr[ypos], npix, match_radius)
+ if ((gd != NULL) && (starno > 0) && (xyinvalid == NO) &&
+ (plottype == PX_XYPLOT)) {
+ call gscur (gd, Memr[x+starno-1], Memr[y+starno-1])
+ call printf ("Star found\n")
+ curtype = 'g'
+ } else
+ call printf ("Star not found\n")
+ } else
+ call printf (
+ "The x or y coordinate data is undefined\n")
+ }
+
+ # Undelete everything.
+ case 'z':
+ call amovki (PX_GOOD, deleted, npix)
+ newplot = YES
+ goto replot_
+
+ # Delete points and replot.
+ case 'f':
+ call pt_update (deleted, npix)
+ newplot = YES
+ goto replot_
+
+ # Mark a point for deletion.
+ case 'd':
+ if (curtype == 'g') {
+ if ((xyinvalid == YES) || (plottype != PX_XYPLOT))
+ call printf (
+ "Invalid plot type for deleting points\n")
+ else
+ call pt_delpt (gd, wx, wy, Memr[x], Memr[y], Memr[x],
+ Memr[y], deleted, npix, NO, INDEFR)
+ } else if (curtype == 'i') {
+ if (cooinvalid == NO) {
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT))
+ call pt_delpt (gd, wx, wy, Memr[xpos], Memr[ypos],
+ Memr[x], Memr[y], deleted, npix, NO,
+ match_radius)
+ else
+ call pt_delpt (NULL, wx, wy, Memr[xpos], Memr[ypos],
+ Memr[x], Memr[y], deleted, npix, NO,
+ match_radius)
+ } else
+ call printf (
+ "The x or y coordinate data is undefined\n")
+ }
+
+ # Undelete a point marked for deletion.
+ case 'u':
+ if (curtype == 'g') {
+ if ((xyinvalid == YES) || (plottype != PX_XYPLOT))
+ call printf (
+ "Invalid plot type for undeleting points\n")
+ else
+ call pt_delpt (gd, wx, wy, Memr[x], Memr[y], Memr[x],
+ Memr[y], deleted, npix, YES, INDEFR)
+ } else if (curtype == 'i') {
+ if (cooinvalid == NO) {
+ if (xyinvalid == NO && plottype == PX_XYPLOT)
+ call pt_delpt (gd, wx, wy, Memr[xpos], Memr[ypos],
+ Memr[x], Memr[y], deleted, npix, YES,
+ match_radius)
+ else
+ call pt_delpt (NULL, wx, wy, Memr[xpos], Memr[ypos],
+ Memr[x], Memr[y], deleted, npix, YES,
+ match_radius)
+ } else
+ call printf (
+ "The x and y coordinate data is undefined\n")
+ }
+
+ # Toggle the delete/undelete function
+ case 't':
+ if (undelete == NO) {
+ call printf ("Now undeleting points\n")
+ undelete = YES
+ } else if (undelete == YES) {
+ call printf ("Now deleting points\n")
+ undelete = NO
+ }
+
+ # Mark for deletion points with X < X (cursor).
+ case '(':
+ if (curtype == 'g') {
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT)) {
+ call pt_dxltg (gd, wx, Memr[x], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ } else if ((hinvalid == NO) && plottype == PX_HISTPLOT) {
+ call pt_dxltg (NULL, wx, Memr[h], Memr[h], Memr[h],
+ deleted, npix, undelete)
+ newplot = YES
+ } else
+ call printf (
+ "Invalid plot type for (un)deleting points\n")
+ } else if (curtype == 'i') {
+ if (cooinvalid == YES) {
+ call printf (
+ "The x or y coordinate data is undefined\n")
+ } else if ((xyinvalid == NO) && (plottype == PX_XYPLOT)) {
+ call pt_dxltg (gd, wx, Memr[xpos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ } else {
+ call pt_dxltg (NULL, wx, Memr[xpos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ if (plottype == PX_XYPLOT || plottype == PX_HISTPLOT)
+ newplot = YES
+ else
+ call printf (
+ "Replot x-y or histogram to show (un)deletions\n")
+ }
+ }
+ if (newplot == YES)
+ goto replot_
+
+ # Mark for deletion points with X > X (cursor).
+ case ')':
+ if (curtype == 'g') {
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT)) {
+ call pt_dxgtg (gd, wx, Memr[x], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ } else if ((hinvalid == NO) && (plottype == PX_HISTPLOT)) {
+ call pt_dxgtg (NULL, wx, Memr[h], Memr[h], Memr[h],
+ deleted, npix, undelete)
+ newplot = YES
+ } else
+ call printf (
+ "Invalid plot type for (un)deleting points\n")
+ } else if (curtype == 'i') {
+ if (cooinvalid == YES) {
+ call printf (
+ "The x and y coordinate data is undefined\n")
+ } else if ((xyinvalid == NO) && (plottype == PX_XYPLOT)) {
+ call pt_dxgtg (gd, wx, Memr[xpos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ } else {
+ call pt_dxgtg (NULL, wx, Memr[xpos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ if (plottype == PX_XYPLOT || plottype == PX_HISTPLOT)
+ newplot = YES
+ else
+ call printf (
+ "Replot x-y or histogram to show (un)deletions\n")
+ }
+ }
+ if (newplot == YES)
+ goto replot_
+
+ # Mark for deletion points with Y > Y (cursor).
+ case '^':
+ if (curtype == 'g') {
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT))
+ call pt_dygtg (gd, wy, Memr[y], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ else
+ call printf (
+ "Invalid plot type for (un)deleting points\n")
+ } else if (curtype == 'i') {
+ if (cooinvalid == YES)
+ call printf (
+ "The x and y coordinate data is undefined\n")
+ else if ((xyinvalid == NO) && (plottype == PX_XYPLOT))
+ call pt_dygtg (gd, wy, Memr[ypos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ else {
+ call pt_dygtg (NULL, wy, Memr[ypos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ if (plottype == PX_XYPLOT || plottype == PX_HISTPLOT)
+ newplot = YES
+ else
+ call printf (
+ "Replot x-y or histogram to show (un)deletions\n")
+ }
+ }
+ if (newplot == YES)
+ goto replot_
+
+ # Mark for deletion points with Y < Y (cursor).
+ case 'v':
+ if (curtype == 'g') {
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT))
+ call pt_dyltg (gd, wy, Memr[y], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ else
+ call printf (
+ "Invalid plot type for (un)deleting points\n")
+ } else if (curtype == 'i') {
+ if (cooinvalid == YES)
+ call printf (
+ "The x and y coordinate data is undefined\n")
+ else if ((xyinvalid == NO) && (plottype == PX_XYPLOT))
+ call pt_dyltg (gd, wy, Memr[ypos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ else {
+ call pt_dyltg (NULL, wy, Memr[ypos], Memr[x], Memr[y],
+ deleted, npix, undelete)
+ if (plottype == PX_XYPLOT || plottype == PX_HISTPLOT)
+ newplot = YES
+ else
+ call printf (
+ "Replot x-y or histogram to show (un)deletions\n")
+ }
+ }
+ if (newplot == YES)
+ goto replot_
+
+ # Mark points for deletion inside a box.
+ case 'b':
+ if (curtype == 'g') {
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT)) {
+ twx = wx; twy = wy
+ call printf ("again:\n")
+ if (pt_gcur (curtype, wx, wy, key, Memc[cmd],
+ SZ_LINE) == EOF)
+ next
+ call pt_dboxg (gd, Memr[x], Memr[y], Memr[x], Memr[y],
+ deleted, npix, twx, twy, wx, wy, undelete)
+ } else
+ call printf (
+ "Invalid plot type for (un)deleting points\n")
+ } else if (curtype == 'i') {
+ if (cooinvalid == YES)
+ call printf (
+ "The x or y coordinate data is undefined\n")
+ else {
+ twx = wx; twy = wy
+ call printf ("again:\n")
+ if (pt_gcur (curtype, wx, wy, key, Memc[cmd],
+ SZ_LINE) == EOF)
+ next
+ if ((xyinvalid == NO) && (plottype == PX_XYPLOT))
+ call pt_dboxg (gd, Memr[xpos], Memr[ypos], Memr[x],
+ Memr[y], deleted, npix, twx, twy, wx, wy,
+ undelete)
+ else {
+ call pt_dboxg (NULL, Memr[xpos], Memr[ypos],
+ Memr[x], Memr[y], deleted, npix, twx, twy,
+ wx, wy, undelete)
+ if ((plottype == PX_XYPLOT) ||
+ (plottype == PX_HISTPLOT))
+ newplot = YES
+ else
+ call printf (
+ "Replot x-y or histogram to show (un)deletions\n")
+ }
+ }
+ }
+
+ # Colon commands:
+ case ':':
+ iferr (call pt_colon (px, gd, Memc[cmd], newdata, newxy,
+ newhist, newcoo, newplot, plottype, undelete))
+ call erract (EA_WARN)
+ if (newplot == YES)
+ goto replot_
+
+ default:
+ call printf ("Unknown or ambiguous keystroke command\007\n")
+ }
+ }
+
+ call sfree (sp)
+
+ return (status)
+end
+
+
+# PT_PRINT -- Print a 10 by 10 box of pixel values around the star.
+
+procedure pt_print (gd, im, x, y)
+
+pointer gd # pointer to the graphics stream
+pointer im # pointer to the input image
+real x, y # center of box
+
+int i, j, x1, x2, y1, y2, nx
+pointer data
+pointer pt_gdata()
+
+begin
+ if (gd != NULL)
+ call gdeactivate (gd, 0)
+
+ # Check that the image is defined.
+ if (im == NULL) {
+ call printf ("The input image is undefined\n")
+ return
+ }
+
+ # Check that the center is defined.
+ if (IS_INDEFR(x) || IS_INDEFR(y)) {
+ call printf ("The box center is undefined\n")
+ return
+ }
+
+ x1 = x - 5 + 0.5
+ x2 = x + 5 + 0.5
+ y1 = y - 5 + 0.5
+ y2 = y + 5 + 0.5
+ data = pt_gdata (im, x1, x2, y1, y2)
+ if (data == NULL) {
+ call printf ("The requested image section is off the image\n")
+ return
+ }
+ nx = x2 - x1 + 1
+
+ call printf ("\n%4w")
+ do i = x1, x2 {
+ call printf (" %4d ")
+ call pargi (i)
+ }
+ call printf ("\n")
+
+ do j = y2, y1, -1 {
+ call printf ("%4d")
+ call pargi (j)
+ do i = x1, x2 {
+ call printf (" %5g")
+ call pargr (Memr[data+(j-y1)*nx+(i-x1)])
+ }
+ call printf ("\n")
+ }
+ call printf ("\n")
+
+ if (gd != NULL)
+ call greactivate (gd, 0)
+end
+
+
+define LEN_TYPESTR 9
+
+# PT_COLINFO -- Print the name, type and units of all the columns in the
+# input catalog.
+
+procedure pt_colinfo (gd, apd, key)
+
+pointer gd # pointer to the graphics stream
+pointer apd # the file descriptor for the input catalog
+int key # the key structure for text catalogs
+
+int len_colname, i, datatype, numelems
+pointer tty, sp, name, units, type, junk, colptr
+int tbpsta(), tbcigi(), pt_gnfn(), pt_kstati()
+pointer ttyodes(), tbcnum(), pt_ofnl()
+
+begin
+ if (gd != NULL)
+ call gdeactivate (gd, AW_CLEAR)
+ else {
+ tty = ttyodes ("terminal")
+ call ttyclear (STDOUT, tty)
+ }
+
+ len_colname = max (SZ_COLNAME, KY_SZPAR)
+ call printf ("\n%*.*s %*.*s %s\n\n")
+ call pargi (-len_colname)
+ call pargi (len_colname)
+ call pargstr ("COLUMN")
+ call pargi (-LEN_TYPESTR)
+ call pargi (LEN_TYPESTR)
+ call pargstr ("TYPE")
+ call pargstr ("UNITS")
+
+ call smark (sp)
+ call salloc (name, len_colname, TY_CHAR)
+ call salloc (units, max (SZ_COLUNITS, KY_SZPAR), TY_CHAR)
+ call salloc (type, LEN_TYPESTR, TY_CHAR)
+
+ if (key == NULL) {
+
+ do i = 1, tbpsta (apd, TBL_NCOLS) {
+
+ colptr = tbcnum (apd, i)
+ call tbcigt (colptr, TBL_COL_NAME, Memc[name], SZ_COLNAME)
+ call tbcigt (colptr, TBL_COL_UNITS, Memc[units], SZ_COLUNITS)
+ datatype = tbcigi (colptr, TBL_COL_DATATYPE)
+ switch (datatype) {
+ case TY_BOOL:
+ call strcpy ("boolean", Memc[type], LEN_TYPESTR)
+ case TY_SHORT, TY_INT, TY_LONG:
+ call strcpy ("integer", Memc[type], LEN_TYPESTR)
+ case TY_REAL:
+ call strcpy ("real", Memc[type], LEN_TYPESTR)
+ case TY_DOUBLE:
+ call strcpy ("double", Memc[type], LEN_TYPESTR)
+ default:
+ if (datatype < 0)
+ call strcpy ("character", Memc[type], LEN_TYPESTR)
+ else
+ call strcpy ("undefined", Memc[type], LEN_TYPESTR)
+ }
+
+ call printf ("%*.*s %*.*s %s\n")
+ call pargi (-len_colname)
+ call pargi (len_colname)
+ call pargstr (Memc[name])
+ call pargi (-LEN_TYPESTR)
+ call pargi (LEN_TYPESTR)
+ call pargstr (Memc[type])
+ call pargstr (Memc[units])
+ }
+
+ } else {
+
+ call salloc (junk, SZ_LINE, TY_CHAR)
+ colptr = pt_ofnl (key, "*")
+ while (pt_gnfn (colptr, Memc[name], Memc[junk], KY_SZPAR) != EOF) {
+ #if (pt_kstati (key, Memc[name], KY_INDEX) <= KY_NOKEYS(key))
+ if (pt_kstati (key, Memc[name], KY_INDEX) <= KY_NPKEYS(key))
+ next
+ numelems = pt_kstati (key, Memc[name], KY_NUMELEMS)
+ call pt_kstats (key, Memc[name], KY_UNITSTR, Memc[units],
+ KY_SZPAR)
+ datatype = pt_kstati (key, Memc[name], KY_DATATYPE)
+ switch (datatype) {
+ case TY_BOOL:
+ call strcpy ("boolean", Memc[type], LEN_TYPESTR)
+ case TY_CHAR:
+ call strcpy ("character", Memc[type], LEN_TYPESTR)
+ case TY_INT:
+ call strcpy ("integer", Memc[type], LEN_TYPESTR)
+ case TY_REAL:
+ call strcpy ("real", Memc[type], LEN_TYPESTR)
+ default:
+ call strcpy ("undefined", Memc[type], LEN_TYPESTR)
+ }
+
+ do i = 1, numelems {
+ if (numelems == 1)
+ call strcpy (Memc[name], Memc[junk], KY_SZPAR)
+ else {
+ call sprintf (Memc[junk], KY_SZPAR, "%s[%d]")
+ call pargstr (Memc[name])
+ call pargi (numelems)
+ }
+ call printf ("%*.*s %*.*s %s\n")
+ call pargi (-len_colname)
+ call pargi (len_colname)
+ call pargstr (Memc[junk])
+ call pargi (-LEN_TYPESTR)
+ call pargi (LEN_TYPESTR)
+ call pargstr (Memc[type])
+ call pargstr (Memc[units])
+ }
+
+ }
+ call pt_cfnl (colptr)
+
+ }
+ call printf ("\n")
+
+ call sfree (sp)
+
+ if (gd != NULL)
+ call greactivate (gd, AW_PAUSE)
+ else
+ call ttycdes (tty)
+end
+
+
+# PT_GLDATA -- List the values of the loaded columns for this point.
+
+int procedure pt_gldata (gd, px, apd, key, wx, wy, x, y, npix, matchrad)
+
+pointer gd # pointer to the graphics stream
+pointer px # pointer to the pexamine structure
+int apd # file descriptor for catalog
+pointer key # pointer to the key structure for text files
+real wx # the graphics cursor x coordinate
+real wy # the graphics cursor y coordinate
+real x[ARB] # the array of x plotted data
+real y[ARB] # the array of y plotted data
+int npix # the number of points
+real matchrad # matching radius
+
+int row, ip, ncol
+pointer sp, name, units, colptr
+int pt_getnames(), pt_fstarg()
+
+begin
+ if (gd != NULL)
+ call gdeactivate (gd, 0)
+
+ # Find the star.
+ row = pt_fstarg (gd, wx, wy, x, y, npix, matchrad)
+
+ # List the values of the loaded columns.
+ if (row != 0) {
+
+ call smark (sp)
+ call salloc (name, PX_SZCOLNAME, TY_CHAR)
+ call salloc (units, max (KY_SZPAR, SZ_COLUNITS), TY_CHAR)
+
+ call printf ("\n%*.*s %s (%s)\n\n")
+ call pargi (-PX_SZCOLNAME)
+ call pargi (PX_SZCOLNAME)
+ call pargstr ("COLUMN")
+ call pargstr ("VALUE")
+ call pargstr ("UNITS")
+
+ ip = 1
+ ncol = 0
+ while (pt_getnames (Memc[PX_COLNAMES(px)], ip, Memc[name],
+ PX_SZCOLNAME) != EOF) {
+ if (PX_COLPTRS(px) == NULL)
+ next
+ if (key == NULL) {
+ call tbcfnd (apd, Memc[name], colptr, 1)
+ call tbcigt (colptr, TBL_COL_UNITS, Memc[units],
+ SZ_COLUNITS)
+ } else
+ call pt_kstats (key, Memc[name], KY_UNITSTR, Memc[units],
+ KY_SZPAR)
+ call printf ("%*.*s %g (%s)\n")
+ call pargi (-PX_SZCOLNAME)
+ call pargi (PX_SZCOLNAME)
+ call pargstr (Memc[name])
+ call pargr (Memr[Memi[PX_COLPTRS(px)+ncol]+row-1])
+ call pargstr (Memc[units])
+ ncol = ncol + 1
+ }
+ call printf ("\n")
+
+ call sfree (sp)
+ }
+
+ if (gd != NULL)
+ call greactivate (gd, 0)
+
+ return (row)
+end
+
+
+# PT_XYPLOT -- Plot the x and y points.
+
+procedure pt_xyplot (gd, x, y, deleted, npix, title, xlabel, ylabel)
+
+pointer gd # pointer to the graphics stream
+real x[ARB] # array of x coordinates
+real y[ARB] # array of y coordinates
+int deleted[ARB] # deletions array
+int npix # number of points
+char title[ARB] # title of the plot
+char xlabel[ARB] # x axis label
+char ylabel[ARB] # y axis label
+
+int i, marker_type
+pointer sp, marker, longtitle
+real szmarker, x1, x2, y1, y2, dmin, dmax
+bool clgetb()
+int clgeti(), strlen()
+real clgetr()
+
+begin
+ # Check for undefined graphis stream.
+ if (gd == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Allocate working space.
+ call smark (sp)
+ call salloc (marker, SZ_FNAME, TY_CHAR)
+ call salloc (longtitle, 2 * SZ_LINE, TY_CHAR)
+
+ # Clear the plotting strucuture.
+ call gclear (gd)
+
+ # Fetch the window and viewport parameters.
+ x1 = clgetr ("xyplot.x1")
+ x2 = clgetr ("xyplot.x2")
+ y1 = clgetr ("xyplot.y1")
+ y2 = clgetr ("xyplot.y2")
+ if (IS_INDEFR(x1) || IS_INDEFR(x2)) {
+ call pt_alimr (x, npix, dmin, dmax)
+ if (IS_INDEFR(x1))
+ x1 = dmin - FRACTION * (dmax - dmin)
+ if (IS_INDEFR(x2))
+ x2 = dmax + FRACTION * (dmax - dmin)
+ }
+ if (IS_INDEFR(y1) || IS_INDEFR(y2)) {
+ call pt_alimr (y, npix, dmin, dmax)
+ if (IS_INDEFR(y1))
+ y1 = dmin - FRACTION * (dmax - dmin)
+ if (IS_INDEFR(y2))
+ y2 = dmax + FRACTION * (dmax - dmin)
+ }
+
+ # Set the scale of the axes.
+ call gswind (gd, x1, x2, y1, y2)
+ if (clgetb ("xyplot.logx"))
+ call gseti (gd, G_XTRAN, GW_LOG)
+ else
+ call gseti (gd, G_XTRAN, GW_LINEAR)
+ if (clgetb ("xyplot.logy"))
+ call gseti (gd, G_YTRAN, GW_LOG)
+ else
+ call gseti (gd, G_YTRAN, GW_LINEAR)
+
+ # Get the x and y axes parameters.
+ if (! clgetb ("xyplot.fill"))
+ call gseti (gd, G_ASPECT, 1)
+ if (clgetb ("xyplot.round"))
+ call gseti (gd, G_ROUND, YES)
+
+ # Get the axis drawing parameters.
+ if (clgetb ("xyplot.box")) {
+
+ # Get number of major and minor tick marks.
+ call gseti (gd, G_XNMAJOR, clgeti ("xyplot.majrx"))
+ call gseti (gd, G_XNMINOR, clgeti ("xyplot.minrx"))
+ call gseti (gd, G_YNMAJOR, clgeti ("xyplot.majry"))
+ call gseti (gd, G_YNMINOR, clgeti ("xyplot.minry"))
+
+ # Label tick marks on axes.
+ if (clgetb ("xyplot.ticklabels"))
+ call gseti (gd, G_LABELTICKS, YES)
+ else
+ call gseti (gd, G_LABELTICKS, NO)
+
+ # Draw grid.
+ if (clgetb ("xyplot.grid"))
+ call gseti (gd, G_DRAWGRID, YES)
+ else
+ call gseti (gd, G_DRAWGRID, NO)
+
+ # Optionally draw a box around the plot.
+ if (clgetb ("xyplot.banner")) {
+ call sysid (Memc[longtitle], 2 * SZ_LINE)
+ call sprintf (Memc[longtitle+strlen(Memc[longtitle])],
+ 2 * SZ_LINE, "\n%s")
+ call pargstr (title)
+ } else
+ call strcpy (title, Memc[longtitle], 2 * SZ_LINE)
+ call glabax (gd, Memc[longtitle], xlabel, ylabel)
+
+ }
+
+ # Get the marker type, the size of the marker and the linewidth.
+ call clgstr ("xyplot.marker", Memc[marker], SZ_FNAME)
+ call pt_marker (Memc[marker], SZ_FNAME, marker_type)
+ if (marker_type != GM_POINT)
+ szmarker = clgetr ("xyplot.szmarker")
+ else
+ szmarker = 0.0
+ call gsetr (gd, G_PLWIDTH, 2.0)
+
+ # Draw the points in using the deletions array.
+ do i = 1, npix {
+ if (deleted[i] == PX_DELETE)
+ next
+ call gmark (gd, x[i], y[i], marker_type, szmarker, szmarker)
+ }
+
+ # Overplot crosses for those new points marked for deletion.
+ call pt_mdelete (gd, x, y, deleted, npix)
+
+ call gflush (gd)
+ call sfree (sp)
+end
+
+
+# PT_HPLOT -- Compute and plot histogram.
+
+procedure pt_hplot (gd, x, deleted, npix, title, xlabel, ylabel)
+
+pointer gd # pointer to the graphics stream
+real x[ARB] # array of points to be made into a histogram
+int deleted[ARB] # deletions array
+int npix # number of pixels
+char title[ARB] # the title of the plot
+char xlabel[ARB] # the x axis label
+char ylabel[ARB] # the y axis label
+
+int i, j, nbins, nbins1
+pointer sp, hgm, xp, yp, longtitle
+real z1, z2, dz, x1, x2, y1, y2, dmin, dmax
+bool clgetb(), fp_equalr()
+int clgeti(), strlen()
+real clgetr()
+
+begin
+ # Check for undefined graphis stream.
+ if (gd == NULL) {
+ call printf ("The graphics device is undefined\n")
+ return
+ }
+
+ # Get default histogram resolution and range.
+ nbins = clgeti ("histplot.nbins")
+ z1 = clgetr ("histplot.z1")
+ z2 = clgetr ("histplot.z2")
+
+ # Use data limits for INDEF limits.
+ if (IS_INDEFR(z1) || IS_INDEFR(z2)) {
+ call pt_alimr (x, npix, dmin, dmax)
+ if (IS_INDEFR(z1))
+ z1 = dmin
+ if (IS_INDEFR(z2))
+ z2 = dmax
+ }
+ if (z1 > z2) {
+ dz = z1
+ z1 = z2
+ z2 = dz
+ }
+
+ # Test for constant valued image, which causes zero divide in ahgm.
+ if (fp_equalr (z1, z2)) {
+ call printf ("Warning: Histogram has no data range.\n")
+ return
+ }
+
+ # The extra bin counts the pixels that equal z2 and shifts the
+ # remaining bins to evenly cover the interval [z1,z2].
+ # Note that real numbers could be handled better - perhaps
+ # adjust z2 upward by ~ EPSILONR (in ahgm itself).
+
+ nbins1 = nbins + 1
+
+ # Initialize the histogram buffer and image line vector.
+ call smark (sp)
+ call salloc (hgm, nbins1, TY_INT)
+ call aclri (Memi[hgm], nbins1)
+
+ # Accumulate the histogram. Add the ability to use the deletions
+ # array in future.
+ call pt_ahgmr (x, deleted, npix, Memi[hgm], nbins1, z1, z2)
+
+ # "Correct" the topmost bin for pixels that equal z2. Each
+ # histogram bin really wants to be half open.
+
+ if (clgetb ("histplot.top_closed"))
+ Memi[hgm+nbins-1] = Memi[hgm+nbins-1] + Memi[hgm+nbins1-1]
+
+ # List or plot the histogram. In list format, the bin value is the
+ # z value of the left side (start) of the bin.
+
+ dz = (z2 - z1) / real (nbins)
+
+ # Plot the histogram in box mode.
+ nbins1 = 2 * nbins + 2
+ call salloc (xp, nbins1, TY_REAL)
+ call salloc (yp, nbins1, TY_REAL)
+ Memr[xp] = z1
+ Memr[yp] = 0.0
+ j = 1
+ do i = 0, nbins - 1 {
+ Memr[xp+j] = Memr[xp+j-1]
+ Memr[yp+j] = Memi[hgm+i]
+ j = j + 1
+ Memr[xp+j] = Memr[xp+j-1] + dz
+ Memr[yp+j] = Memr[yp+j-1]
+ j = j + 1
+ }
+ Memr[xp+j] = Memr[xp+j-1]
+ Memr[yp+j] = 0.0
+
+ # Construct the title.
+ call salloc (longtitle, 2 * SZ_LINE, TY_CHAR)
+ if (clgetb ("histplot.banner")) {
+ call sysid (Memc[longtitle], 2 * SZ_LINE)
+ call sprintf (Memc[longtitle+strlen(Memc[longtitle])], 2 * SZ_LINE,
+ "\nHistogram from z1=%g to z2=%g, nbins=%d\n%s")
+ call pargr (z1)
+ call pargr (z2)
+ call pargi (nbins)
+ call pargstr (title)
+ } else {
+ call sprintf (Memc[longtitle], 2 * SZ_LINE,
+ "Histogram from z1=%g to z2=%g, nbins=%d\n%s")
+ call pargr (z1)
+ call pargr (z2)
+ call pargi (nbins)
+ call pargstr (title)
+ }
+
+ # Clear the screen.
+ call gclear (gd)
+
+ # Compute the data window to be plotted.
+ x1 = clgetr ("histplot.x1")
+ x2 = clgetr ("histplot.x2")
+ if (IS_INDEFR(x1) || IS_INDEFR(x2)) {
+ call alimr (Memr[xp], nbins1, dmin, dmax)
+ if (IS_INDEFR(x1))
+ x1 = dmin
+ if (IS_INDEFR(x2))
+ x2 = dmax
+ }
+ y1 = clgetr ("histplot.y1")
+ y2 = clgetr ("histplot.y2")
+ if (IS_INDEFR(y1) || IS_INDEFR(y2)) {
+ call alimr (Memr[yp], nbins1, dmin, dmax)
+ if (IS_INDEFR(y1))
+ y1 = dmin
+ if (IS_INDEFR(y2))
+ y2 = dmax
+ }
+
+ # Set the scale of the axes.
+ call gswind (gd, x1, x2, y1, y2)
+ call gseti (gd, G_XTRAN, GW_LINEAR)
+ if (clgetb ("histplot.logy"))
+ call gseti (gd, G_YTRAN, GW_LOG)
+ else
+ call gseti (gd, G_YTRAN, GW_LINEAR)
+
+ if (! clgetb ("xyplot.fill"))
+ call gseti (gd, G_ASPECT, 1)
+ if (clgetb ("xyplot.round"))
+ call gseti (gd, G_ROUND, YES)
+ call gsetr (gd, G_PLWIDTH, 2.0)
+
+ # Draw a box around the axes.
+ if (clgetb ("histplot.box")) {
+
+ # Label tick marks on axes.
+ if (clgetb ("histplot.ticklabels"))
+ call gseti (gd, G_LABELTICKS, YES)
+ else
+ call gseti (gd, G_LABELTICKS, NO)
+
+ # Get number of major and minor tick marks.
+ call gseti (gd, G_XNMAJOR, clgeti ("histplot.majrx"))
+ call gseti (gd, G_XNMINOR, clgeti ("histplot.minrx"))
+ call gseti (gd, G_YNMAJOR, clgeti ("histplot.majry"))
+ call gseti (gd, G_YNMINOR, clgeti ("histplot.minry"))
+
+ # Draw the axes.
+ call glabax (gd, Memc[longtitle], xlabel, ylabel)
+
+ }
+
+ # Draw the historgram.
+ call gseti (gd, G_PLTYPE, GL_SOLID)
+ call gpline (gd, Memr[xp], Memr[yp], nbins1)
+ call gflush (gd)
+
+ call sfree (sp)
+end
+
+
+# PT_XYINFO -- Get the title and axes labels for the X-Y plot.
+
+procedure pt_xyinfo (px, tp, key, title, max_sztitle, xlabel, ylabel,
+ max_szlabel)
+
+pointer px # pointer to the pexamine strcuture
+pointer tp # input catalog file descriptor
+pointer key # pointer to key structure for text files
+char title[ARB] # title for the plot
+int max_sztitle # maximum length of the title
+char xlabel[ARB] # X axis label
+char ylabel[ARB] # Y axis label
+int max_szlabel # maximum size of the label
+
+pointer sp, label, units, cd
+
+begin
+ call smark (sp)
+ call salloc (label, max_szlabel, TY_CHAR)
+ call salloc (units, max_szlabel, TY_CHAR)
+
+ # Get the title.
+
+ # Get the x and y labels for the columns.
+ if (key == NULL) {
+
+ call tbtnam (tp, title, max_sztitle)
+
+ call tbcfnd (tp, PX_XCOLNAME(px), cd, 1)
+ if (cd != NULL) {
+ call strcpy (PX_XCOLNAME(px), Memc[label], max_szlabel)
+ call tbcigt (cd, TBL_COL_UNITS, Memc[units], SZ_COLUNITS)
+ } else {
+ call strcpy ("UNDEFINED", Memc[label], max_szlabel)
+ Memc[units] = EOS
+ }
+ call sprintf (xlabel, max_szlabel, "%s in %s")
+ call pargstr (Memc[label])
+ call pargstr (Memc[units])
+
+ call tbcfnd (tp, PX_YCOLNAME(px), cd, 1)
+ if (cd != NULL) {
+ call strcpy (PX_YCOLNAME(px), Memc[label], max_szlabel)
+ call tbcigt (cd, TBL_COL_UNITS, Memc[units], SZ_COLUNITS)
+ } else {
+ call strcpy ("UNDEFINED", Memc[label], max_szlabel)
+ Memc[units] = EOS
+ }
+ call sprintf (ylabel, max_szlabel, "%s in %s")
+ call pargstr (Memc[label])
+ call pargstr (Memc[units])
+
+ } else {
+
+ call fstats (tp, F_FILENAME, title, max_sztitle)
+
+ if (PX_XCOLNAME(px) == EOS) {
+ call strcpy ("UNDEFINED", Memc[label], max_szlabel)
+ Memc[units] = EOS
+ } else {
+ call strcpy (PX_XCOLNAME(px), Memc[label], max_szlabel)
+ call pt_kstats (key, PX_XCOLNAME(px), KY_UNITSTR, Memc[units],
+ max_szlabel)
+ }
+ call sprintf (xlabel, max_szlabel, "%s %s")
+ call pargstr (Memc[label])
+ call pargstr (Memc[units])
+
+ if (PX_YCOLNAME(px) == EOS) {
+ call strcpy ("UNDEFINED", Memc[label], max_szlabel)
+ Memc[units] = EOS
+ } else {
+ call strcpy (PX_YCOLNAME(px), Memc[label], max_szlabel)
+ call pt_kstats (key, PX_YCOLNAME(px), KY_UNITSTR, Memc[units],
+ max_szlabel)
+ }
+ call sprintf (ylabel, max_szlabel, "%s %s")
+ call pargstr (Memc[label])
+ call pargstr (Memc[units])
+
+ }
+
+ call sfree (sp)
+end
+
+
+# PT_HINFO -- Get the title and axes labels for the histogram plot.
+
+procedure pt_hinfo (px, tp, key, title, max_sztitle, xlabel, ylabel,
+ max_szlabel)
+
+pointer px # pointer to the pexamine strcuture
+pointer tp # input catalog file descriptor
+pointer key # pointer to key structure for text files
+char title[ARB] # title for the plot
+int max_sztitle # maximum length of the title
+char xlabel[ARB] # X axis label
+char ylabel[ARB] # Y axis label
+int max_szlabel # maximum size of the label
+
+pointer sp, label, units, cd
+
+begin
+ call smark (sp)
+ call salloc (label, max_szlabel, TY_CHAR)
+ call salloc (units, max_szlabel, TY_CHAR)
+
+ # Get the title.
+
+ # Get the x and y labels for the columns.
+ if (key == NULL) {
+
+ call tbtnam (tp, title, max_sztitle)
+
+ call tbcfnd (tp, PX_HCOLNAME(px), cd, 1)
+ if (cd != NULL) {
+ call strcpy (PX_HCOLNAME(px), Memc[label], max_szlabel)
+ call tbcigt (cd, TBL_COL_UNITS, Memc[units], SZ_COLUNITS)
+ } else {
+ call strcpy ("UNDEFINED", Memc[label], max_szlabel)
+ Memc[units] = EOS
+ }
+ call sprintf (xlabel, max_szlabel, "%s in %s")
+ call pargstr (Memc[label])
+ call pargstr (Memc[units])
+
+ call sprintf (ylabel, max_szlabel, "N(%s)")
+ call pargstr (Memc[label])
+
+ } else {
+
+ call fstats (tp, F_FILENAME, title, max_sztitle)
+
+ if (PX_HCOLNAME(px) == EOS) {
+ call strcpy ("UNDEFINED", Memc[label], max_szlabel)
+ Memc[units] = EOS
+ } else {
+ call strcpy (PX_HCOLNAME(px), Memc[label], max_szlabel)
+ call pt_kstats (key, PX_HCOLNAME(px), KY_UNITSTR, Memc[units],
+ max_szlabel)
+ }
+ call sprintf (xlabel, max_szlabel, "%s %s")
+ call pargstr (Memc[label])
+ call pargstr (Memc[units])
+
+ call sprintf (ylabel, max_szlabel, "N(%s)")
+ call pargstr (Memc[label])
+
+ }
+
+ call sfree (sp)
+end
+
+
+# PT_GCUR -- Get PEXAMINE cursor value.
+# This is an interface between the standard cursor input and PEXAMINE.
+# It reads the appropriate cursor, makes the appropriate default
+# coordinate conversions when using graphics cursor input, and gets any
+# further cursor reads needed. Missing coordinates default to the last
+# coordinates.
+
+int procedure pt_gcur (curtype, x, y, key, strval, maxch)
+
+int curtype # cursor type
+real x, y # cursor position
+int key # keystroke value of cursor event
+char strval[ARB] # string value, if any
+int maxch # max chars out
+
+char ch
+int nitems, wcs, ip
+int clgcur(), ctor(), cctoc()
+errchk clgcur
+
+begin
+ # Initialize.
+ strval[1] = EOS
+
+ # Get a cursor values from the desired cursor parameter.
+ switch (curtype) {
+ case 'i':
+ nitems = clgcur ("icommands", x, y, wcs, key, strval, maxch)
+ case 'g':
+ nitems = clgcur ("gcommands", x, y, wcs, key, strval, maxch)
+ }
+
+ call flush (STDOUT)
+
+ # Map numeric colon sequences (: x [y] key strval) to make them appear
+ # as ordinary "x y key" type cursor reads. This makes it possible for
+ # the user to access any command using typed in rather than positional
+ # cursor coordinates. Special treatment is also given to the syntax
+ # ":lN" and ":cN", provided for compatibility with IMPLOT for simple
+ # line and column plots.
+
+ if (key == ':') {
+ for (ip=1; IS_WHITE(strval[ip]); ip=ip+1)
+ ;
+ if (IS_DIGIT(strval[ip])) {
+ if (ctor (strval, ip, x) <= 0)
+ ;
+ if (ctor (strval, ip, y) <= 0)
+ y = x
+ for (; IS_WHITE(strval[ip]); ip=ip+1)
+ ;
+ if (cctoc (strval, ip, ch) > 0)
+ key = ch
+ call strcpy (strval[ip], strval, maxch)
+
+ }
+ }
+
+ return (nitems)
+end
+
+
+# PT_FSTARG -- Find the the point data point nearest the input position.
+
+int procedure pt_fstarg (gd, wx, wy, x, y, npix, matchrad)
+
+pointer gd # pointer to the graphics descriptor
+real wx # X cursor position
+real wy # Y cursor position
+real x[ARB] # X array of plotted data
+real y[ARB] # Y array of plotted data
+int npix # number of pixels
+real matchrad # the matching radius
+
+int i, row
+real r2min, r2, mr2, wx0, wy0, x0, y0
+
+begin
+ row = 0
+ r2min = MAX_REAL
+ if (IS_INDEFR(matchrad)) {
+ mr2 = MAX_REAL
+ if (gd != NULL)
+ call gctran (gd, wx, wy, wx0, wy0, 1, 0)
+ else {
+ wx0 = wx
+ wy0 = wy
+ }
+ } else {
+ mr2 = matchrad ** 2
+ wx0 = wx
+ wy0 = wy
+ }
+
+ # Search for the nearest point.
+ do i = 1 , npix {
+ if (! IS_INDEFR(x[i]) && ! IS_INDEFR(y[i])) {
+ if (IS_INDEFR(matchrad)) {
+ if (gd != NULL)
+ call gctran (gd, x[i], y[i], x0, y0, 1, 0)
+ else {
+ x0 = x[i]
+ y0 = y[i]
+ }
+ } else {
+ x0 = x[i]
+ y0 = y[i]
+ }
+ r2 = (wx0 - x0) ** 2 + (wy0 - y0) ** 2
+ } else
+ r2 = MAX_REAL
+ if (r2 >= r2min)
+ next
+ r2min = r2
+ row = i
+ }
+
+ if ((row != 0) && (r2min <= mr2))
+ return (row)
+ else
+ return (0)
+end
+
+
+# PT_MARKER -- Return an integer code for the marker type string.
+
+procedure pt_marker (marker, maxch, imark)
+
+char marker[ARB] # string defining the marker type
+int maxch # maximum length of the marker name
+int imark # the integer code for the marker
+
+int i
+int strdic()
+
+begin
+ i = strdic (marker, marker, maxch, PX_MARKERS)
+ switch (i) {
+ case 1:
+ imark = GM_POINT
+ case 2:
+ imark = GM_BOX
+ case 3:
+ imark = GM_PLUS
+ case 4:
+ imark = GM_CROSS
+ case 5:
+ imark = GM_CIRCLE
+ case 6:
+ imark = GM_HLINE
+ case 7:
+ imark = GM_VLINE
+ case 8:
+ imark = GM_DIAMOND
+ default:
+ imark = GM_BOX
+ call strcpy ("box", marker, maxch)
+ }
+end
diff --git a/noao/digiphot/ptools/pexamine/ptrddata.x b/noao/digiphot/ptools/pexamine/ptrddata.x
new file mode 100644
index 00000000..ff0864b9
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptrddata.x
@@ -0,0 +1,125 @@
+include "../../lib/ptkeysdef.h"
+include "pexamine.h"
+
+# PT_RXYDATA -- Load the data for the input columns from the structure.
+
+int procedure pt_rxydata (px, xptr, yptr)
+
+pointer px # pointer to the pexamine structure
+pointer xptr # pointer to the X coordinate array
+pointer yptr # pointer to the Y coordinate array
+
+int data_invalid, field
+pointer sp, str
+int strdic()
+
+begin
+ data_invalid = NO
+
+ # Allocate some temporary memory
+ call smark (sp)
+ call salloc (str, PX_SZCOLNAME, TY_CHAR)
+
+ # Load the x column.
+ field = strdic (PX_XCOLNAME(px), Memc[str], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)])
+ if (field > 0)
+ xptr = Memi[PX_COLPTRS(px)+field-1]
+ else {
+ xptr = NULL
+ data_invalid = YES
+ }
+
+ # Load the y column.
+ field = strdic (PX_YCOLNAME(px), Memc[str], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)])
+ if (field > 0)
+ yptr = Memi[PX_COLPTRS(px)+field-1]
+ else {
+ yptr = NULL
+ data_invalid = YES
+ }
+
+ call sfree (sp)
+
+ return (data_invalid)
+end
+
+
+# PT_RHDATA -- Load the data for the histogram column from the structure.
+
+int procedure pt_rhdata (px, xptr)
+
+pointer px # pointer to the pexamine structure
+pointer xptr # array containing the x points
+
+int data_invalid, field
+pointer sp, str
+int strdic()
+
+begin
+ data_invalid = NO
+
+ # Allocate some temporary memory
+ call smark (sp)
+ call salloc (str, PX_SZCOLNAME, TY_CHAR)
+
+ # Load the x column.
+ field = strdic (PX_HCOLNAME(px), Memc[str], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)])
+ if (field > 0)
+ xptr = Memi[PX_COLPTRS(px)+field-1]
+ else {
+ xptr = NULL
+ data_invalid = YES
+ }
+
+ call sfree (sp)
+
+ return (data_invalid)
+end
+
+
+# PT_RCOODATA -- Load the coordinate data from the structure.
+
+int procedure pt_rcoodata (px, xptr, yptr)
+
+pointer px # pointer to the pexamine structure
+pointer xptr # pointer to x coordinates array
+pointer yptr # pointer to y coordinates array
+
+int data_invalid, field
+pointer sp, str
+int strdic()
+
+begin
+ data_invalid = NO
+
+ # Allocate some temporary memory
+ call smark (sp)
+ call salloc (str, PX_SZCOLNAME, TY_CHAR)
+
+ # Load the x coordinate.
+ field = strdic (PX_XPOSNAME(px), Memc[str], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)])
+ if (field > 0)
+ xptr = Memi[PX_COLPTRS(px)+field-1]
+ else {
+ data_invalid = YES
+ xptr = NULL
+ }
+
+ # Load the y coordinate.
+ field = strdic (PX_YPOSNAME(px), Memc[str], PX_SZCOLNAME,
+ Memc[PX_COLNAMES(px)])
+ if (field > 0)
+ yptr = Memi[PX_COLPTRS(px)+field-1]
+ else {
+ data_invalid = YES
+ yptr = NULL
+ }
+
+ call sfree (sp)
+
+ return (data_invalid)
+end
diff --git a/noao/digiphot/ptools/pexamine/ptsetup.x b/noao/digiphot/ptools/pexamine/ptsetup.x
new file mode 100644
index 00000000..5a8bc832
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptsetup.x
@@ -0,0 +1,360 @@
+include <error.h>
+include <ctotok.h>
+include "pexamine.h"
+
+# PT_INIT - Initialize the pexamine structure.
+
+pointer procedure pt_init (photcols, usercols, xcol, ycol, xpos, ypos, hcol)
+
+char photcols[ARB] # the list of photometry columns
+char usercols[ARB] # the list of user columns
+char xcol[ARB] # the name of the x column
+char ycol[ARB] # the name of the y column
+char xpos[ARB] # the name of the x coord column
+char ypos[ARB] # the name of the y coord column
+char hcol[ARB] # the name of the histogram column
+
+pointer px
+bool streq()
+int strdic()
+
+begin
+ # Preload the daophot and apphot photometry fields.
+ if (streq ("DAOPHOT", photcols) || streq ("daophot", photcols))
+ call strcpy (PX_DAOCOLS, photcols, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+ else if (streq ("APPHOT", photcols) || streq ("apphot", photcols))
+ call strcpy (PX_APCOLS, photcols, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+
+ # Allocate space for the pexamine structure and the column lists.
+ call malloc (px, LEN_PXSTRUCT, TY_STRUCT)
+
+ # Initialize the requested column information.
+ PX_RNPHOT(px) = 0; PX_RNUSER(px) = 0; PX_RNCOLS(px) = 0
+ call malloc (PX_RCOLNAMES(px), PX_SZCOLNAME * (PX_MAXNCOLS + 1),
+ TY_CHAR)
+ Memc[PX_RCOLNAMES(px)] = EOS
+
+ # Initialize the stored column information.
+ PX_NPHOT(px) = 0; PX_NUSER(px) = 0; PX_NCOLS(px) = 0
+ call malloc (PX_COLNAMES(px), PX_SZCOLNAME * (PX_MAXNCOLS + 1),
+ TY_CHAR)
+ Memc[PX_COLNAMES(px)] = EOS
+
+ # Decode the column strings. Check that the number of columns
+ # does not exceed the maximum number permitted, by extracting
+ # the column names one by one from the photometry and user column
+ # strings.
+
+ call pt_setnames (px, photcols, usercols)
+
+ # Convert all the input column name specifications to upper case.
+ call strupr (xcol)
+ call strupr (ycol)
+ call strupr (xpos)
+ call strupr (ypos)
+ call strupr (hcol)
+
+ # Decode the x and y columns.
+ if (strdic (xcol, PX_RXCOLNAME(px), PX_SZCOLNAME,
+ Memc[PX_RCOLNAMES(px)]) <= 0)
+ call strcpy (xcol, PX_RXCOLNAME(px), PX_SZCOLNAME)
+ if (strdic (ycol, PX_RYCOLNAME(px), PX_SZCOLNAME,
+ Memc[PX_RCOLNAMES(px)]) <= 0)
+ call strcpy (ycol, PX_RYCOLNAME(px), PX_SZCOLNAME)
+
+ # Decode the y and y coordinate column names.
+ if (strdic (xpos, PX_RXPOSNAME(px), PX_SZCOLNAME,
+ Memc[PX_RCOLNAMES(px)]) <= 0)
+ call strcpy (xpos, PX_RXPOSNAME(px), PX_SZCOLNAME)
+ if (strdic (ypos, PX_RYPOSNAME(px), PX_SZCOLNAME,
+ Memc[PX_RCOLNAMES(px)]) <= 0)
+ call strcpy (ypos, PX_RYPOSNAME(px), PX_SZCOLNAME)
+
+ # Decode the histogram column name.
+ if (strdic (hcol, PX_RHCOLNAME(px), PX_SZCOLNAME,
+ Memc[PX_RCOLNAMES(px)]) <= 0)
+ call strcpy (hcol, PX_RHCOLNAME(px), PX_SZCOLNAME)
+
+ # Allocate space for the pointers and initialize them to NULL.
+ call malloc (PX_COLPTRS(px), PX_MAXNCOLS, TY_POINTER)
+ call amovki (NULL, Memi[PX_COLPTRS(px)], PX_MAXNCOLS)
+
+ return (px)
+end
+
+
+# PT_FREE -- Free memory used by the pexamine task.
+
+procedure pt_free (px)
+
+pointer px
+
+int i
+
+begin
+ # Free the column lists.
+ if (PX_RCOLNAMES(px) != NULL)
+ call mfree (PX_RCOLNAMES(px), TY_CHAR)
+ if (PX_COLNAMES(px) != NULL)
+ call mfree (PX_COLNAMES(px), TY_CHAR)
+
+ # Free the column pointers.
+ do i = 1, PX_MAXNCOLS {
+ if (Memi[PX_COLPTRS(px)+i-1] != NULL)
+ call mfree (Memi[PX_COLPTRS(px)+i-1], TY_REAL)
+ }
+ if (PX_COLPTRS(px) != NULL)
+ call mfree (PX_COLPTRS(px), TY_POINTER)
+
+ # Free the pexamine structure.
+ call mfree (px, TY_STRUCT)
+end
+
+
+# PT_SETNAMES -- Decode the photometry and user columns.
+
+procedure pt_setnames (px, photcols, usercols)
+
+pointer px # pointer to the pexamine strucuture
+char photcols[ARB] # list of photometry columns
+char usercols[ARB] # list of user columns
+
+int ip, nphot
+pointer sp, name
+int pt_getnames()
+
+begin
+ call smark (sp)
+ call salloc (name, PX_SZCOLNAME, TY_CHAR)
+
+ call strupr (photcols)
+ call strupr (usercols)
+ Memc[PX_RCOLNAMES(px)] = EOS
+
+ ip = 1
+ nphot = 0
+ while (pt_getnames (photcols, ip, Memc[name], PX_SZCOLNAME) != EOF) {
+ if (nphot >= PX_MAXNCOLS)
+ break
+ #if (Memc[name] == EOS)
+ #next
+ call strcat (",", Memc[PX_RCOLNAMES(px)], PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], Memc[PX_RCOLNAMES(px)], PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ nphot = nphot + 1
+ }
+ PX_RNPHOT(px) = nphot
+
+ # Decode the user columns.
+ ip = 1
+ while (pt_getnames (usercols, ip, Memc[name], PX_SZCOLNAME) != EOF) {
+ if (nphot >= PX_MAXNCOLS)
+ break
+ #if (Memc[name] == EOS)
+ #next
+ call strcat (",", Memc[PX_RCOLNAMES(px)], PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], Memc[PX_RCOLNAMES(px)], PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ nphot = nphot + 1
+ }
+ PX_RNUSER(px) = nphot - PX_RNPHOT(px)
+
+ PX_RNCOLS(px) = nphot
+
+ call sfree (sp)
+end
+
+
+# PT_GPHOTCOLS -- Extract the requested and stored photometric columns
+# from the pexamine structure.
+
+procedure pt_gphotcols (px, rphotcols, rnphot, photcols, nphot)
+
+pointer px # pointer to the pexamine structure
+char rphotcols[ARB] # list of requested photometric columns
+int rnphot # number of requested photometric columns
+char photcols[ARB] # list of photometric columns
+int nphot # number of photometric columns
+
+int ip, ncols
+pointer sp, name
+int pt_getnames()
+
+begin
+ call smark (sp)
+ call salloc (name, PX_SZCOLNAME, TY_CHAR)
+
+ ip = 1
+ ncols = 0
+ rphotcols[1] = EOS
+ while (pt_getnames (Memc[PX_RCOLNAMES(px)], ip, Memc[name],
+ PX_SZCOLNAME) != EOF) {
+ #if (Memc[name] == EOS)
+ #next
+ ncols = ncols + 1
+ if (ncols > PX_RNPHOT(px))
+ break
+ call strcat (",", rphotcols, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], rphotcols, PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ }
+ rnphot = PX_RNPHOT(px)
+
+ ip = 1
+ ncols = 0
+ photcols[1] = EOS
+ while (pt_getnames (Memc[PX_COLNAMES(px)], ip, Memc[name],
+ PX_SZCOLNAME) != EOF) {
+ #if (Memc[name] == EOS)
+ #next
+ ncols = ncols + 1
+ if (ncols > PX_NPHOT(px))
+ break
+ call strcat (",", photcols, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], photcols, PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ }
+ nphot = PX_NPHOT(px)
+
+ call sfree (sp)
+end
+
+
+# PT_GUSERCOLS -- Extract the requested and stored user columns
+# from the pexamine structure.
+
+procedure pt_gusercols (px, rusercols, rnuser, usercols, nuser)
+
+pointer px # pointer to the pexamine structure
+char rusercols[ARB] # list of requested user columns
+int rnuser # number of requested user columns
+char usercols[ARB] # list of user columns
+int nuser # number of user columns
+
+int ip, ncols
+pointer sp, name
+int pt_getnames()
+
+begin
+ call smark (sp)
+ call salloc (name, PX_SZCOLNAME, TY_CHAR)
+
+ ip = 1
+ ncols = 0
+ rusercols[1] = EOS
+ while (pt_getnames (Memc[PX_RCOLNAMES(px)], ip, Memc[name],
+ PX_SZCOLNAME) != EOF) {
+ #if (Memc[name] == EOS)
+ #next
+ ncols = ncols + 1
+ if (ncols <= PX_RNPHOT(px))
+ next
+ call strcat (",", rusercols, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], rusercols, PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ }
+ rnuser = PX_RNUSER(px)
+
+ ip = 1
+ ncols = 0
+ usercols[1] = EOS
+ while (pt_getnames (Memc[PX_COLNAMES(px)], ip, Memc[name],
+ PX_SZCOLNAME) != EOF) {
+ #if (Memc[name] == EOS)
+ #next
+ ncols = ncols + 1
+ if (ncols <= PX_NPHOT(px))
+ next
+ call strcat (",", usercols, PX_SZCOLNAME * (PX_MAXNCOLS + 1))
+ call strcat (Memc[name], usercols, PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ }
+ nuser = PX_NUSER(px)
+
+ call sfree (sp)
+end
+
+
+# PT_LCOLS -- List the requested and stored columns with an optional
+# title string.
+
+procedure pt_lcols (title, rcols, rncols, cols, ncols)
+
+char title[ARB] # title string for column listing
+char rcols[ARB] # list of requested columns
+int rncols # the number of requested columns
+char cols[ARB] # list of stored columns
+int ncols # the number of stored columns
+
+int ip1, ip2, i
+pointer sp, name1, name2
+int pt_getnames()
+
+begin
+ call smark (sp)
+ call salloc (name1, PX_SZCOLNAME, TY_CHAR)
+ call salloc (name2, PX_SZCOLNAME, TY_CHAR)
+
+ call printf ("\n%s\n\n")
+ call pargstr (title)
+
+ ip1 = 1
+ ip2 = 1
+ do i = 1, max (rncols, ncols) {
+ if (pt_getnames (rcols, ip1, Memc[name1], PX_SZCOLNAME) == EOF)
+ Memc[name1] = EOS
+ if (pt_getnames (cols, ip2, Memc[name2], PX_SZCOLNAME) == EOF)
+ Memc[name2] = EOS
+ call printf (" requested: %*.*s stored: %*.*s\n")
+ call pargi (-PX_SZCOLNAME)
+ call pargi (PX_SZCOLNAME)
+ call pargstr (Memc[name1])
+ call pargi (-PX_SZCOLNAME)
+ call pargi (PX_SZCOLNAME)
+ call pargstr (Memc[name2])
+ }
+
+ call sfree (sp)
+end
+
+
+# PT_GETNAMES -- Decode the list of column names into list of column names.
+
+int procedure pt_getnames (colnames, ip, name, maxch)
+
+char colnames[ARB] # list of column names
+int ip # pointer in to the list of names
+char name[ARB] # the output column name
+int maxch # maximum length of a column name
+
+int op, token
+int ctotok(), strlen()
+
+begin
+ # Decode the column labels.
+ op = 1
+ while (colnames[ip] != EOS) {
+
+ token = ctotok (colnames, ip, name[op], maxch)
+ if (name[op] == EOS)
+ next
+ if ((token == TOK_UNKNOWN) || (token == TOK_CHARCON))
+ break
+ if ((token == TOK_PUNCTUATION) && (name[op] == ',')) {
+ if (op == 1)
+ next
+ else
+ break
+ }
+
+ op = op + strlen (name[op])
+ }
+
+ name[op] = EOS
+ if ((colnames[ip] == EOS) && (op == 1))
+ return (EOF)
+ else
+ return (op - 1)
+end
diff --git a/noao/digiphot/ptools/pexamine/ptwtfile.x b/noao/digiphot/ptools/pexamine/ptwtfile.x
new file mode 100644
index 00000000..02f5f282
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/ptwtfile.x
@@ -0,0 +1,143 @@
+include "../../lib/ptkeysdef.h"
+include "pexamine.h"
+
+# PT_WTFILE -- Write out the catalogs of selected and rejected objects.
+
+procedure pt_wtfile (apd, key, apout, aprej, deleted, nstars)
+
+int apd # input catalog file descriptor
+pointer key # key structure for textfiles
+int apout # output catalog file descriptor
+int aprej # rejections catalog file descriptor
+int deleted[ARB] # deletions array
+int nstars # number of stars in the catalog
+
+int i, nselect, ndelete
+int pt_selrej()
+
+begin
+ # ST tables format.
+ if (key == NULL) {
+
+ # Write out the good data.
+ if (apout != NULL) {
+ call tbtcre (apout)
+ call tbhcal (apd, apout)
+ nselect = 0
+ do i = 1, nstars {
+ if (deleted[i] == PX_DELETE)
+ next
+ nselect = nselect + 1
+ call tbrcpy (apd, apout, i, nselect)
+ }
+ }
+
+ # Write out the deletions.
+ if (aprej != NULL) {
+ call tbtcre (aprej)
+ call tbhcal (apd, aprej)
+ ndelete = 0
+ do i = 1, nstars {
+ if (deleted[i] != PX_DELETE)
+ next
+ ndelete = ndelete + 1
+ call tbrcpy (apd, aprej, i, ndelete)
+ }
+ }
+
+ # Write out a text file.
+ } else {
+ if (pt_selrej (apd, apout, aprej, deleted, nstars) < nstars)
+ ;
+ }
+end
+
+
+define LEN_LONGLINE 10
+
+# PT_SELREJ -- Select and/or reject records based on evaluating a logical
+# expression.
+
+int procedure pt_selrej (tp_in, tp_out, tp_rej, deleted, nstars)
+
+int tp_in # the input catalog file descriptor
+int tp_out # the output catalog file descriptor
+int tp_rej # the rejections catalog file descriptor
+int deleted[ARB] # the deletions array
+int nstars # maximum number of stars
+
+int record, nchars, buflen, lenrecord
+pointer line, lline
+int getline()
+
+begin
+ # Check that output has been requested.
+ if (tp_out == NULL && tp_rej == NULL)
+ return (0)
+
+ # Rewind the input file.
+ call seek (tp_in, BOF)
+
+ # Initialize the file read.
+ record = 0
+ lenrecord = 0
+ buflen = LEN_LONGLINE * SZ_LINE
+ call malloc (line, SZ_LINE, TY_CHAR)
+ call malloc (lline, buflen, TY_CHAR)
+
+ # Loop over the text file records.
+ repeat {
+
+ # Read in a line of the text file.
+ nchars = getline (tp_in, Memc[line])
+ if (nchars == EOF)
+ break
+
+ # Determine the type of record.
+ if (Memc[line] == KY_CHAR_POUND || Memc[line] == KY_CHAR_NEWLINE) {
+
+ if (tp_out != NULL)
+ call putline (tp_out, Memc[line])
+ if (tp_rej != NULL)
+ call putline (tp_rej, Memc[line])
+
+ } else {
+
+ # Reallocate the temporary record space.
+ if (lenrecord > buflen) {
+ buflen = buflen + SZ_LINE
+ call realloc (lline, buflen, TY_CHAR)
+ }
+
+ # Store the record.
+ call amovc (Memc[line], Memc[lline+lenrecord], nchars)
+ lenrecord = lenrecord + nchars
+ Memc[lline+lenrecord] = EOS
+
+ # Do the record bookkeeping.
+ if (Memc[line+nchars-2] != KY_CHAR_CONT) {
+
+ # Increment the record counter.
+ record = record + 1
+
+ # Write out the expression.
+ if ((tp_out != NULL) && (deleted[record] != PX_DELETE))
+ call putline (tp_out, Memc[lline])
+ if ((tp_rej != NULL) && (deleted[record] == PX_DELETE))
+ call putline (tp_rej, Memc[lline])
+ if (record >= nstars)
+ break
+
+ # Reinitialize the record read.
+ lenrecord = 0
+ }
+ }
+
+ }
+
+ # Cleanup.
+ call mfree (line, TY_CHAR)
+ call mfree (lline, TY_CHAR)
+
+ return (record)
+end
diff --git a/noao/digiphot/ptools/pexamine/t_pexamine.x b/noao/digiphot/ptools/pexamine/t_pexamine.x
new file mode 100644
index 00000000..10db0747
--- /dev/null
+++ b/noao/digiphot/ptools/pexamine/t_pexamine.x
@@ -0,0 +1,188 @@
+include <fset.h>
+include <error.h>
+include "pexamine.h"
+
+# T_PEXAMINE -- Interactively examine and edit APPHOT and DAOPHOT output.
+
+procedure t_pexamine()
+
+pointer input # pointer to the name of the catalog
+pointer output # pointer to the name of the edited catalog
+pointer xcolumn # pointer to the name of the X column
+pointer ycolumn # pointer to the name of the Y column
+pointer xposcolumn # pointer to the name of the X coord column
+pointer yposcolumn # pointer to the name of the Y coord column
+pointer hcolumn # pointer to the name of the histogram column
+pointer photcolumns # pointer to the photometry columns
+pointer usercolumns # pointer to the user columns
+pointer graphics # pointer to the name of the graphics device
+pointer image # pointer to the name of the input image
+pointer reject # pointer to the name of the deletions catalog
+real match_radius # the matching radius
+
+int numrows, max_nstars, first_star, status
+int apd, apout, aprej, use_display
+pointer sp, key, px, gd, im, deleted
+
+bool clgetb()
+int fstati(), access(), clgeti(), pt_getphot(), pt_plot(), open(), btoi()
+pointer gopen(), tbtopn(), pt_init(), immap()
+real clgetr()
+
+begin
+ # Flush on a newline if the standard output is not redirected.
+ if (fstati (STDOUT, F_REDIR) == NO)
+ call fseti (STDOUT, F_FLUSHNL, YES)
+
+ # Get some working memory.
+ call smark (sp)
+ call salloc (input, SZ_FNAME, TY_CHAR)
+ call salloc (output, SZ_FNAME, TY_CHAR)
+ call salloc (image, SZ_FNAME, TY_CHAR)
+ call salloc (reject, SZ_FNAME, TY_CHAR)
+ call salloc (photcolumns, PX_SZCOLNAME * (PX_MAXNCOLS + 1), TY_CHAR)
+ call salloc (xcolumn, PX_SZCOLNAME, TY_CHAR)
+ call salloc (ycolumn, PX_SZCOLNAME, TY_CHAR)
+ call salloc (hcolumn, PX_SZCOLNAME, TY_CHAR)
+ call salloc (xposcolumn, PX_SZCOLNAME, TY_CHAR)
+ call salloc (yposcolumn, PX_SZCOLNAME, TY_CHAR)
+ call salloc (usercolumns, PX_SZCOLNAME * (PX_MAXNCOLS + 1), TY_CHAR)
+ call salloc (graphics, SZ_FNAME, TY_CHAR)
+
+ # Fetch the input and output file parameters and the column
+ # definition parameters.
+ call clgstr ("input", Memc[input], SZ_FNAME)
+ call clgstr ("output", Memc[output], SZ_FNAME)
+ call clgstr ("image", Memc[image], SZ_FNAME)
+ call clgstr ("deletions", Memc[reject], SZ_FNAME)
+ call clgstr ("photcolumns", Memc[photcolumns], PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+ call clgstr ("xcolumn", Memc[xcolumn], PX_SZCOLNAME)
+ call clgstr ("ycolumn", Memc[ycolumn], PX_SZCOLNAME)
+ call clgstr ("hcolumn", Memc[hcolumn], PX_SZCOLNAME)
+ call clgstr ("xposcolumn", Memc[xposcolumn], PX_SZCOLNAME)
+ call clgstr ("yposcolumn", Memc[yposcolumn], PX_SZCOLNAME)
+ call clgstr ("usercolumns", Memc[usercolumns], PX_SZCOLNAME *
+ (PX_MAXNCOLS + 1))
+
+ match_radius = clgetr ("match_radius")
+ max_nstars = clgeti ("max_nstars")
+ first_star = clgeti ("first_star")
+
+ # Get the graphics and display parameters.
+ call clgstr ("icommands.p_filename", Memc[graphics], SZ_FNAME)
+ if (Memc[graphics] != EOS)
+ use_display = YES
+ else
+ use_display = btoi (clgetb ("use_display"))
+ call clgstr ("graphics", Memc[graphics], SZ_FNAME)
+
+ # Initialize the pexamine struture.
+ px = pt_init (Memc[photcolumns], Memc[usercolumns], Memc[xcolumn],
+ Memc[ycolumn], Memc[xposcolumn], Memc[yposcolumn], Memc[hcolumn])
+
+ # Open the input catalog.
+ if (access (Memc[input], 0, TEXT_FILE) == YES) {
+ apd = open (Memc[input], READ_ONLY, TEXT_FILE)
+ call pt_kyinit (key)
+ } else {
+ apd = tbtopn (Memc[input], READ_ONLY, 0)
+ key = NULL
+ }
+
+ # Open the input image.
+ if (Memc[image] == EOS)
+ im = NULL
+ else
+ im = immap (Memc[image], READ_ONLY, 0)
+
+ # Allocate buffer space.
+ iferr {
+ numrows = min (max_nstars, pt_getphot (px, apd, key, max_nstars,
+ first_star))
+ call malloc (deleted, numrows, TY_INT)
+ } then
+ call erract (EA_FATAL)
+
+ # Plot the data and enter the interactive cursor loop.
+ gd = gopen (Memc[graphics], NEW_FILE, STDGRAPH)
+ status = pt_plot (gd, px, apd, key, im, Memi[deleted], numrows,
+ max_nstars, first_star, match_radius, use_display)
+ call gclose (gd)
+
+ if (status == PX_EXIT) {
+
+ # Open the output file.
+ if (Memc[output] != EOS) {
+ if (access (Memc[output], 0, 0) == YES) {
+ call printf ("The catalog %s already exists\n")
+ call pargstr (Memc[output])
+ call mktemp ("out", Memc[output], SZ_FNAME)
+ call printf ("The new output catalog is %s\n")
+ call pargstr (Memc[output])
+ }
+ if (key == NULL)
+ apout = tbtopn (Memc[output], NEW_COPY, apd)
+ else
+ apout = open (Memc[output], NEW_FILE, TEXT_FILE)
+ } else
+ apout = NULL
+
+ # Open a reject points catalog if required.
+ if (Memc[reject] != EOS) {
+ if (access (Memc[reject], 0, 0) == YES) {
+ call printf ("The catalog %s already exists.\n")
+ call pargstr (Memc[reject])
+ call mktemp ("rej", Memc[reject], SZ_FNAME)
+ call printf ("The new rejections catalog is %s\n")
+ call pargstr (Memc[reject])
+ }
+ if (key == NULL)
+ aprej = tbtopn (Memc[reject], NEW_COPY, apd)
+ else
+ aprej = open (Memc[reject], NEW_FILE, TEXT_FILE)
+ } else
+ aprej = NULL
+
+ # Write the output catalog file.
+ call pt_wtfile (apd, key, apout, aprej, Memi[deleted], numrows)
+
+ # Close the output file.
+ if (apout != NULL) {
+ if (key == NULL)
+ call tbtclo (apout)
+ else
+ call close (apout)
+ }
+
+ # Close the rejected points file.
+ if (aprej != NULL) {
+ if (key == NULL)
+ call tbtclo (aprej)
+ else
+ call close (aprej)
+ }
+
+ } else if (status == ERR)
+ call fseti (STDOUT, F_CANCEL, OK)
+
+ # Close the input file.
+ if (key != NULL) {
+ call pt_kyfree (key)
+ call close (apd)
+ } else if (apd != NULL)
+ call tbtclo (apd)
+
+ # Close the image.
+ if (im != NULL)
+ call imunmap(im)
+
+ # Return the buffer space.
+ call mfree (deleted, TY_INT)
+
+ # Free the program structures.
+ call pt_free (px)
+ call sfree (sp)
+ if (status == ERR)
+ call erract (EA_ERROR)
+end
generated by cgit (git 2.34.1) at 2025-09-20 13:25:33 -0400